numhask-range 0.0.3 → 0.0.4
raw patch · 9 files changed
+748/−745 lines, 9 filesdep −HUnitdep −smallcheckdep −tasty-hspecdep ~numhasksetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: HUnit, smallcheck, tasty-hspec, tasty-hunit, tasty-smallcheck
Dependency ranges changed: numhask
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- Setup.hs +2/−2
- numhask-range.cabal +135/−143
- readme.md +11/−0
- src/NumHask/Histogram.hs +110/−110
- src/NumHask/Range.hs +240/−240
- src/NumHask/Rect.hs +153/−153
- stack.yaml +7/−7
- test/test.hs +60/−60
LICENSE view
@@ -1,30 +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. +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
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
numhask-range.cabal view
@@ -1,143 +1,135 @@-name: - numhask-range -version: - 0.0.3 -synopsis: - Numbers that are range representations -description: - Numbers that represent ranges of all sorts. -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 >= 0.0.4, - 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 >= 0.0.4 - 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 +name: numhask-range+version: 0.0.4+synopsis:+ Numbers that are range representations+description:+ Numbers that represent ranges of all sorts.+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:+ readme.md+ 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 >= 0.0.7,+ 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,+ numhask-range,+ tasty,+ tasty-quickcheck,+ numhask >= 0.0.7+ 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
+ readme.md view
@@ -0,0 +1,11 @@+[numhask-range](https://github.com/tonyday567/numhask-range)+===++[](https://travis-ci.org/tonyday567/numhask-range) [](https://hackage.haskell.org/package/numhask-range) [](http://stackage.org/lts/package/numhask-range) [](http://stackage.org/nightly/package/numhask-range) ++A `Range` a is a tuple representing an interval of a number space. A Range can be thought of as consisting of a low and high value, though `low <= high` isn't strictly enforced, allowing a negative space so to speak. The library uses the 'NumHask' classes and thus most of the usual arithmetic operators can be used.++The library includes modules for:++- `Rect`: rectangles, which are 2 dimensional ranges. This is very useful for diagrams+- `Hist`: histograms. This may sound strange but buckets of a histogram is nothing more than a collection of contiguous `Ranges` with extra information for each bucket.
src/NumHask/Histogram.hs view
@@ -1,110 +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 +{-# 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
@@ -1,240 +1,240 @@-{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# OPTIONS_GHC -Wall #-} - --- | A 'Range' a is a tuple representing an interval of a number space. A Range can be thought of as consisting of a low and high value, though low<high isn't strictly enforced, allowing a negative space so to speak. --- The library uses the 'NumHask' classes and thus most of the usual arithmetic operators can be used. - -module NumHask.Range - ( Range(..) - , (...) - , low - , high - , mid - , width - , element - , singleton - , singular - , intersection - , contains - , range - , project - , LinearPos(..) - , linearSpace - , linearSpaceSensible - , fromLinearSpace - ) 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 newtype wrapped (a, a) tuple -newtype Range a = Range { range_ :: (a, a) } - deriving (Eq, Ord, Show, Functor) - --- | alternative constructor -(...) :: Ord a => a -> a -> Range a -a ... b - | a <= b = Range (a, b) - | otherwise = Range (b, a) - --- | lens for the fst of the tuple -low :: Lens' (Range a) a -low = lens (\(Range (l,_)) -> l) (\(Range (_,u)) l -> Range (l,u)) - --- | lens for the snd of the tuple -high :: Lens' (Range a) a -high = lens (\(Range (_,u)) -> u) (\(Range (l,_)) u -> Range (l,u)) - --- | mid-value lens -mid :: - (BoundedField a) => - Lens' (Range a) a -mid = - lens - plushom - (\r m -> Range (m - plushom r, m + plushom r)) - --- | range width lens -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 (Arbitrary a) => Arbitrary (Range a) where - arbitrary = do - a <- arbitrary - b <- arbitrary - pure (Range (a,b)) - --- | choosing 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 = (<>) - -instance (Ord a) => AdditiveInvertible (Range a) - where - negate (Range (l,u)) = Range (u,l) - -instance (BoundedField a, Ord a) => AdditiveGroup (Range a) - --- | 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 projection 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 (BoundedField a, Ord a) => Signed (Range a) where - sign (Range (l,u)) = if u >= l then one else negate one - abs (Range (l,u)) = if u >= l then Range (l,u) else Range (u,l) - -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 - -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) - --- | project a data point from an old range to a new range --- project o n (view low o) == view low n --- project o n (view high o) == view high n --- project a a == id -project :: (Field b) => Range b -> Range b -> b -> b -project (Range (l0,u0)) (Range (l1,u1)) p = - ((p-l0)/(u0-l0)) * (u1-l1) + l1 - --- * linear --- | overns where data points go on the range -data LinearPos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq) - --- | turn a range into a list of n equally-spaced `a`s -linearSpace :: (Field a, FromInteger a) => LinearPos -> Range a -> Int -> [a] -linearSpace 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 -linearSpaceSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) => - LinearPos -> Range a -> Int -> [a] -linearSpaceSensible 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 --- fromLinearSpace . linearSpace OuterPos == id --- linearSpace OuterPos . fromLinearSpace == id -fromLinearSpace :: [a] -> [Range a] -fromLinearSpace as = zipWith (curry Range) as (drop 1 as) - +{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -Wall #-}++-- | A 'Range' a is a tuple representing an interval of a number space. A Range can be thought of as consisting of a low and high value, though low<high isn't strictly enforced, allowing a negative space so to speak.+-- The library uses the 'NumHask' classes and thus most of the usual arithmetic operators can be used.++module NumHask.Range+ ( Range(..)+ , (...)+ , low+ , high+ , mid+ , width+ , element+ , singleton+ , singular+ , intersection+ , contains+ , range+ , project+ , LinearPos(..)+ , linearSpace+ , linearSpaceSensible+ , fromLinearSpace+ ) 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 newtype wrapped (a, a) tuple+newtype Range a = Range { range_ :: (a, a) }+ deriving (Eq, Ord, Show, Functor)++-- | alternative constructor+(...) :: Ord a => a -> a -> Range a+a ... b+ | a <= b = Range (a, b)+ | otherwise = Range (b, a)++-- | lens for the fst of the tuple+low :: Lens' (Range a) a+low = lens (\(Range (l,_)) -> l) (\(Range (_,u)) l -> Range (l,u))++-- | lens for the snd of the tuple+high :: Lens' (Range a) a+high = lens (\(Range (_,u)) -> u) (\(Range (l,_)) u -> Range (l,u))++-- | mid-value lens+mid ::+ (BoundedField a) =>+ Lens' (Range a) a+mid =+ lens+ plushom+ (\r m -> Range (m - plushom r, m + plushom r))++-- | range width lens+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 (Arbitrary a) => Arbitrary (Range a) where+ arbitrary = do+ a <- arbitrary+ b <- arbitrary+ pure (Range (a,b))++-- | choosing 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 = (<>)++instance (Ord a) => AdditiveInvertible (Range a)+ where+ negate (Range (l,u)) = Range (u,l)++instance (BoundedField a, Ord a) => AdditiveGroup (Range a)++-- | 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 projection 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 (BoundedField a, Ord a) => Signed (Range a) where+ sign (Range (l,u)) = if u >= l then one else negate one+ abs (Range (l,u)) = if u >= l then Range (l,u) else Range (u,l)++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++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)++-- | project a data point from an old range to a new range+-- project o n (view low o) == view low n+-- project o n (view high o) == view high n+-- project a a == id+project :: (Field b) => Range b -> Range b -> b -> b+project (Range (l0,u0)) (Range (l1,u1)) p =+ ((p-l0)/(u0-l0)) * (u1-l1) + l1++-- * linear+-- | overns where data points go on the range+data LinearPos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq)++-- | turn a range into a list of n equally-spaced `a`s+linearSpace :: (Field a, FromInteger a) => LinearPos -> Range a -> Int -> [a]+linearSpace 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+linearSpaceSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) =>+ LinearPos -> Range a -> Int -> [a]+linearSpaceSensible 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+-- fromLinearSpace . linearSpace OuterPos == id+-- linearSpace OuterPos . fromLinearSpace == id+fromLinearSpace :: [a] -> [Range a]+fromLinearSpace as = zipWith (curry Range) as (drop 1 as)+
src/NumHask/Rect.hs view
@@ -1,153 +1,153 @@-{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} - -module NumHask.Rect - ( Rect(..) - , rect - , corners - , midRect - , elementRect - , singletonRect - , singularRect - , intersectionRect - , containsRect - , rangeR2 - , rangeR2s - , projectR2 - , projectRect - , 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 - --- | 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 = (<>) - -instance (Ord a) => AdditiveInvertible (Rect a) where - negate (Rect (V2 x y)) = Rect (V2 (negate x) (negate y)) - -instance (BoundedField a, Ord a) => AdditiveGroup (Rect a) - --- | 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 (BoundedField a, Ord a) => Signed (Rect a) where - sign (Rect (V2 a b)) = Rect (V2 (sign a) (sign b)) - abs (Rect (V2 a b)) = Rect (V2 (abs a) (abs b)) - -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 - --- | project a container of r2 points from an old Rect to a new one -projectR2 :: (R2 r, Field a, Functor f) => - Rect a -> Rect a -> f (r a) -> f (r a) -projectR2 (Rect (V2 rx ry)) (Rect (V2 rx' ry')) qs = - (over _x (project rx rx') . over _y (project ry ry')) <$> qs - --- | project a Rect from an old Rect range to a new one -projectRect :: (Field a) => - Rect a -> Rect a -> Rect a -> Rect a -projectRect (Rect (V2 rx ry)) (Rect (V2 rx' ry')) (Rect (V2 rx0 ry0)) = - Rect (V2 (project rx rx' <$> rx0) (project ry ry' <$> ry0)) - --- | grid points on a rectange, divided up by a V2 Int -gridP :: (Field a, FromInteger a) => LinearPos -> Rect a -> V2 Int -> [V2 a] -gridP tp (Rect (V2 rX rY)) (V2 stepX stepY) = - [V2 x y | x <- linearSpace tp rX stepX, y <- linearSpace 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 <- linearSpace LowerPos rX stepX - , y <- linearSpace LowerPos rY stepY - ] - where - sx = view width rX / fromIntegral stepX - sy = view width rY / fromIntegral stepY +{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Rect+ ( Rect(..)+ , rect+ , corners+ , midRect+ , elementRect+ , singletonRect+ , singularRect+ , intersectionRect+ , containsRect+ , rangeR2+ , rangeR2s+ , projectR2+ , projectRect+ , 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++-- | 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 = (<>)++instance (Ord a) => AdditiveInvertible (Rect a) where+ negate (Rect (V2 x y)) = Rect (V2 (negate x) (negate y))++instance (BoundedField a, Ord a) => AdditiveGroup (Rect a)++-- | 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 (BoundedField a, Ord a) => Signed (Rect a) where+ sign (Rect (V2 a b)) = Rect (V2 (sign a) (sign b))+ abs (Rect (V2 a b)) = Rect (V2 (abs a) (abs b))++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++-- | project a container of r2 points from an old Rect to a new one+projectR2 :: (R2 r, Field a, Functor f) =>+ Rect a -> Rect a -> f (r a) -> f (r a)+projectR2 (Rect (V2 rx ry)) (Rect (V2 rx' ry')) qs =+ (over _x (project rx rx') . over _y (project ry ry')) <$> qs++-- | project a Rect from an old Rect range to a new one+projectRect :: (Field a) =>+ Rect a -> Rect a -> Rect a -> Rect a+projectRect (Rect (V2 rx ry)) (Rect (V2 rx' ry')) (Rect (V2 rx0 ry0)) =+ Rect (V2 (project rx rx' <$> rx0) (project ry ry' <$> ry0))++-- | grid points on a rectange, divided up by a V2 Int+gridP :: (Field a, FromInteger a) => LinearPos -> Rect a -> V2 Int -> [V2 a]+gridP tp (Rect (V2 rX rY)) (V2 stepX stepY) =+ [V2 x y | x <- linearSpace tp rX stepX, y <- linearSpace 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 <- linearSpace LowerPos rX stepX+ , y <- linearSpace LowerPos rY stepY+ ]+ where+ sx = view width rX / fromIntegral stepX+ sy = view width rY / fromIntegral stepY
stack.yaml view
@@ -1,7 +1,7 @@-resolver: lts-8.9 - -packages: -- '.' - -extra-deps: -- numhask-0.0.4 +resolver: lts-8.23++packages:+- '.'++extra-deps:+- numhask-0.0.7
test/test.hs view
@@ -1,60 +1,60 @@-{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE DataKinds #-} - -module Main where - -import NumHask.Prelude -import NumHask.Range - -import Test.Tasty (TestName, TestTree, testGroup, defaultMain, localOption) -import Test.Tasty.QuickCheck - -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 = - defaultMain $ testGroup "range" [localOption (QuickCheckTests 1000) 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", Failiary $ expectFailure . (\a b c -> ((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 - +{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds #-}++module Main where++import NumHask.Prelude+import NumHask.Range++import Test.Tasty (TestName, TestTree, testGroup, defaultMain, localOption)+import Test.Tasty.QuickCheck++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 =+ defaultMain $ testGroup "range" [localOption (QuickCheckTests 1000) 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", Failiary $ expectFailure . (\a b c -> ((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+