diff --git a/Data/RangeSpace.hs b/Data/RangeSpace.hs new file mode 100644 --- /dev/null +++ b/Data/RangeSpace.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} + +---------------------------------------------------------------------- +{- | + Module : Data.RangeSpace + Copyright : John Lato + License : BSD3 (see LICENSE) + + Maintainer : John Lato + 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 + diff --git a/Data/RangeSpace/TwoD.hs b/Data/RangeSpace/TwoD.hs new file mode 100644 --- /dev/null +++ b/Data/RangeSpace/TwoD.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/range-space.cabal b/range-space.cabal new file mode 100644 --- /dev/null +++ b/range-space.cabal @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -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) + ] + ] + ]