packages feed

numhask-range (empty) → 0.0.1

raw patch · 8 files changed

+769/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, containers, foldl, formatting, lens, linear, numhask, numhask-range, protolude, smallcheck, tasty, tasty-hspec, tasty-hunit, tasty-quickcheck, tasty-smallcheck

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2017++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 Tony Day 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
+ numhask-range.cabal view
@@ -0,0 +1,143 @@+name:+  numhask-range+version:+  0.0.1+synopsis:+  see readme.md+description:+  see readme.md for description.+category:+  project+homepage:+  https://github.com/tonyday567/numhask-range+license:+  BSD3+license-file:+  LICENSE+author:+  Tony Day+maintainer:+  tonyday567@gmail.com+copyright:+  Tony Day+build-type:+  Simple+cabal-version:+  >=1.14+extra-source-files:+  stack.yaml+library+  default-language:+    Haskell2010+  ghc-options:+  hs-source-dirs:+    src+  exposed-modules:+    NumHask.Range,+    NumHask.Histogram,+    NumHask.Rect+  build-depends:+    base >= 4.7 && < 5,+    numhask,+    protolude,+    lens,+    foldl,+    containers,+    QuickCheck,+    linear,+    formatting+  default-extensions:+    NoImplicitPrelude,+    UnicodeSyntax,+    BangPatterns,+    BinaryLiterals,+    DeriveFoldable,+    DeriveFunctor,+    DeriveGeneric,+    DeriveTraversable,+    DisambiguateRecordFields,+    EmptyCase,+    FlexibleContexts,+    FlexibleInstances,+    FunctionalDependencies,+    GADTSyntax,+    InstanceSigs,+    KindSignatures,+    LambdaCase,+    MonadComprehensions,+    MultiParamTypeClasses,+    MultiWayIf,+    NegativeLiterals,+    OverloadedStrings,+    ParallelListComp,+    PartialTypeSignatures,+    PatternSynonyms,+    RankNTypes,+    RecordWildCards,+    RecursiveDo,+    ScopedTypeVariables,+    TupleSections,+    TypeFamilies,+    TypeOperators++test-suite test+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    test.hs+  build-depends:+    base >= 4.7 && < 5,+    HUnit,+    QuickCheck,+    numhask-range,+    protolude,+    smallcheck,+    tasty,+    tasty-hunit,+    tasty-hspec,+    tasty-quickcheck,+    tasty-smallcheck,+    numhask+  default-extensions:+    NoImplicitPrelude,+    UnicodeSyntax,+    BangPatterns,+    BinaryLiterals,+    DeriveFoldable,+    DeriveFunctor,+    DeriveGeneric,+    DeriveTraversable,+    DisambiguateRecordFields,+    EmptyCase,+    FlexibleContexts,+    FlexibleInstances,+    FunctionalDependencies,+    GADTSyntax,+    InstanceSigs,+    KindSignatures,+    LambdaCase,+    MonadComprehensions,+    MultiParamTypeClasses,+    MultiWayIf,+    NegativeLiterals,+    OverloadedStrings,+    ParallelListComp,+    PartialTypeSignatures,+    PatternSynonyms,+    RankNTypes,+    RecordWildCards,+    RecursiveDo,+    ScopedTypeVariables,+    TupleSections,+    TypeFamilies,+    TypeOperators++source-repository head+  type:+    git+  location:+    https://github.com/tonyday567/numhask-range
+ src/NumHask/Histogram.hs view
@@ -0,0 +1,110 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}++module NumHask.Histogram+  ( Histogram(..)+  , freq+  , fill+  , DealOvers(..)+  , fromHist+  , hist+  , labels+  , insert+  , insertW+  , insertWs+  ) where++import NumHask.Rect++import Protolude+import qualified Control.Foldl as L+import qualified Data.Map.Strict as Map+import Linear hiding (identity)+import Data.List+import Formatting+import Control.Lens++-- a histogram+data Histogram = Histogram+   { _cuts   :: [Double] -- bucket boundaries+   , _values :: Map.Map Int Double -- bucket counts+   } deriving (Show, Eq)++freq' :: Map.Map Int Double -> Map.Map Int Double+freq' m = Map.map (* recip (Protolude.sum m)) m++freq :: Histogram -> Histogram+freq (Histogram c v) = Histogram c (freq' v)++count :: L.Fold Int (Map Int Double)+count = L.premap (\x -> (x,1.0)) countW++countW :: L.Fold (Int,Double) (Map Int Double)+countW = L.Fold (\x (a,w) -> Map.insertWith (+) a w x) Map.empty identity++countBool :: L.Fold Bool Int+countBool = L.Fold (\x a -> x + if a then 1 else 0) 0 identity++histMap :: (Functor f, Functor g, Ord a, Foldable f, Foldable g) =>+    f a -> g a -> Map Int Double+histMap cuts xs = L.fold count $ (\x -> L.fold countBool (fmap (x >) cuts)) <$> xs++histMapW :: (Functor f, Functor g, Ord a, Foldable f, Foldable g) =>+    f a -> g (a,Double) -> Map Int Double+histMapW cuts xs = L.fold countW $+    (\x -> (L.fold countBool (fmap (fst x >) cuts),snd x)) <$> xs++fill :: [Double] -> [Double] -> Histogram+fill cuts xs = Histogram cuts (histMap cuts xs)++insertW :: Histogram -> Double -> Double -> Histogram+insertW (Histogram cuts vs) value weight = Histogram cuts (Map.unionWith (+) vs s)+    where+      s = histMapW cuts [(value,weight)]++insertWs :: Histogram -> [(Double, Double)] -> Histogram+insertWs (Histogram cuts vs) vws = Histogram cuts (Map.unionWith (+) vs s)+    where+      s = histMapW cuts vws++data DealOvers = IgnoreOvers | IncludeOvers Double++fromHist :: DealOvers -> Histogram -> [Rect Double]+fromHist o (Histogram cuts counts) = view rect <$> zipWith4 V4 x y z w'+  where+      y = repeat 0+      w = zipWith (/)+          ((\x -> Map.findWithDefault 0 x counts) <$> [f..l])+          (zipWith (-) z x)+      f = case o of+        IgnoreOvers -> 1+        IncludeOvers _ -> 0+      l = case o of+        IgnoreOvers -> length cuts - 1+        IncludeOvers _ -> length cuts+      w' = (/Protolude.sum w) <$> w+      x = case o of+        IgnoreOvers -> cuts+        IncludeOvers outw -> [Data.List.head cuts - outw] <> cuts <> [Data.List.last cuts + outw]+      z = drop 1 x++labels :: DealOvers -> [Double] -> [Text]+labels o cuts =+    case o of+      IgnoreOvers -> inside+      IncludeOvers _ -> [ "< " <> sformat (prec 2) (Data.List.head cuts)] <> inside <> [ "> " <> sformat (prec 2) (Data.List.last cuts)]+  where+    inside = sformat (prec 2) <$> zipWith (\l u -> (l+u)/2) cuts (drop 1 cuts)++hist :: [Double] -> Double -> L.Fold Double Histogram+hist cuts r =+    L.Fold+    (\(Histogram cuts counts) a ->+       Histogram cuts+       (Map.unionWith (+)+        (Map.map (*r) counts)+        (Map.singleton (L.fold countBool (fmap (a>) cuts)) 1)))+    (Histogram cuts mempty)+    identity
+ src/NumHask/Range.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Range+  ( Range(..)+  , (...)+  , posit+  , low+  , high+  , mid+  , width+  , element+  , singleton+  , singular+  , mirrored+  , intersection+  , contains+  , range+  , rescaleP+  , TickPos(..)+  , ticks+  , ticksSensible+  , fromTicks+ ) where++import NumHask.Prelude+import Control.Category (id)+import Control.Lens hiding (Magma, singular, element, contains, (...))+import qualified Control.Foldl as L+import Test.QuickCheck++-- | a range represented by a (minimum, maximum) tuple+-- very similar to https://hackage.haskell.org/package/intervals-0.7.2 but the+-- metaphor and purpose there is closer to a fuzzy value around a central point.+newtype Range a = Range { range_ :: (a, a) }+  deriving (Eq, Ord, Show, Functor)++(...) :: Ord a => a -> a -> Range a+a ... b+  | a <= b = Range (a, b)+  | otherwise = Range (b, a)++low :: Lens' (Range a) a+low = lens (\(Range (l,_)) -> l) (\(Range (_,u)) l -> Range (l,u))++high :: Lens' (Range a) a+high = lens (\(Range (_,u)) -> u) (\(Range (l,_)) u -> Range (l,u))++mid ::+    (BoundedField a) =>+    Lens' (Range a) a+mid =+    lens+    plushom+    (\r m -> Range (m - plushom r, m + plushom r))++width ::+    (BoundedField a) =>+    Lens' (Range a) a+width =+    lens+    (\(Range (l,u)) -> (u-l))+    (\r w -> Range (plushom r - w/two, plushom r + w/two))++instance (Ord a, Arbitrary a) => Arbitrary (Range a) where+    arbitrary = do+        a <- arbitrary+        b <- arbitrary+        pure (posit (Range (a,b)))++posit :: (Ord a) => Range a -> Range a+posit r@(Range (l,u))  = if l<=u then r else Range (u,l)++-- | the convex hull as plus seems like a natural choice, given the cute zero definition.+instance (Ord a) => AdditiveMagma (Range a) where+    plus (Range (l0,u0)) (Range (l1,u1)) = Range (min l0 l1, max u0 u1)++instance (Ord a, BoundedField a) => AdditiveUnital (Range a) where+    zero = Range (infinity,neginfinity)++instance (Ord a) => AdditiveAssociative (Range a)+instance (Ord a) => AdditiveCommutative (Range a)+instance (Ord a, BoundedField a) => Additive (Range a)++instance (Ord a) => Semigroup (Range a) where+    (<>) = plus++instance (AdditiveUnital (Range a), Semigroup (Range a)) => Monoid (Range a) where+    mempty = zero+    mappend = (<>)++-- | natural interpretation of a `Range a` as an `a` is the mid-point+instance (BoundedField a) =>+    AdditiveHomomorphic (Range a) a where+    plushom (Range (l,u)) = (l+u)/two++-- | natural interpretation of an `a` as a `Range a` is a singular Range+instance (Ord a) =>+    AdditiveHomomorphic a (Range a) where+    plushom a = singleton a++-- | times may well be some sort of affine transformation lurking under the hood+instance (BoundedField a) => MultiplicativeMagma (Range a) where+    times a b = Range (m - r/two, m + r/two)+        where+          m = view mid b + (view mid a * view width b)+          r = view width a * view width b++-- | The unital object derives from:+--+-- view range one = one+-- view mid zero = zero+-- ie (-0.5,0.5)+instance (BoundedField a) => MultiplicativeUnital (Range a) where+    one = Range (negate half, half)++instance (BoundedField a) => MultiplicativeAssociative (Range a)++instance (Ord a, BoundedField a) => MultiplicativeInvertible (Range a) where+    recip a = case view width a == zero of+      True  -> theta+      False -> Range (m - r/two, m + r/two)+        where+          m = negate (view mid a) * recip (view width a)+          r = recip (view width a)++instance (Ord a, BoundedField a) => MultiplicativeRightCancellative (Range a)+instance (Ord a, BoundedField a) => MultiplicativeLeftCancellative (Range a)++instance (AdditiveGroup a) => Normed (Range a) a where+    size (Range (l, u)) = u-l++instance (Ord a, AdditiveGroup a) => Metric (Range a) a where+    distance (Range (l,u)) (Range (l',u'))+        | u < l' = l' - u+        | u' < l = l - u'+        | otherwise = zero++-- | theta is a bit like 1/infinity+theta :: (AdditiveUnital a) => Range a+theta = Range (zero, zero)++two :: (MultiplicativeUnital a, Additive a) => a+two = one + one++half :: (BoundedField a) => a+half = one / (one + one)++singleton :: a -> Range a+singleton a = Range (a,a)++-- | determine whether a point is within the range+element :: (Ord a) => a -> Range a -> Bool+element a (Range (l,u)) = a >= l && a <= u++-- | is the range a singleton point+singular :: (Eq a) => Range a -> Bool+singular (Range (l,u)) = l==u++-- | is the range low higher than the high+-- there well may be an interesting complex-like set of operations on mirrored ranges+mirrored :: (Ord a) => Range a -> Bool+mirrored (Range (l,u)) = l>u++intersection :: (Ord a) => Range a -> Range a -> Range a+intersection a b =+    Range (max (view low a) (view low b), min (view high a) (view high b))++contains :: (Ord a) => Range a -> Range a -> Bool+contains (Range (l,u)) (Range (l',u')) = l <= l' && u >= u'++-- | range of a foldable+range :: (Foldable f, Ord a, BoundedField a) => f a -> Range a+range = L.fold (L.Fold (\x a -> x + singleton a) zero id)++-- | `rescaleP rold rnew p` rescales a data point from an old range to a new range+-- rescaleP o n (view low o) == view low n+-- rescaleP o n (view high o) == view high n+-- rescaleP a a == id+rescaleP :: (Field b) => Range b -> Range b -> b -> b+rescaleP (Range (l0,u0)) (Range (l1,u1)) p =+    ((p-l0)/(u0-l0)) * (u1-l1) + l1++-- * ticks are a series of `a`s constructued from a `Range a`+-- | where on the `Range` should the ticks be placed+data TickPos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq)++-- | turn a range into a ist of n `a`s, that are (view width x/n) apart+ticks :: (Field a, FromInteger a) => TickPos -> Range a -> Int -> [a]+ticks o (Range (l, u)) n = (+ if o==MidPos then step/two else zero) <$> posns+  where+    posns = (l +) . (step *) . fromIntegral <$> [i0..i1]+    step = (u - l)/fromIntegral n+    (i0,i1) = case o of+                OuterPos -> (0,n)+                InnerPos -> (1,n - 1)+                LowerPos -> (0,n - 1)+                UpperPos -> (1,n)+                MidPos -> (0,n - 1)++-- | turn a range into n `a`s pleasing to human sense and sensibility+-- the `a`s may well lie outside the original range as a result+ticksSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpRing a, MultiplicativeGroup a) => TickPos -> Range a -> Int -> [a]+ticksSensible tp (Range (l, u)) n = (+ if tp==MidPos then step/two else zero) <$> posns+  where+    posns = (first' +) . (step *) . fromIntegral <$> [i0..i1]+    span = u - l+    step' = 10 ^^ floor (logBase 10 (span/fromIntegral n))+    err = fromIntegral n / span * step'+    step+      | err <= 0.15 = 10 * step'+      | err <= 0.35 = 5 * step'+      | err <= 0.75 = 2 * step'+      | otherwise = step'+    first' = step * fromIntegral (ceiling (l/step))+    last' = step * fromIntegral (floor (u/step))+    n' = round ((last' - first')/step)+    (i0,i1) = case tp of+                OuterPos -> (0,n')+                InnerPos -> (1,n' - 1)+                LowerPos -> (0,n' - 1)+                UpperPos -> (1,n')+                MidPos -> (0,n' - 1)++-- | take a list of (ascending) `a`s and make some (ascending) ranges+-- based on OuterPos+-- fromTicks . ticks OuterPos == id+-- ticks OuterPos . fromTicks == id+fromTicks :: [a] -> [Range a]+fromTicks as = zipWith (curry Range) as (drop 1 as)+
+ src/NumHask/Rect.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Rect+  ( Rect(..)+  , rect+  , positRect+  , corners+  , midRect+  , elementRect+  , singletonRect+  , singularRect+  , intersectionRect+  , containsRect+  , rescaleP+  , rangeR2s+  , scaleR2s+  , rangeRects+  , rescaleRect+  , scaleRects+  , scaleRectss+  , gridP+  , grid+  ) where++import NumHask.Range+import NumHask.Prelude+import Control.Lens hiding (Magma, singular, element, contains)+import Linear.V2+import Linear.V4++-- | a two-dimensional plane, bounded by ranges.+newtype Rect a = Rect {xy :: V2 (Range a)}+    deriving (Show, Eq, Ord, Functor)++-- | an alternative specification; as a 4-dim vector `V4 x y z w` where:+-- - (x,y) is the lower left corner of a rectangle, and+-- - (z,w) is the upper right corner of a rectangle+rect :: Iso' (V4 a) (Rect a)+rect = iso toRect toV4+  where+    toRect (V4 x y z w) = Rect $ V2 (Range (x,z)) (Range (y,w))+    toV4 (Rect (V2 (Range (x,z)) (Range (y,w)))) = V4 x y z w++positRect :: (Ord a) => Rect a -> Rect a+positRect (Rect (V2 x y)) = Rect (V2 (posit x) (posit y))++-- | a convex hull approach+instance (Ord a) => AdditiveMagma (Rect a) where+    plus (Rect (V2 ax ay)) (Rect (V2 bx yb)) =+        Rect (V2 (ax `plus` bx) (ay `plus` yb))++instance (Ord a, BoundedField a) => AdditiveUnital (Rect a) where+    zero = Rect $ V2 zero zero++instance (Ord a) => AdditiveAssociative (Rect a)+instance (Ord a) => AdditiveCommutative (Rect a)+instance (Ord a, BoundedField a) => Additive (Rect a)++instance (Ord a) => Semigroup (Rect a) where+    (<>) = plus++instance (AdditiveUnital (Rect a), Semigroup (Rect a)) => Monoid (Rect a) where+    mempty = zero+    mappend = (<>)++-- | natural interpretation of an `a` as an `Rect a`+instance (Ord a) =>+    AdditiveHomomorphic (V2 a) (Rect a) where+    plushom v = singletonRect v++instance (BoundedField a) => MultiplicativeMagma (Rect a) where+    (Rect (V2 a0 b0)) `times` (Rect (V2 a1 b1)) =+        Rect (V2 (a0 `times` a1) (b0 `times` b1))++instance (BoundedField a) => MultiplicativeUnital (Rect a) where+    one = Rect (V2 one one)+instance (BoundedField a) => MultiplicativeAssociative (Rect a)+instance (Ord a, BoundedField a) => MultiplicativeInvertible (Rect a) where+    recip (Rect (V2 a b)) = Rect (V2 (recip a) (recip b))+instance (Ord a, BoundedField a) => MultiplicativeLeftCancellative (Rect a)+instance (Ord a, BoundedField a) => MultiplicativeRightCancellative (Rect a)++instance (AdditiveGroup a) => Normed (Rect a) (V2 a) where+    size (Rect (V2 x y)) = V2 (size x) (size y)++instance (Ord a, AdditiveGroup a) => Metric (Rect a) (V2 a) where+    distance (Rect (V2 x y)) (Rect (V2 x1 y1)) = V2 (distance x x1) (distance y y1)+++midRect :: (BoundedField a) => Rect a -> V2 a+midRect (Rect (V2 x y)) = V2 (plushom x) (plushom y)++-- | determine whether a point is within the range+elementRect :: (Ord a) => V2 a -> Rect a -> Bool+elementRect (V2 x y) (Rect (V2 rx ry)) = NumHask.Range.element x rx && NumHask.Range.element y ry++-- | is the range a singleton V2 (has zero area)+singularRect :: (Eq a) => Rect a -> Bool+singularRect (Rect (V2 x y)) = NumHask.Range.singular x || NumHask.Range.singular y++singletonRect :: V2 a -> Rect a+singletonRect (V2 x y) = Rect (V2 (singleton x) (singleton y)) ++intersectionRect :: (Ord a) => Rect a -> Rect a -> Rect a+intersectionRect (Rect (V2 x y)) (Rect (V2 x1 y1)) =+    Rect (V2 (NumHask.Range.intersection x x1) (NumHask.Range.intersection y y1))++containsRect :: (Ord a) => Rect a -> Rect a -> Bool+containsRect (Rect (V2 x y)) (Rect (V2 x1 y1)) =+    NumHask.Range.contains x x1 && NumHask.Range.contains y y1++corners :: Rect a -> [V2 a]+corners (Rect (V2 (Range (lx,ux)) (Range (ly,uy)))) = [V2 lx ly, V2 ux uy]++-- | the range Rect of a container of R2s+rangeR2 :: (Traversable f, Ord a, BoundedField a, R2 r) => f (r a) -> Rect a+rangeR2 f = Rect (V2 (range $ view _x <$> f) (range $ view _y <$> f))++-- | range specialized to double traversables+rangeR2s :: (BoundedField a, Traversable g, Traversable f, R2 r, Ord a) =>+    g (f (r a)) -> Rect a+rangeR2s f = foldMap rangeR2 f++-- | rescales a container of r2's+rescaleR2 :: (R2 r, Field a, Functor f) =>+    Rect a -> Rect a -> f (r a) -> f (r a)+rescaleR2 (Rect (V2 rx ry)) (Rect (V2 rx' ry')) qs =+    (over _x (rescaleP rx rx') . over _y (rescaleP ry ry')) <$> qs++-- | scale a double container of r2s from the current range+scaleR2s ::+    (R2 r, BoundedField a, Traversable f, Traversable g, Ord a) =>+    Rect a -> g (f (r a)) -> g (f (r a))+scaleR2s xy qss = rescaleR2 (rangeR2s qss) xy <$> qss++-- | rescales a Rect from an old Rect range to a new one+rescaleRect :: (Field a) =>+    Rect a -> Rect a -> Rect a -> Rect a+rescaleRect (Rect (V2 rx ry)) (Rect (V2 rx' ry')) (Rect (V2 rx0 ry0)) =+    Rect (V2 (rescaleP rx rx' <$> rx0) (rescaleP ry ry' <$> ry0))++-- | rescales a container of Rects from an old Rect range to a new one+rescaleRects :: (Field a, Functor f) =>+    Rect a -> Rect a -> f (Rect a) -> f (Rect a)+rescaleRects o n f = rescaleRect o n <$> f++-- | the range of a container of Rects+rangeRects :: (Ord a, BoundedField a, Traversable f) =>+    f (Rect a) -> Rect a+rangeRects f = fold f++-- | scale a double container of Rects from the current range+scaleRects ::+    (BoundedField a, Traversable f, Ord a) =>+    Rect a -> f (Rect a) -> f (Rect a)+scaleRects xy f = rescaleRects (fold f) xy f++-- | scale a double container of Rects from the current range+scaleRectss ::+    (BoundedField a, Traversable f, Traversable g, Ord a) =>+    Rect a -> g (f (Rect a)) -> g (f (Rect a))+scaleRectss xy g = rescaleRects (fold $ fold <$> g) xy <$> g++-- | grid points on a rectange, divided up by a V2 Int+gridP :: (Field a, FromInteger a) => TickPos -> Rect a -> V2 Int -> [V2 a]+gridP tp (Rect (V2 rX rY)) (V2 stepX stepY) =+    [V2 x y | x <- ticks tp rX stepX, y <- ticks tp rY stepY]++-- | a rectangle divided up by a V2 Int, making a list of smaller rectangles+grid :: (BoundedField a, FromInteger a) => Rect a -> V2 Int -> [Rect a]+grid (Rect (V2 rX rY)) (V2 stepX stepY) =+    [ Rect (V2 (Range (x,x+sx)) (Range (y,y+sy)))+    | x <- ticks LowerPos rX stepX+    , y <- ticks LowerPos rY stepY+    ]+  where+    sx = view width rX / fromIntegral stepX+    sy = view width rY / fromIntegral stepY++
+ stack.yaml view
@@ -0,0 +1,7 @@+resolver: lts-7.19++packages:+- '.'++extra-deps:+- numhask-0.0.1
+ test/test.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds #-}++module Main where++import NumHask.Prelude+import NumHask.Range+import NumHask.Histogram+import NumHask.Rect++import Test.Tasty (TestName, TestTree, testGroup, defaultMain)+import Test.Tasty.QuickCheck+import Test.Tasty.Hspec++data LawArity a =+    Nonary Bool |+    Unary (a -> Bool) |+    Binary (a -> a -> Bool) |+    Ternary (a -> a -> a -> Bool) |+    Ornary (a -> a -> a -> a -> Bool) |+    Failiary (a -> Property)++type Law a = (TestName, LawArity a)++testLawOf  :: (Arbitrary a, Show a) => [a] -> Law a -> TestTree+testLawOf _ (name, Nonary f) = testProperty name f+testLawOf _ (name, Unary f) = testProperty name f+testLawOf _ (name, Binary f) = testProperty name f+testLawOf _ (name, Ternary f) = testProperty name f+testLawOf _ (name, Ornary f) = testProperty name f+testLawOf _ (name, Failiary f) = testProperty name f++testRange :: TestTree+testRange = testGroup "Data.Range" $ testLawOf ([]::[Range Double]) <$> rangeLaws++main :: IO ()+main = do+    defaultMain $ testGroup "range" [testRange]++rangeLaws :: [Law (Range Double)]+rangeLaws =+    [ ("associative: (a + b) + c = a + (b + c)", Ternary (\a b c -> (a + b) + c == a + (b + c)))+    , ("left id: zero + a = a", Unary (\a -> zero + a == a))+    , ("right id: a + zero = a", Unary (\a -> a + zero == a))+    , ("commutative: a + b == b + a", Binary (\a b -> a + b == b + a))+    , ("associative: a `times` (b `times` c) = (a `times` b) `times` c", Ternary (\a b c -> fuzzyeq 1e-4 ((a `times` b) `times` c) (a `times` (b `times` c))))+    , ("left id: one * a = a", Unary (\a -> fuzzyeq 1e-8 (one `times` a) a))+    , ("right id: a * one = a", Unary (\a -> fuzzyeq 1e-8 (a `times` one) a))+    , ("commutative: a * b == b * a", Failiary $ expectFailure . (\a b -> a `times` b == b `times` a))+    , ("recip iso: recip . recip == id", Unary (\a -> zeroRange a || fuzzyeq 1e-4 (recip . recip $ a) a))+    , ("divide: zero range || a /~ a = one", Unary (\a -> zeroRange a || fuzzyeq 1e-8 (a /~ a) one))+    , ("recip divide right: zero range || recip a == one /~ a", Unary (\a -> zeroRange a || fuzzyeq 1e-8 (recip a) (one /~ a)))+    , ("recip left: zero range || recip a * a == one",  Unary (\a -> zeroRange a ||fuzzyeq 1e-8 (recip a `times` a) one))+    , ("recip right: zero range || a * recip a == one", Unary (\a -> zeroRange a || fuzzyeq 1e-8 (a `times` recip a) one))+    ]++fuzzyeq :: (AdditiveGroup a, Ord a) => a -> Range a -> Range a -> Bool+fuzzyeq eps0 (Range (l0,u0)) (Range (l1,u1)) =+    (l0-l1) <= eps0 && (l1-l0) <= eps0 && (u0-u1) <= eps0 && (u1-u0) <= eps0 ++zeroRange :: (Eq a) => Range a -> Bool+zeroRange (Range (l,u)) = l==u+