numhask-range 0.0.2 → 0.0.3

raw patch · 8 files changed

+745/−777 lines, 8 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- NumHask.Rect: rangeRects :: (Ord a, BoundedField a, Traversable f) => f (Rect a) -> Rect a

- NumHask.Rect: scaleR2s :: (R2 r, BoundedField a, Traversable f, Traversable g, Ord a) => Rect a -> g (f (r a)) -> g (f (r a))

- NumHask.Rect: scaleRects :: (BoundedField a, Traversable f, Ord a) => Rect a -> f (Rect a) -> f (Rect a)

- NumHask.Rect: scaleRectss :: (BoundedField a, Traversable f, Traversable g, Ord a) => Rect a -> g (f (Rect a)) -> g (f (Rect a))

+ NumHask.Rect: projectR2 :: (R2 r, Field a, Functor f) => Rect a -> Rect a -> f (r a) -> f (r a)

+ NumHask.Rect: rangeR2 :: (Traversable f, Ord a, BoundedField a, R2 r) => f (r a) -> Rect a

Files

LICENSE +30/−30
Setup.hs +2/−2
numhask-range.cabal +143/−143
src/NumHask/Histogram.hs +110/−110
src/NumHask/Range.hs +240/−240
src/NumHask/Rect.hs +153/−185
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,143 @@-name:-  numhask-range-version:-  0.0.2-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 >= 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.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

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,185 +1,153 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}--module NumHask.Rect-  ( Rect(..)-  , rect-  , corners-  , midRect-  , elementRect-  , singletonRect-  , singularRect-  , intersectionRect-  , containsRect-  , rangeR2s-  , scaleR2s-  , rangeRects-  , projectRect-  , 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---- | 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 double container of r2s from the current Rect 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 = projectR2 (rangeR2s qss) xy <$> qss---- | 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))---- | project a container of Rects from an old Rect range to a new one-projectRects :: (Field a, Functor f) =>-    Rect a -> Rect a -> f (Rect a) -> f (Rect a)-projectRects o n f = projectRect o n <$> f---- | the range Rect 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 = projectRects (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 = projectRects (fold $ fold <$> g) xy <$> g---- | 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.9
+
+packages:
+- '.'
+
+extra-deps:
+- numhask-0.0.4

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
+