numhask-range 0.0.4 → 0.1.0

raw patch · 8 files changed

+582/−427 lines, 8 filesdep +adjunctionsdep +distributivedep +doctestdep −foldldep −lensdep −lineardep ~basedep ~numhaskPVP ok

version bump matches the API change (PVP)

Dependencies added: adjunctions, distributive, doctest, semigroupoids

Dependencies removed: foldl, lens, linear

Dependency ranges changed: base, numhask

API changes (from Hackage documentation)

Files

• numhask-range.cabal +11/−9
• src/NumHask/Histogram.hs +0/−110
• src/NumHask/Pair.hs +216/−0
• src/NumHask/Range.hs +159/−167
• src/NumHask/Rect.hs +99/−122
• src/NumHask/Space.hs +77/−0
• stack.yaml +3/−3
• test/test.hs +17/−16

@@ -1,5 +1,5 @@ name: numhask-range-version: 0.0.4+version: 0.1.0 synopsis:   Numbers that are range representations description:@@ -32,19 +32,20 @@   hs-source-dirs:     src   exposed-modules:+    NumHask.Space,     NumHask.Range,-    NumHask.Histogram,-    NumHask.Rect+    NumHask.Rect,+    NumHask.Pair   build-depends:-    base >= 4.7 && < 5,-    numhask >= 0.0.7,+    base >= 4.7 && < 4.11,+    numhask >= 0.0.9,     protolude,-    lens,-    foldl,     containers,     QuickCheck,-    linear,-    formatting+    formatting,+    adjunctions,+    distributive,+    semigroupoids   default-extensions:     NoImplicitPrelude,     UnicodeSyntax,@@ -93,6 +94,7 @@     numhask-range,     tasty,     tasty-quickcheck,+    doctest,     numhask >= 0.0.7   default-extensions:     NoImplicitPrelude,

@@ -1,110 +0,0 @@-{-# 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

@@ -0,0 +1,216 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+#if ( __GLASGOW_HASKELL__ < 820 )+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif++{-#++I would have used V2 from the linear package, but wanted to avoid the lens dependency.++#-}++module NumHask.Pair+  ( Pair(..)+  , pattern Pair+  ) where++import NumHask.Prelude++import Data.Functor.Apply (Apply(..))+import Data.Semigroup.Foldable (Foldable1(..))+import Data.Semigroup.Traversable (Traversable1(..))+import Data.Functor.Rep+import Data.Functor.Classes+import Data.Distributive+import Test.QuickCheck.Arbitrary (Arbitrary(..))++-- $setup+-- >>> :set -XNoImplicitPrelude++-- | A Pair+--+-- >>> fmap (+1) (Pair 1 2)+-- Pair 2 3+--+-- >>> pure one :: Pair Int+-- Pair 1 1+--+-- >>> (*) <$> Pair 1 2 <*> pure 2+-- Pair 2 4+--+-- >>> foldr (++) [] (Pair [1,2] [3])+-- [1,2,3]+--+-- >>> Pair "a" "pair" <> pure " " <> Pair "string" "mappend"+-- Pair "a string" "pair mappend"+--+-- | numerics+-- >>> Pair 0 1 + zero+-- Pair 0 1+--+-- >>> Pair 0 1 + Pair 2 3+-- Pair 2 4+--+-- >>> Pair 1 1 - one+-- Pair 0 0+--+-- >>> Pair 0 1 * one+-- Pair 0 1+--+-- >>> Pair 0 1 / one+-- Pair 0.0 1.0+--+-- >>> Pair 11 12 `mod` (pure 6)+-- Pair 5 0+--+-- | module+-- >>> Pair 1 2 .+ 3+-- Pair 4 5+--+-- | representations+-- >>>  distribute [Pair 1 2, Pair 3 4]+-- Pair [1,3] [2,4]+--+-- >>> index (Pair 'l' 'r') LPair+-- 'l'+-- +++-- | A pair of a's, implemented as a tuple, but api represented as a Pair of a's.+newtype Pair a = Pair' (a,a)+    deriving (Show, Eq, Ord, Generic)++pattern Pair :: a -> a -> Pair a+pattern Pair a b = Pair' (a,b)+{-# COMPLETE Pair#-}++instance Functor Pair where+    fmap f (Pair a b) = Pair (f a) (f b)++instance Eq1 Pair where+    liftEq f (Pair a b) (Pair c d) = f a c && f b d++instance Show1 Pair where+    liftShowsPrec sp _ d (Pair' (a,b)) = showsBinaryWith sp sp "Pair" d a b++instance Apply Pair where+  Pair fa fb <.> Pair a b = Pair (fa a) (fb b)++instance Applicative Pair where+    pure a = Pair a a+    (Pair fa fb) <*> Pair a b = Pair (fa a) (fb b)++instance Monad Pair where+  Pair a b >>= f = Pair a' b' where+    Pair a' _ = f a+    Pair _ b' = f b++instance Foldable Pair where+    foldMap f (Pair a b) = f a `mappend` f b++instance Foldable1 Pair+    -- foldMap1 f (Pair a b) = f a <> f b++instance Traversable Pair where+    traverse f (Pair a b) = Pair <$> f a <*> f b++instance Traversable1 Pair where+    traverse1 f (Pair a b) = Pair <$> f a Data.Functor.Apply.<.> f b++instance (Monoid a) => Monoid (Pair a) where+    mempty  = Pair mempty mempty+    (Pair a0 b0) `mappend` (Pair a1 b1) = Pair (a0 `mappend` a1) (b0 `mappend` b1)++instance Distributive Pair where+  collect f x = Pair (getL . f <$> x) (getR . f <$> x)+    where getL (Pair l _) = l+          getR (Pair _ r) = r++instance Representable Pair where+  type Rep Pair = Bool+  tabulate f = Pair (f False) (f True)+  index (Pair l _) False = l+  index (Pair _ r) True = r++instance NFData a => NFData (Pair a) where+  rnf (Pair a b) = rnf a `seq` rnf b++instance (Arbitrary a) => Arbitrary (Pair a) where+    arbitrary = do+        a <- arbitrary+        b <- arbitrary+        pure (Pair a b)++-- * numeric heirarchy+instance (AdditiveMagma a) => AdditiveMagma (Pair a) where+    plus (Pair a0 b0) (Pair a1 b1) = Pair (a0 `plus` a1) (b0 `plus` b1)++instance (AdditiveUnital a) => AdditiveUnital (Pair a) where+    zero = Pair zero zero++instance (AdditiveMagma a) => AdditiveAssociative (Pair a)+instance (AdditiveMagma a) => AdditiveCommutative (Pair a)+instance (AdditiveUnital a) => Additive (Pair a)++instance (AdditiveInvertible a) => AdditiveInvertible (Pair a) where+    negate (Pair a b) = Pair (negate a) (negate b)++instance (AdditiveUnital a, AdditiveInvertible a ) => AdditiveGroup (Pair a)++instance (MultiplicativeMagma a) => MultiplicativeMagma (Pair a) where+    times (Pair a0 b0) (Pair a1 b1) = Pair (a0 `times` a1) (b0 `times` b1)++instance (MultiplicativeUnital a) => MultiplicativeUnital (Pair a) where+    one = Pair one one++instance (MultiplicativeMagma a) => MultiplicativeAssociative (Pair a)+instance (MultiplicativeMagma a) => MultiplicativeCommutative (Pair a)+instance (MultiplicativeUnital a) => Multiplicative (Pair a)++instance (MultiplicativeInvertible a) => MultiplicativeInvertible (Pair a) where+    recip (Pair a b) = Pair (recip a) (recip b)++instance (MultiplicativeUnital a, MultiplicativeInvertible a ) => MultiplicativeGroup (Pair a)++-- | integral instance+instance (Integral a) => Integral (Pair a) where+    (Pair a0 b0) `divMod` (Pair a1 b1) = (Pair da db, Pair ma mb)+      where+        (da,ma) = a0 `divMod` a1+        (db,mb) = b0 `divMod` b1++-- metric instances+instance (Signed a) => Signed (Pair a) where+    sign (Pair a b) = Pair (sign a) (sign b)+    abs (Pair a b) = Pair (abs a) (abs b)++instance (ExpField a, AdditiveGroup a, MultiplicativeUnital a) => Normed (Pair a) a where+    size (Pair a b) = sqrt (a**(one+one) + b**(one+one))++instance (Epsilon a) => Epsilon (Pair a) where+    nearZero (Pair a b) = nearZero a && nearZero b+    aboutEqual a b = nearZero $ a - b++instance (ExpField a) => Metric (Pair a) a where+    distance (Pair a0 b0) (Pair a1 b1) = size (Pair (a1-a0) (b1-b0))++-- | ring instances+instance (AdditiveGroup a, Distribution a) =>+    Distribution (Pair a)+instance (Ring a) => Ring (Pair a)+instance (AdditiveGroup a, Semiring a) => Semiring (Pair a)+instance (CRing a) => CRing (Pair a)+instance (Field a) => Field (Pair a)+instance (ExpField a) => ExpField (Pair a) where+    exp (Pair a b) = Pair (exp a) (exp b)+    log (Pair a b) = Pair (log a) (log b)+instance (BoundedField a) => BoundedField (Pair a) where+    isNaN (Pair a b) = isNaN a || isNaN b

@@ -1,215 +1,215 @@-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-}+#if ( __GLASGOW_HASKELL__ < 820 )+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif --- | 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.+{- | +'Range -0.5 0.5 :: Range Double' is a 1-dimensional instance of a 'Space Double' from -0.5 to 0.5 on the Double number line.++The instances chosen for 'NumHask.Range' are conducive to Charting.  Specifically:++- a Range is polymorphic, with the main constraint being 'Ord a'+- 'NumHask.Additive.Additive' and 'NumHask.Multiplicative.Multiplicative' instances define numeric manipulation rather than relying on the 'Num' class in base.+- '(+)' and '(<>)' are defined as the convex hull of two ranges (compare the interval package approach for + of `fmap (+)`). 'zero' and 'mempty' are defined as `Range infinity neginfinity`.  This arrangement targets a neat definition for conversion of a foldable into a range via a very neat `foldMap singleton`.  An additional benefit is that Ranges are additively idempotent (a + a = a).++- The starting point for understanding Range multiplication is the diagrams <https://hackage.haskell.org/package/diagrams-lib-1.4.1.2/docs/Diagrams-TwoD-Shapes.html#v:unitSquare unitSquare>.  Restricting consideration to one-dimension, a natural 'one' Range is `Range -0.5 0.5`, which uniquely satisfies the equations:++  `mid one == zero`+  `width one == one`++  where the right zero and one refer to the underlying type.++-}+ module NumHask.Range   ( Range(..)-  , (...)-  , low-  , high-  , mid-  , width-  , element-  , singleton-  , singular-  , intersection-  , contains-  , range-  , project-  , LinearPos(..)-  , linearSpace-  , linearSpaceSensible-  , fromLinearSpace+  , pattern Range+  , gridSensible  ) 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+import NumHask.Space --- | a newtype wrapped (a, a) tuple-newtype Range a = Range { range_ :: (a, a) }-  deriving (Eq, Ord, Show, Functor)+import Data.Functor.Apply (Apply(..))+import Data.Semigroup.Foldable (Foldable1(..))+import Data.Semigroup.Traversable (Traversable1(..))+import Data.Functor.Rep+import Data.Functor.Classes+import Data.Distributive+import Test.QuickCheck.Arbitrary (Arbitrary(..))+import qualified Text.Show as Show --- | alternative constructor-(...) :: Ord a => a -> a -> Range a-a ... b-  | a <= b = Range (a, b)-  | otherwise = Range (b, a)+-- $setup+-- >>> :set -XNoImplicitPrelude+-- >>> :set -XExtendedDefaultRules+-- --- | lens for the fst of the tuple-low :: Lens' (Range a) a-low = lens (\(Range (l,_)) -> l) (\(Range (_,u)) l -> Range (l,u))+-- | Range is a newtype wrapped (a,a) tuple+newtype Range a = Range' (a,a)+  deriving (Eq, Generic) --- | lens for the snd of the tuple-high :: Lens' (Range a) a-high = lens (\(Range (_,u)) -> u) (\(Range (l,_)) u -> Range (l,u))+-- | A tuple is the preferred concrete implementation of a Range, due to many libraries having substantial optimizations for tuples already (eg 'Vector').  'Pattern Synonyms' allow us to recover a constructor without the need for tuple syntax.+-- >>> Range 0 1+-- Range 0 1+pattern Range :: a -> a -> Range a+pattern Range a b = Range' (a, b)+{-# COMPLETE Range#-} --- | mid-value lens-mid ::-    (BoundedField a) =>-    Lens' (Range a) a-mid =-    lens-    plushom-    (\r m -> Range (m - plushom r, m + plushom r))+-- | recovering the synonym name+instance (Show a) => Show (Range a) where+    show (Range a b) = "Range " <> show a <> " " <> show b --- | 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 Eq1 Range where+    liftEq f (Range a b) (Range c d) = f a c && f b d -instance (Arbitrary a) => Arbitrary (Range a) where-    arbitrary = do-        a <- arbitrary-        b <- arbitrary-        pure (Range (a,b))+instance Show1 Range where+    liftShowsPrec sp _ d (Range' (a,b)) = showsBinaryWith sp sp "Range" d 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)+-- | and here we recover the desired property of fmap'ing over both elements in contrast to the (a,) functor.+instance Functor Range where+    fmap f (Range a b) = Range (f a) (f b) -instance (Ord a, BoundedField a) => AdditiveUnital (Range a) where-    zero = Range (infinity,neginfinity)+instance Apply Range where+  Range fa fb <.> Range a b = Range (fa a) (fb b) -instance (Ord a) => AdditiveAssociative (Range a)-instance (Ord a) => AdditiveCommutative (Range a)-instance (Ord a, BoundedField a) => Additive (Range a)+instance Applicative Range where+    pure a = Range a a+    (Range fa fb) <*> Range a b = Range (fa a) (fb b) -instance (Ord a) => Semigroup (Range a) where-    (<>) = plus+instance Monad Range where+  Range a b >>= f = Range a' b' where+    Range a' _ = f a+    Range _ b' = f b -instance (AdditiveUnital (Range a), Semigroup (Range a)) => Monoid (Range a) where-    mempty = zero-    mappend = (<>)+instance Foldable Range where+    foldMap f (Range a b) = f a `mappend` f b -instance (Ord a) => AdditiveInvertible (Range a)-    where-        negate (Range (l,u)) = Range (u,l)+instance Foldable1 Range -instance (BoundedField a, Ord a) => AdditiveGroup (Range a)+instance Traversable Range where+    traverse f (Range a b) = Range <$> f a <*> f b --- | 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+instance Traversable1 Range where+    traverse1 f (Range a b) = Range <$> f a Data.Functor.Apply.<.> f b --- | 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+instance Distributive Range where+  collect f x = Range (getL . f <$> x) (getR . f <$> x)+    where getL (Range l _) = l+          getR (Range _ r) = r +instance Representable Range where+  type Rep Range = Bool+  tabulate f = Range (f False) (f True)+  index (Range l _) False = l+  index (Range _ r) True = r++instance (Arbitrary a) => Arbitrary (Range a) where+    arbitrary = do+        a <- arbitrary+        b <- arbitrary+        pure (Range a b)++instance NFData a => NFData (Range a) where+  rnf (Range a b) = rnf a `seq` rnf b++two :: (MultiplicativeUnital a, Additive a) => a+two = one + one++half :: (Field a) => a+half = one / two+ -- | 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)+instance (Ord a, BoundedField a, FromInteger 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+          m = mid a + mid b+          r = width a * width b  -- | The unital object derives from: ----- view range one = one--- view mid zero = zero+-- width one = one+--+-- mid zero = zero+-- -- ie (-0.5,0.5)-instance (BoundedField a) => MultiplicativeUnital (Range a) where-    one = Range (negate half, half)+instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeUnital (Range a) where+    one = Range (negate half) half -instance (BoundedField a) => MultiplicativeAssociative (Range a)+instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeAssociative (Range a) -instance (Ord a, BoundedField a) => MultiplicativeInvertible (Range a) where-    recip a = case view width a == zero of+instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeInvertible (Range a) where+    recip a = case width a == zero of       True  -> theta-      False -> Range (m - r/two, m + r/two)+      False -> Range (m - r/two) (m + r/two)         where-          m = negate (view mid a) * recip (view width a)-          r = recip (view width a)+          m = negate (mid a)+          r = recip (width a) -instance (Ord a, BoundedField a) => MultiplicativeRightCancellative (Range a)-instance (Ord a, BoundedField a) => MultiplicativeLeftCancellative (Range a)+instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeCommutative (Range a)+instance (Ord a, BoundedField a, FromInteger a) => Multiplicative (Range a)+instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeGroup (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 (AdditiveInvertible a, BoundedField a, Ord a, FromInteger a) => Signed (Range a) where+    sign (Range l u) = if u >= l then one else (Range half (negate half))+    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+    size (Range l u) = u-l  instance (Ord a, AdditiveGroup a) => Metric (Range a) a where-    distance (Range (l,u)) (Range (l',u'))+    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+theta = Range zero zero --- * linear--- | overns where data points go on the range-data LinearPos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq)+instance (Ord a, BoundedField a, FromInteger a) => Space (Range a) where+    type Element (Range a) = a+    union (Range l0 u0) (Range l1 u1) = Range (min l0 l1) (max u0 u1)+    nul = Range infinity neginfinity+    lower (Range l _) = l+    upper (Range _ u) = u+    singleton a = Range a a+    type Grid (Range a) = Int+    grid :: (FromInteger a) => Pos -> Range a -> Int -> [a]+    grid o s n = (+ if o==MidPos then step/(one+one) else zero) <$> posns+      where+        posns = (lower s +) . (step *) . fromIntegral <$> [i0..i1]+        step = (/) (width s) (fromIntegral n)+        (i0,i1) = case o of+                    OuterPos -> (zero,n)+                    InnerPos -> (one,n - one)+                    LowerPos -> (zero,n - one)+                    UpperPos -> (one,n)+                    MidPos -> (zero,n - one)+    gridSpace r n = zipWith Range ps (drop 1 ps)+      where+        ps = grid OuterPos r n --- | 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)+instance (Ord a, BoundedField a, FromInteger a) => Monoid (Range a) where+    mempty = nul+    mappend = union  -- | 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 =+gridSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) =>+    Pos -> Range a -> Int -> [a]+gridSensible tp (Range l u) n =     (+ if tp==MidPos then step/two else zero) <$> posns   where     posns = (first' +) . (step *) . fromIntegral <$> [i0..i1]@@ -230,11 +230,3 @@                 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)-

@@ -1,153 +1,130 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-}+#if ( __GLASGOW_HASKELL__ < 820 )+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif  module NumHask.Rect   ( Rect(..)-  , rect+  , pattern Rect+  , pattern Ranges   , corners-  , midRect-  , elementRect-  , singletonRect-  , singularRect-  , intersectionRect-  , containsRect-  , rangeR2-  , rangeR2s-  , projectR2   , projectRect-  , gridP-  , grid   ) where +import NumHask.Space import NumHask.Range+import NumHask.Pair 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)+import Data.Functor.Compose+import Data.Functor.Apply (Apply(..))+import Data.Semigroup.Foldable (Foldable1(..))+import Data.Functor.Rep+import Data.Distributive --- | natural interpretation of an `a` as an `Rect a`-instance (Ord a) =>-    AdditiveHomomorphic (V2 a) (Rect a) where-    plushom v = singletonRect v+-- | a two-dimensional plane, implemented as a composite of a 'Pair' of 'Range's.+newtype Rect a = Rect' (Compose Pair Range a)+    deriving (Show, Eq, Functor, Apply, Applicative, Foldable, Foldable1, Traversable) -instance (BoundedField a) => MultiplicativeMagma (Rect a) where-    (Rect (V2 a0 b0)) `times` (Rect (V2 a1 b1)) =-        Rect (V2 (a0 `times` a1) (b0 `times` b1))+pattern Rect :: a -> a -> a -> a -> Rect a+pattern Rect a b c d = Rect' (Compose (Pair (Range a b) (Range c d)))+{-# COMPLETE Rect#-} -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)+pattern Ranges :: Range a -> Range a -> Rect a+pattern Ranges a b = Rect' (Compose (Pair a b))+{-# COMPLETE Ranges#-} -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 (Ord a, BoundedField a, FromInteger a) => MultiplicativeMagma (Rect a) where+    times (Ranges x0 y0) (Ranges x1 y1) = Ranges (x0 `times` x1) (y0 `times` y1) -instance (AdditiveGroup a) => Normed (Rect a) (V2 a) where-    size (Rect (V2 x y)) = V2 (size x) (size y)+instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeUnital (Rect a) where+    one = Ranges one one -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)+instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeAssociative (Rect a) +instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeCommutative (Rect a) -midRect :: (BoundedField a) => Rect a -> V2 a-midRect (Rect (V2 x y)) = V2 (plushom x) (plushom y)+instance (Ord a, BoundedField a, FromInteger a) => Multiplicative (Rect a) --- | 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+instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeInvertible (Rect a) where+    recip (Ranges x y) = Ranges (recip x) (recip y) --- | 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+instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeGroup (Rect a) -singletonRect :: V2 a -> Rect a-singletonRect (V2 x y) = Rect (V2 (singleton x) (singleton y)) +instance (AdditiveInvertible a, BoundedField a, Ord a, FromInteger a) => Signed (Rect a) where+    sign (Ranges l u) = Ranges (sign l) (sign u)+    abs (Ranges l u) = Ranges (sign l * l) (sign u * u) -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))+instance (AdditiveGroup a) => Normed (Rect a) (Pair a) where+    size (Ranges l u) = Pair (size l) (size u) -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+instance Distributive Rect where+  collect f x =+      Rect+      (getA . f <$> x)+      (getB . f <$> x)+      (getC . f <$> x)+      (getD . f <$> x)+    where getA (Rect a _ _ _) = a+          getB (Rect _ b _ _) = b+          getC (Rect _ _ c _) = c+          getD (Rect _ _ _ d) = d -corners :: Rect a -> [V2 a]-corners (Rect (V2 (Range (lx,ux)) (Range (ly,uy)))) = [V2 lx ly, V2 ux uy]+instance Representable Rect where+  type Rep Rect = (Bool, Bool)+  tabulate f =+      Rect+      (f (False, False))+      (f (False, True))+      (f (True, False))+      (f (True, True))+  index (Rect a _ _ _) (False, False) = a+  index (Rect _ b _ _) (False, True) = b+  index (Rect _ _ c _) (True, False) = c+  index (Rect _ _ _ d) (True, True) = d --- | 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))+instance (FromInteger a, Ord a, BoundedField a) => Space (Rect a) where+    type Element (Rect a) = Pair a+    nul = Ranges nul nul+    union (Ranges a b) (Ranges c d) = Ranges (a `union` c) (b `union` d)+    lower (Rect l0 _ l1 _) = Pair l0 l1+    upper (Rect _ u0 _ u1) = Pair u0 u1+    singleton (Pair x y) = Rect x x y y+    type Grid (Rect a) = Pair Int+    grid :: (FromInteger a) => Pos -> Rect a -> Pair Int -> [Pair a]+    grid o s n = (+ if o==MidPos then step/(one+one) else zero) <$> posns+      where+        posns = (lower s +) . (step *) . fmap fromIntegral <$>+            [Pair x y | x <- [x0..x1], y <- [y0..y1]]+        step = (/) (width s) (fromIntegral <$> n)+        (Pair x0 y0, Pair x1 y1) = case o of+                    OuterPos -> (zero,n)+                    InnerPos -> (one,n - one)+                    LowerPos -> (zero,n - one)+                    UpperPos -> (one,n)+                    MidPos -> (zero,n - one)+    gridSpace (Ranges rX rY) (Pair stepX stepY)=+        [ Rect x (x+sx) y (y+sy)+        | x <- grid LowerPos rX stepX+        , y <- grid LowerPos rY stepY+        ]+      where+        sx = width rX / fromIntegral stepX+        sy = width rY / fromIntegral stepY --- | 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+instance (Ord a, BoundedField a, FromInteger a) => Monoid (Rect a) where+    mempty = nul+    mappend = union --- | 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+corners :: (FromInteger a, BoundedField a, Ord a) => Rect a -> [Pair a]+corners r = [lower r, upper r]  -- | project a Rect from an old Rect range to a new one-projectRect :: (Field a) =>+projectRect :: (FromInteger a, Ord a, BoundedField 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+projectRect r0 r1 (Rect a b c d) = Rect a' b' c' d' where+    (Pair a' c') = project r0 r1 (Pair a c)+    (Pair b' d') = project r0 r1 (Pair b d)

@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}+#if ( __GLASGOW_HASKELL__ < 820 )+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif++{- |++A 'Space' represents a continuous interval of a type a. The <https://hackage.haskell.org/package/intervals interval> package is an alternative approach.++-}++module NumHask.Space+  ( Space(..)+  , Pos(..)+  ) where++import NumHask.Prelude++class (Eq (Element s), Ord (Element s), Field (Element s)) => Space s where+    type Element s :: *+    -- | lower boundary of space+    lower :: s -> Element s+    -- | upper boundary of space+    upper :: s -> Element s+    -- | mid-point of the space+    mid :: s -> Element s+    mid s = (lower s + upper s)/(one+one)+    -- | distance between boundaries+    width :: s -> Element s+    width s = upper s - lower s+    -- | singleton space+    singleton :: Element s -> s+    -- | zero-width test+    singular :: s -> Bool+    singular s = lower s == upper s+    -- | determine whether an a is in the space+    element :: Element s -> s -> Bool+    element a s = a >= lower s && a <= upper s+    -- | is a space contained within another?+    contains :: s -> s -> Bool+    contains s0 s1 = lower s0 <= lower s1 && upper s0 >= upper s1+    -- | convex hull+    union :: s -> s -> s+    -- | null space, which can be interpreted as mempty+    nul :: s+    -- | the containing space of a Foldable+    space :: (Foldable f) => f (Element s) -> s+    space = foldr (\a x -> x `union` singleton a) nul+    -- | project a data point from an old range to a new range+    --+    -- project o n (lower o) == lower n+    --+    -- project o n (upper o) == upper n+    --+    -- project a a == id+    project :: s -> s -> Element s -> Element s+    project s0 s1 p =+        ((p-lower s0)/(upper s0-lower s0)) * (upper s1-lower s1) + lower s1+    type Grid s :: *+    -- | create equally-spaced `a`s from a space+    grid :: Pos -> s -> Grid s -> [Element s]+    -- | create equally-spaced `Space a`s from a space+    gridSpace :: s -> Grid s -> [s]++-- | Pos suggests where data points are placed on a grid across a range. Pos can also be thought about as whether the lower and upper points on the range are open or closed (plus the mid-point as an extra option).+data Pos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq)

@@ -1,7 +1,7 @@-resolver: lts-8.23+resolver: lts-8.24  packages:-- '.'+  - '.'  extra-deps:-- numhask-0.0.7+  - numhask-0.0.9

@@ -1,5 +1,9 @@-{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}+-- ghc-8.2 should sort out pattern matching bugs+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}  module Main where @@ -8,6 +12,7 @@  import Test.Tasty (TestName, TestTree, testGroup, defaultMain, localOption) import Test.Tasty.QuickCheck+import Test.DocTest  data LawArity a =     Nonary Bool |@@ -31,30 +36,26 @@ testRange = testGroup "Data.Range" $ testLawOf ([]::[Range Double]) <$> rangeLaws  main :: IO ()-main =-    defaultMain $ testGroup "range" [localOption (QuickCheckTests 1000) testRange]+main = do+    defaultMain $ testGroup "range" [localOption (QuickCheckTests 100) testRange]+    doctest ["src/NumHask/Range.hs"]  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))))+    [ ("associative: a * (b * c) = (a * b) * c", Ternary (\a b c -> fuzzyeq 1e-4 ((a * b) * c) (a * (b * 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))+    , ("commutative: a * b == b * a", Binary (\a b -> fuzzyeq 1e-4 (a * b) (b * a)))+    , ("recip iso: recip . recip == id", Unary (\a -> zeroRange a || fuzzyeq 1e-2 (recip . recip $ a) a))+    , ("divide: zero range || a / a = one", Unary (\a -> zeroRange a || fuzzyeq 1e-4 (a / a) one))+    , ("recip left: zero range || recip a * a == one",  Unary (\a -> zeroRange a ||fuzzyeq 1e-4 (recip a * a) one))+    , ("recip right: zero range || a * recip a == one", Unary (\a -> zeroRange a || fuzzyeq 1e-4 (a * recip a) one))     ]  fuzzyeq :: (AdditiveGroup a, Ord a) => a -> Range a -> Range a -> Bool-fuzzyeq eps0 (Range (l0,u0)) (Range (l1,u1)) =+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+zeroRange (Range l u) = l==u