range-space (empty) → 0.1.0.0
raw patch · 6 files changed
+714/−0 lines, 6 filesdep +QuickCheckdep +basedep +range-spacesetup-changed
Dependencies added: QuickCheck, base, range-space, test-framework, test-framework-quickcheck2, time, vector-space, vector-space-points
Files
- Data/RangeSpace.hs +276/−0
- Data/RangeSpace/TwoD.hs +50/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- range-space.cabal +44/−0
- tests/Properties.hs +312/−0
+ Data/RangeSpace.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}++----------------------------------------------------------------------+{- |+ Module : Data.RangeSpace+ Copyright : John Lato+ License : BSD3 (see LICENSE)++ Maintainer : John Lato <jwlato@gmail.com>+ Stability : unstable+ Portability : unknown++-}+----------------------------------------------------------------------+module Data.RangeSpace (+-- * Types+ Range (..)+, Bounds+, Span++-- * Conversions+, toBounds+, fromBounds+, fromBoundsC+, newRange++, rangeStart+, rangeEnd+, range++, toSpan+, fromSpan+, fromSpanC++, range2D+, fromRange2D++-- ** AffineSpace conversions+, unPoint++-- * Functions+-- ** Combining ranges+, unionBounds+, translateRange+, unionRange+, maskRange+-- ** Querying ranges+, inRange+, inOrdRange+, compareRange+, extentX+, extentY++-- * Modules+, module X+, module V+)++where++import Data.RangeSpace.TwoD as X++import Data.Basis as V+import Data.VectorSpace as V+import Data.AffineSpace as V+import Data.AffineSpace.Point as V++import Control.Applicative+import Control.Arrow ((***))+import Data.List (zipWith4)++-- | This should be provided by the AffineSpace.Point module, but isn't.+unPoint :: Point v -> v+unPoint (P v) = v++-- | Define a Range over some domain+data Range t = Range !t !t+ deriving (Eq, Show, Ord, Functor)++instance Applicative Range where+ pure a = Range a a+ (Range minf maxf) <*> (Range minv maxv) = Range (minf minv) (maxf maxv)++-- | A '(minimum,maximum)' pair+type Bounds t = (t,t)++-- | A starting point and duration+type Span t = (t, Diff t)++unRange :: Range t -> (t,t)+unRange (Range t1 t2) = (t1,t2)++-- | Convert a @Range@ to a '(min,max)' pair.+toBounds :: (Ord t) => Range t -> Bounds t+toBounds (Range s0 s1) = if s1 >= s0+ then (s0,s1)+ else (s1,s0)++-- | Generate a @Span@, '(start, distance)' from a 'Range'+toSpan :: (AffineSpace t) => Range t -> (t, Diff t)+toSpan (Range s0 s1) = (s0, s1 .-. s0)++-- | Generate a @Range@ from a @Span@ '(start, distance)'+fromSpan :: (AffineSpace t) => Span t -> Range t+fromSpan (s0,dur) = Range s0 (s0 .+^ dur)++-- | A curried @fromSpan@+fromSpanC :: (AffineSpace t) => t -> Diff t -> Range t+fromSpanC = curry fromSpan++-- | Create a @Range@ from a '(min,max)' 'Bounds' pair.+--+-- 'fromBounds' uses the 'Ord' instance to construct a 'Range'. For+-- multi-dimensional types, this probably isn't correct. For that case, see+-- 'newRange'+fromBounds :: (Ord t) => Bounds t -> Range t+fromBounds (minT,maxT)+ | maxT >= minT = Range minT maxT+ | otherwise = Range maxT minT++-- | A curried form of @fromBounds@+--+-- See the notes for @fromBounds@.+fromBoundsC :: (Ord t) => t -> t -> Range t+fromBoundsC = curry fromBounds++rangeStart :: (Ord t) => Range t -> t+rangeStart = fst . toBounds++rangeEnd :: (Ord t) => Range t -> t+rangeEnd = snd . toBounds++-- | Get the range covered by a @Range@+range :: (AffineSpace t) => Range t -> Diff t+range = snd . toSpan++-- | Translate a 'Range' by the given amount.+translateRange :: AffineSpace t => Diff t -> Range t -> Range t+translateRange t rng = (.+^ t) <$> rng++-- -------------------------------------------------------------------------+-- multi-dimensional stuff++-- | Create a range from a 'start,stop' pair. For multi-dimensional ranges,+-- the resulting range will be the union of the two points.+newRange :: (Ord t, AffineSpace t, HasBasis (Diff t)+ ,Ord (Scalar (Diff t)), Num (Scalar (Diff t)))+ => t+ -> t+ -> Range t+newRange start stop = unionRange (Range start start) (Range stop stop)++-- | Calculate the union of two 'Bounds'. See the notes for @unionRange@.+unionBounds :: (Num (Scalar (Diff t)), Ord (Scalar (Diff t)), Ord t,+ HasBasis (Diff t), AffineSpace t)+ => Bounds t+ -> Bounds t+ -> Bounds t+unionBounds r1 r2 = unRange $ unionRange (fromBounds r1) (fromBounds r2)++-- | Calculate the union of two 'Range's, per-basis.+--+-- The union is constructed by calculating the difference vector between two points,+-- performing a basis decomposition on that vector, performing comparisons and+-- adjustments on each basis vector, recomposing, and adding the result back to+-- the starting position.+--+-- The advantage of this method is that it works on an 'AffineSpace' and+-- doesn't require a full 'VectorSpace'. It does require that the+-- affine space scalars are in a vector space, but this is more easily+-- satisfiable.+unionRange :: (Num (Scalar (Diff t)), Ord t, Ord (Scalar (Diff t)),+ HasBasis (Diff t), AffineSpace t)+ => Range t -> Range t -> Range t+unionRange r0 r1 =+ Range (adjust combineMin min0 min1) (adjust combineMax max0 max1)+ where+ combineMin diff = min diff 0+ combineMax diff = max diff 0+ adjust f orig s = (orig .+^) . recompose . map (fmap f)+ . decompose $ s .-. orig+ (min0,max0) = toBounds r0+ (min1,max1) = toBounds r1++-- | Restrict a 'Range' by applying a sub-'Range' mask.+--+-- For ranges with multiple dimensions, the masking is performed+-- independently for each basis.+-- If the range lies entirely outside the mask, the returned value+-- is 'Range rmin rmin' (per-basis)+maskRange :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)), Ord t,+ Ord (Scalar (Diff t)), HasBasis (Diff t), AffineSpace t)+ => Range t -- ^ restriction+ -> Range t -- ^ original Range+ -> Range t+maskRange restriction orig = uncurry Range newBounds+ where+ combine (b0,minDiff) (b1,maxDiff) (b2,minCheck) (b3,maxCheck)+ | b0 == b1 && b0 == b2 && b0 == b3 =+ if minCheck > 0 || maxCheck < 0+ -- completely outside the restriction on this axis+ then ((b0, minDiff), (b0, negate maxCheck))+ else ((b0, max 0 minDiff), (b0, min 0 maxDiff))+ | otherwise = error "Data.RangeSpace.maskRange: basis decompositions must be deterministically ordered"+ (minAdj,maxAdj) = (recompose *** recompose) $ unzip pairs+ newBounds = (oMin .+^ minAdj, oMax .+^ maxAdj)++ pairs = zipWith4 combine (decompose $ rMin .-. oMin)+ (decompose $ rMax .-. oMax)+ (decompose $ oMin .-. rMax)+ (decompose $ oMax .-. rMin)+ (oMin,oMax) = toBounds orig+ (rMin,rMax) = toBounds restriction++-- | Create a 2D range from two independent axes.+range2D :: (Ord a, Ord b)+ => Range a -> Range b -> Range (D2V a b)+range2D r1 r2 = Range (D2V min1 min2) (D2V max1 max2)+ where+ (min1,max1) = toBounds r1+ (min2,max2) = toBounds r2++-- | Decompose a 2D range into X/Y axes.+fromRange2D :: (Ord a, Ord b)+ => Range (D2V a b) -> (Range a, Range b)+fromRange2D (Range (D2V minX minY) (D2V maxX maxY)) =+ (fromBoundsC minX maxX, fromBoundsC minY maxY)++-- | Calculate the X extent of a 2D pointwise range+extentX :: (Ord b, Ord a)+ => Range (Point (D2V a b)) -> Range a+extentX = fst . fromRange2D . fmap unPoint++-- | Calculate the Y extent of a 2D pointwise range+extentY :: (Ord b, Ord a)+ => Range (Point (D2V a b)) -> Range b+extentY = snd . fromRange2D . fmap unPoint+-- -------------------------------------------------------------------------++-- | True if a value lies inside a 'Range'.+inRange :: (Ord a, AffineSpace a, HasBasis (Diff a), Eq (Basis (Diff a))+ ,Num (Scalar (Diff a)) ,Ord (Scalar (Diff a)))+ => a+ -> Range a+ -> Bool+inRange val rng = all f $ zip (decompose pVec) (decompose rVec)+ where+ f ((b1,ppart), (b2,rpart))+ | b1 == b2 = ppart >= 0 && rpart - ppart > 0+ | otherwise = error "Data.RangeSpace.inRange: basis decompositions must be deterministically ordered"+ pVec = val .-. start+ rVec = stop .-. start+ (start, stop) = toBounds rng++-- | Check if a value is in a @Range@, using 'Ord' comparison.+--+-- If 'Ord' is usable, this is likely to be faster than @inRange@.+inOrdRange :: Ord a => a -> Range a -> Bool+inOrdRange val rng = val >= start && val <= stop+ where+ (start,stop) = toBounds rng++-- | Compare a value to a @Range@. Returns @EQ@ if the value is+-- inside the range, @LT@ or @GT@ if it's outside.+--+-- Uses @Ord@ for comparison.+compareRange :: Ord a => a -> Range a -> Ordering+compareRange val rng = case (compare val start, compare val stop) of+ (LT, _) -> LT+ (_, GT) -> GT+ _ -> EQ+ where+ (start,stop) = toBounds rng+
+ Data/RangeSpace/TwoD.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}++module Data.RangeSpace.TwoD (+ D2V (..)+) where++import Data.Basis as V+import Data.VectorSpace as V+import Data.AffineSpace as V++import Control.Arrow (first)++-- | A wrapper for two-dimensional vector types.+data D2V a b = D2V {+ xAxis :: !a+ ,yAxis :: !b+ } deriving (Eq, Ord, Show)++instance (Num a, Num b) => Num (D2V a b) where+ fromInteger n = D2V (fromIntegral n) (fromIntegral n)+ (D2V x1 y1) + (D2V x2 y2) = D2V (x1 + x2) (y1 + y2)+ (D2V x1 y1) * (D2V x2 y2) = D2V (x1 * x2) (y1 * y2)+ negate (D2V x y) = D2V (negate x) (negate y)+ abs (D2V x y) = D2V (abs x) (abs y)+ signum (D2V x y) = D2V (signum x) (signum y)++instance (AdditiveGroup a, AdditiveGroup b) => AdditiveGroup (D2V a b) where+ zeroV = D2V zeroV zeroV+ (D2V x1 y1) ^+^ (D2V x2 y2) = D2V (x1 ^+^ x2) (y1 ^+^ y2)+ negateV (D2V x y) = D2V (negateV x) (negateV y)++instance (AffineSpace a, AffineSpace b) => AffineSpace (D2V a b) where+ type Diff (D2V a b) = D2V (Diff a) (Diff b)+ (D2V x1 y1) .-. (D2V x2 y2) = D2V (x1 .-. x2) (y1 .-. y2)+ (D2V x1 y1) .+^ (D2V x2 y2) = D2V (x1 .+^ x2) (y1 .+^ y2)++instance (VectorSpace a, VectorSpace b, Scalar a ~ Scalar b)+ => VectorSpace (D2V a b) where+ type Scalar (D2V a b) = Scalar a+ s *^ (D2V x y) = D2V (s *^ x) (s *^ y)++instance (HasBasis a, HasBasis b, Scalar a ~ Scalar b)+ => HasBasis (D2V a b) where+ type Basis (D2V a b) = Either (Basis a) (Basis b)+ basisValue = either (\lb -> D2V (basisValue lb) zeroV)+ (D2V zeroV . basisValue)+ decompose (D2V x y) = map (first Left) (decompose x)+ ++ map (first Right) (decompose y)+ decompose' (D2V x _) (Left lb) = decompose' x lb+ decompose' (D2V _ y) (Right lb) = decompose' y lb
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, John Lato++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 John Lato nor the names of other+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ range-space.cabal view
@@ -0,0 +1,44 @@+-- Initial range-space.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: range-space+version: 0.1.0.0+synopsis: A Range type with vector-space instances+description: Provides functions for converting between ranges and spans+homepage: https://github.com/JohnLato/range-space+license: BSD3+license-file: LICENSE+author: John Lato+maintainer: jwlato@gmail.com+-- copyright: +category: Math+build-type: Simple+cabal-version: >=1.10++library+ default-language: Haskell2010+ ghc-options: -Wall+ exposed-modules: Data.RangeSpace+ Data.RangeSpace.TwoD+ -- other-modules: + build-depends: base >= 4.5 && < 5+ ,vector-space == 0.8.*+ ,vector-space-points == 0.1.*++Test-Suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Properties.hs+ hs-source-dirs: tests++ build-depends:+ base,+ range-space,+ time == 1.4.*,+ QuickCheck >= 2 && < 3,+ test-framework >= 0.3 && < 0.7,+ test-framework-quickcheck2 >= 0.2 && < 0.3++source-repository head+ type: git+ location: git://github.com/JohnLato/range-space.git
+ tests/Properties.hs view
@@ -0,0 +1,312 @@+{-# OPTIONS -Wall -fno-warn-orphans #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Data.RangeSpace++import Control.Applicative+import Data.List (sort)++import Data.Time.Calendar (Day(..))+import Data.Time.Clock++import Test.QuickCheck++import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++----------------------------------------------------------------------+-- * Derive some instances++instance (ApproxEq t, Ord t, AffineSpace t) => ApproxEq (Range t) where+ approxEq tol r1 r2 = approxEq tol (toBounds r1) (toBounds r2)++deriving instance Arbitrary p => Arbitrary (Point p)+deriving instance ApproxEq p => ApproxEq (Point p)++deriving instance Arbitrary Day+instance Arbitrary UTCTime where+ arbitrary = do+ day <- arbitrary+ diff <- arbitrary+ return $ UTCTime { utctDay = day, utctDayTime = diff }+ shrink (UTCTime day diff) = UTCTime <$> shrink day <*> shrink diff++instance Arbitrary DiffTime where+ arbitrary = picosecondsToDiffTime <$> arbitrary++instance Arbitrary NominalDiffTime where+ arbitrary = diffUTCTime <$> arbitrary <*> arbitrary++instance (Arbitrary a, Arbitrary b) => Arbitrary (D2V a b) where+ arbitrary = D2V <$> arbitrary <*> arbitrary+ shrink (D2V x y) = D2V <$> shrink x <*> shrink y++instance (ApproxEq a, ApproxEq b) => ApproxEq (D2V a b) where+ approxEq tol (D2V x1 y1) (D2V x2 y2) = approxEq tol (x1,y1) (x2,y2)++instance ApproxEq UTCTime where+ approxEq tol t1 t2 = abs (diffUTCTime t1 t2) < realToFrac (tol*2)++instance ApproxEq NominalDiffTime where+ approxEq tol t1 t2 = abs (t2 - t1) <= realToFrac (tol*20)++-- Although Ranges created by @fromBounds@ should always have a positive+-- distance, there's no reason for that to be true in general, so we allow+-- Arbitrary to create Ranges with negative distance.+instance (Arbitrary r) => Arbitrary (Range r) where+ arbitrary = Range <$> arbitrary <*> arbitrary++-- Don't want to drag in more dependencies for just this.+class ApproxEq a where+ approxEq :: Double -> a -> a -> Bool++instance ApproxEq Double where+ approxEq tol d1 d2 = m == 0.0 || d/m < tol where+ m = max (abs d1) (abs d2)+ d = abs (d1 - d2)++instance (ApproxEq a, ApproxEq b) => ApproxEq (a,b) where+ approxEq tol (l1,r1) (l2,r2) = approxEq tol l1 l2 && approxEq tol r1 r2++infix 4 ===+(===) :: (ApproxEq a) => a -> a -> Bool+(===) = approxEq {-pretty equal-}1.0e-10+++type DoubleP = Point (D2V Double Double)+++----------------------------------------------------------------------+-- Some orphans+++instance AdditiveGroup NominalDiffTime where+ zeroV = 0+ (^+^) = (+)+ negateV = negate+ +-- We want an AffineSpace instance for UTCTime, because+-- then we can use 'Range UTCTime'+instance AffineSpace UTCTime where+ type Diff UTCTime = NominalDiffTime+ (.-.) = diffUTCTime+ (.+^) = flip addUTCTime++-- | Having Scalar NominalDiffTime = Double means that scaling+-- and basis decomposition have to go through Rational.+-- Maybe this should be revisited.+instance VectorSpace NominalDiffTime where+ -- Scalar is Double so we can form a basis like+ -- D2V (DataX, NominalDiffTime)+ type Scalar NominalDiffTime = Double+ s *^ difftime = (realToFrac s) * difftime++instance AffineSpace NominalDiffTime where+ type Diff NominalDiffTime = NominalDiffTime+ (.-.) = (-)+ (.+^) = (+)++instance HasBasis NominalDiffTime where+ type Basis NominalDiffTime = ()+ basisValue () = 1+ decompose dtime = [((), realToFrac dtime)]+ decompose' dtime () = realToFrac dtime++----------------------------------------------------------------------+-- * Range tests++-- | When creating '(s0,s1)', s1 >= 0+orderedBoundsRange :: (Ord a, AffineSpace a) => Range a -> Bool+orderedBoundsRange rng = rmax >= rmin+ where (rmin,rmax) = toBounds rng++-- | A created range should always have a non-negative distance+orderedRangeBounds :: (Ord (Diff t), Ord t, AffineSpace t) => Bounds t -> Bool+orderedRangeBounds bounds = (max1 .-. min1) >= zeroV+ where (min1,max1) = toBounds $ fromBounds bounds++roundTripRange :: (Ord a, ApproxEq a, AffineSpace a) => a -> a -> Bool+roundTripRange s0 s1 =+ if s1 >= s0+ then (s0,s1) === (toBounds $ fromBounds (s0,s1) )+ else (s1,s0) === (toBounds $ fromBounds (s0,s1) )+++----------------------------------------------------------------------+-- maskRange tests++maskOuter1D :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)),+ Ord (Scalar (Diff t)), Ord t, HasBasis (Diff t), AffineSpace t,+ ApproxEq t) =>+ t -> t -> t -> t -> Property+maskOuter1D v1 v2 v3 v4 = True+ ==> rng === maskRange maskion rng+ where maskion = fromBounds (r0,r1) -- normalized maskion+ rng = fromBounds (s0,s1)+ [r0,s0,s1,r1] = sort [v1,v2,v3,v4]++maskInner1D :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)),+ Ord (Scalar (Diff t)), Ord t, HasBasis (Diff t), AffineSpace t,+ ApproxEq t) =>+ t -> t -> t -> t -> Property+maskInner1D v1 v2 v3 v4 = True+ ==> maskion === maskRange maskion rng+ where maskion = fromBounds (r0,r1) -- normalized maskion+ rng = fromBounds (s0,s1)+ [s0,r0,r1,s1] = sort [v1,v2,v3,v4]++maskLeft1D :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)), Ord (Scalar (Diff t)),+ Ord t, HasBasis (Diff t), AffineSpace t, ApproxEq t) =>+ t -> t -> t -> t -> Property+maskLeft1D v1 v2 v3 v4 = True+ ==> fromBounds (r0,s1)+ === maskRange (fromBounds (r0,r1)) (fromBounds (s0,s1))+ where+ [s0,r0,s1,r1] = sort [v1,v2,v3,v4]++maskRight1D :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)),+ Ord (Scalar (Diff t)), Ord t, HasBasis (Diff t), AffineSpace t,+ ApproxEq t) =>+ t -> t -> t -> t -> Property+maskRight1D v1 v2 v3 v4 = True+ ==> fromBounds (s0,r1)+ === maskRange (fromBounds (r0,r1)) (fromBounds (s0,s1))+ where+ [r0,s0,r1,s1] = sort [v1,v2,v3,v4]++maskNeg :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)), Ord (Scalar (Diff t)),+ Ord t, HasBasis (Diff t), AffineSpace t, ApproxEq t) =>+ Range t -> Range t -> Bool+maskNeg rng1 rng2 = maskRange rng1 rng2 === maskRange rng1' rng2'+ where+ rng1' = fromBounds $ toBounds rng1+ rng2' = fromBounds $ toBounds rng2++maskMiss1D :: (Eq (Basis (Diff t)), Num (Scalar (Diff t)), Ord (Scalar (Diff t)),+ Ord t, HasBasis (Diff t), AffineSpace t, ApproxEq t) =>+ t -> t -> t -> t -> Property+maskMiss1D v1 v2 v3 v4 = True+ ==> fromBounds (r0,r0)+ === maskRange (fromBounds (r0,r1)) (fromBounds (s0,s1))+ -- flip the positions to check misses on both sides+ && fromBounds (s0,s0)+ === maskRange (fromBounds (s0,s1)) (fromBounds (r0,r1))+ where+ [r0,r1,s0,s1] = sort [v1,v2,v3,v4]+++-- 2D tests++maskD2V :: (Eq (Basis (Diff t1)), Eq (Basis (Diff t)), Num (Scalar (Diff t)),+ Ord (Scalar (Diff t)), Ord t, Ord t1, HasBasis (Diff t1),+ HasBasis (Diff t), AffineSpace t, AffineSpace t1, ApproxEq t1,+ ApproxEq t, Scalar (Diff t1) ~ Scalar (Diff t)) =>+ Range t1 -> Range t1 -> Range t -> Range t -> Bool+maskD2V xr1 xr2 yr1 yr2 =+ rngMin === (D2V minx miny) && rngMax === D2V maxx maxy+ where+ Range rngMin rngMax = maskRange r2d1 r2d2+ (minx,maxx) = toBounds $ maskRange (xr1) (xr2)+ (miny,maxy) = toBounds $ maskRange (yr1) (yr2)+ r2d1 = range2D xr1 yr1+ r2d2 = range2D xr2 yr2++-- union tests++unionRangeBounds :: (Num (Scalar (Diff t)), Ord (Scalar (Diff t)), Ord t,+ HasBasis (Diff t), AffineSpace t, ApproxEq t)+ => Range t -> Range t -> Bool+unionRangeBounds r1 r2 =+ toBounds (unionRange r1 r2) === (min min1 min2,max max1 max2)+ where+ (min1,max1) = toBounds r1+ (min2,max2) = toBounds r2++----------------------------------------------------------------------+-- Test harness++main :: IO ()+main = defaultMain tests++-- do a *whole lot* of tests, to make sure that the instances are all correct.+tests :: [Test]+tests =+ [ testGroup "bounds"+ [ testGroup "construction"+ [ testProperty "Double" (orderedBoundsRange :: Range Double -> Bool)+ , testProperty "DoubleP" (orderedBoundsRange :: Range DoubleP -> Bool)+ ]+ ]+ , testGroup "range"+ [ testGroup "construction"+ [ testProperty "Double" (orderedRangeBounds :: (Double,Double)->Bool)+ , testProperty "DoubleP" (orderedRangeBounds :: (DoubleP ,DoubleP)->Bool)+ ]+ ]+ , testGroup "roundTrip"+ [ testProperty "Double" (roundTripRange :: Double->Double->Bool)+ , testProperty "DoubleP" (roundTripRange :: DoubleP->DoubleP->Bool)+ ]+ , testGroup "union"+ -- only testing with a few types, if there are problems with instances+ -- they'll show up in maskRange tests+ [ testProperty "Double"+ (unionRangeBounds :: Range Double->Range Double->Bool)+ , testProperty "NominalDiffTime"+ (unionRangeBounds :: Range NominalDiffTime->Range NominalDiffTime->Bool)+ ]+ , testGroup "maskRange"+ [ testGroup "maskOuter1D"+ [ testProperty "Double"+ (maskOuter1D :: Double->Double->Double->Double->Property)+ , testProperty "NominalDiffTime"+ (maskOuter1D :: NominalDiffTime->NominalDiffTime+ ->NominalDiffTime->NominalDiffTime->Property)+ ]+ , testGroup "maskInner1D"+ [ testProperty "Double"+ (maskInner1D :: Double->Double->Double->Double->Property)+ , testProperty "NominalDiffTime"+ (maskInner1D :: NominalDiffTime->NominalDiffTime+ ->NominalDiffTime->NominalDiffTime->Property)+ ]+ , testGroup "maskLeft1D"+ [ testProperty "Double"+ (maskLeft1D :: Double->Double->Double->Double->Property)+ , testProperty "NominalDiffTime"+ (maskLeft1D :: NominalDiffTime->NominalDiffTime+ ->NominalDiffTime->NominalDiffTime->Property)+ ]+ , testGroup "maskMiss1D"+ [ testProperty "Double"+ (maskMiss1D :: Double->Double->Double->Double->Property)+ ]+ , testGroup "RestrictNeg"+ [ testProperty "Double"+ (maskRight1D :: Double->Double->Double->Double->Property)+ , testProperty "NominalDiffTime"+ (maskRight1D :: NominalDiffTime->NominalDiffTime+ ->NominalDiffTime->NominalDiffTime->Property)+ ]+ , testGroup "maskNeg"+ [ testProperty "Double"+ (maskNeg :: Range Double->Range Double->Bool)+ , testProperty "NominalDiffTime"+ (maskNeg :: Range NominalDiffTime->Range NominalDiffTime->Bool)+ ]+ , testGroup "mask2D"+ [ testProperty "Double/Double"+ (maskD2V :: Range Double->Range Double->Range Double+ ->Range Double->Bool)+ , testProperty "Double/NominalDiffTime" (maskD2V ::+ Range Double->Range Double->Range NominalDiffTime+ ->Range NominalDiffTime->Bool)+ ]+ ]+ ]