numhask-range 0.1.0 → 0.1.1

raw patch · 9 files changed

+668/−319 lines, 9 filesdep −containersdep −formattingdep ~QuickCheckdep ~adjunctionsdep ~distributivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: containers, formatting

Dependency ranges changed: QuickCheck, adjunctions, distributive, numhask, protolude, semigroupoids

API changes (from Hackage documentation)

Files

• numhask-range.cabal +19/−62
• other/unitSquare.svg +1/−0
• readme.md +47/−4
• src/NumHask/Pair.hs +86/−80
• src/NumHask/Range.hs +83/−45
• src/NumHask/Rect.hs +190/−75
• src/NumHask/Space.hs +9/−20
• stack.yaml +1/−2
• test/test.hs +232/−31

@@ -1,5 +1,5 @@ name: numhask-range-version: 0.1.0+version: 0.1.1 synopsis:   Numbers that are range representations description:@@ -21,10 +21,13 @@ build-type:   Simple cabal-version:-  >=1.14+  >=1.18 extra-source-files:-  readme.md-  stack.yaml+  readme.md,+  stack.yaml,+  other/*.svg+extra-doc-files:+  other/*.svg library   default-language:     Haskell2010@@ -39,46 +42,22 @@   build-depends:     base >= 4.7 && < 4.11,     numhask >= 0.0.9,-    protolude,-    containers,-    QuickCheck,-    formatting,-    adjunctions,-    distributive,-    semigroupoids+    protolude >= 0.1.8 && < 0.3,+    QuickCheck >= 2.8 && < 3,+    adjunctions >= 4.3 && < 5,+    distributive >= 0.5 && < 0.6,+    semigroupoids >= 5.1 && < 6   default-extensions:-    NoImplicitPrelude,-    UnicodeSyntax,-    BangPatterns,-    BinaryLiterals,-    DeriveFoldable,-    DeriveFunctor,     DeriveGeneric,     DeriveTraversable,-    DisambiguateRecordFields,-    EmptyCase,     FlexibleContexts,-    FlexibleInstances,-    FunctionalDependencies,-    GADTSyntax,     InstanceSigs,-    KindSignatures,-    LambdaCase,-    MonadComprehensions,     MultiParamTypeClasses,-    MultiWayIf,-    NegativeLiterals,+    NoImplicitPrelude,     OverloadedStrings,-    ParallelListComp,-    PartialTypeSignatures,     PatternSynonyms,-    RankNTypes,-    RecordWildCards,-    RecursiveDo,-    ScopedTypeVariables,-    TupleSections,     TypeFamilies,-    TypeOperators+    UnicodeSyntax  test-suite test   default-language:@@ -91,44 +70,22 @@     test.hs   build-depends:     base >= 4.7 && < 5,+    doctest,+    numhask >= 0.0.9,     numhask-range,     tasty,-    tasty-quickcheck,-    doctest,-    numhask >= 0.0.7+    tasty-quickcheck   default-extensions:-    NoImplicitPrelude,-    UnicodeSyntax,-    BangPatterns,-    BinaryLiterals,-    DeriveFoldable,-    DeriveFunctor,     DeriveGeneric,     DeriveTraversable,-    DisambiguateRecordFields,-    EmptyCase,     FlexibleContexts,-    FlexibleInstances,-    FunctionalDependencies,-    GADTSyntax,     InstanceSigs,-    KindSignatures,-    LambdaCase,-    MonadComprehensions,     MultiParamTypeClasses,-    MultiWayIf,-    NegativeLiterals,+    NoImplicitPrelude,     OverloadedStrings,-    ParallelListComp,-    PartialTypeSignatures,     PatternSynonyms,-    RankNTypes,-    RecordWildCards,-    RecursiveDo,-    ScopedTypeVariables,-    TupleSections,     TypeFamilies,-    TypeOperators+    UnicodeSyntax  source-repository head   type:

@@ -0,0 +1,1 @@+<svg xmlns="http://www.w3.org/2000/svg" height="100.0000" stroke-opacity="1" viewBox="0 0 100 100" font-size="1" width="100.0000" xmlns:xlink="http://www.w3.org/1999/xlink" stroke="rgb(0,0,0)" version="1.1"><defs></defs><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.5" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 95.4545,95.4545 l -0.0000,-90.9091 h -90.9091 l -0.0000,90.9091 Z"/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 52.0000,50.0000 c 0.0000,-1.1046 -0.8954,-2.0000 -2.0000 -2.0000c -1.1046,-0.0000 -2.0000,0.8954 -2.0000 2.0000c -0.0000,1.1046 0.8954,2.0000 2.0000 2.0000c 1.1046,0.0000 2.0000,-0.8954 2.0000 -2.0000Z"/></g></svg>

@@ -3,9 +3,52 @@  [![Build Status](https://travis-ci.org/tonyday567/numhask-range.svg)](https://travis-ci.org/tonyday567/numhask-range) [![Hackage](https://img.shields.io/hackage/v/numhask-range.svg)](https://hackage.haskell.org/package/numhask-range) [![lts](https://www.stackage.org/package/numhask-range/badge/lts)](http://stackage.org/lts/package/numhask-range) [![nightly](https://www.stackage.org/package/numhask-range/badge/nightly)](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.+A `Space` represents an interval over a type.  The main instance of a Space, a `Range`, consists of a lower and upper value, though `lower > upper` is allowed, and leads to a useful definition of a negative space. A `Rect` is a wrapped `Compose Pair Range` and so a two-dimensional Space. -The library includes modules for:+spatial zeros and ones+--- -- `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.+This library emerged as a bridge between `chart-unit`, an effort to create a clean, minimalist chart api, and `numhask`, an effort to create clean, minimalist numerical classes.++If you ask yourself what a chart is, sifting through the cruft of accumulated practice, nomenclature and usage, digging deep for charting's essence, and if you ask the question in haskell, here's what you find:++![other/unitSquare.svg](other/unitSquare.svg)++To a first approximation, charting is transforming unit squares and placing them on a physical XY plane, such as a screen, or on graph paper.  A rectangle is a distended square; a line is a very thin rectangle; a histogram is a series of rectangles, and axes are nothing more than a collection of squares. The main thing on a chart that isn't a square is text, but even then we use square pixels to render.++one+---++As a well-meaning, but eternally confused student of category theory, I had learnt to pay attention to the simplest thing I could find within a problem domain. To quote from the [haddock](https://www.stackage.org/haddock/lts-8.24/diagrams-lib-1.4.1.2/Diagrams-TwoD-Shapes.html#v:unitSquare), a unitSquare is "a square with its center at the origin and sides of length 1, oriented parallel to the axes." When we first learn to chart, the origin of a graph is usually at the bottom left, and only moves to the center once we learn our negative numbers. The origin for html/svg/css is at top left, however, and the y-axis heads down not up. So what makes this co-ordinate system the right one?++Reducing down to the one dimension case, the diagrams unit boils down to a range along a dimension of -0.5 to 0.5, or `Range -0.5 0.5`.  Length is 1 and the mid-point is 0, so if we define `Range -0.5 0.5` as `one`, the multiplicative unit, we get the very neat:++    mid one == zero+    width one == one++which absolutely nails the correct co-ordinate system, once you see how it easily it can extend to the two-dimensional case: ++    mid (one :: Rect a) == zero :: Pair a+    width (one :: Rect a) == one :: Pair a++zero+---++As a card carrying member of the `+ and <> should be the same thing` committee, I gravitated towards a monoidally additive definition:++    zero = Range infinity neginfinity+    (+) (Range l u) (Range l' u') = Range (min l l') (max u u')+    (<>) = (+)+    mempty = zero++Known as a convex hull union, this operation is the bread-and-butter of charting.  If you have an object at Range 2 3 and one at Range 0 1, then you're going to have to draw over Range 0 3 to get it all on the page.++It's very similar to a tropical semiring, which sets infinity as zero, min as +, and + as *, often summarised as (infinity,min,+) versus the usual (0,+,*) semiring. Reading up on star-semirings [here](http://r6.ca/blog/20110808T035622Z.html), I suspect that an operation that doesn't fill in the holes, that remembers contiguous and non-contiguous intervals in a space, will complete this mempty and plus definition to form a star-semiring.  But the unification of charting and regular expressions is another tale.++space+---++If spatial one and zero are the inspiration of the library, then NumHask.Space is the perspiration.  The Space class are all the various bits and bobs that made up earlier versions of chart operations, refactored a hundred times and slowly reduced to a managable and coherent class.++The Space class came out of common functionality between Range and Rect.  If current trends continue, Space will consume the remaining components of the Range class.  To effect this, however, requires the number heirarchy to be defined for the Space class, which currently leads to compiler whining about orphans, ambiguity and undecidables.  It may be that the consumption of Range ideas will lead to the necessity of wrapping Space in a newtype and that wrapper name may best be Range.  The grind continues.+

@@ -1,138 +1,131 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# 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 -{-#--I would have used V2 from the linear package, but wanted to avoid the lens dependency.--#-}-+-- | I would have used V2 from the linear package, but wanted to avoid the lens dependency. And there's no canonical treatment out there. module NumHask.Pair   ( Pair(..)   , pattern Pair   ) where  import NumHask.Prelude+import Text.Show +import Data.Distributive import Data.Functor.Apply (Apply(..))+import Data.Functor.Classes 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+-- | A pair of a's, implemented as a tuple, but api represented as a Pair of a's. -- -- >>> 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"+-- >>> Pair "a" "pair" `mappend` pure " " `mappend` Pair "string" "mappended"+-- Pair "a string" "pair mappended" ----- | numerics+-- As a Ring and Field class+--  -- >>> 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+-- As a numhask module+-- -- >>> Pair 1 2 .+ 3 -- Pair 4 5 ----- | representations+-- representables+-- -- >>>  distribute [Pair 1 2, Pair 3 4] -- Pair [1,3] [2,4]------ >>> index (Pair 'l' 'r') LPair+-- >>> index (Pair 'l' 'r') False -- '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)+newtype Pair a =+  Pair' (a, a)+  deriving (Eq, Generic) +-- | the preferred pattern pattern Pair :: a -> a -> Pair a pattern Pair a b = Pair' (a,b) {-# COMPLETE Pair#-} +instance (Show a) => Show (Pair a) where+  show (Pair a b) = "Pair " <> Text.Show.show a <> " " <> Text.Show.show b+ instance Functor Pair where-    fmap f (Pair a b) = Pair (f a) (f b)+  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+  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+  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)+  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+  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+  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+  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+  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)+  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+    where+      getL (Pair l _) = l+      getR (Pair _ r) = r  instance Representable Pair where   type Rep Pair = Bool@@ -144,73 +137,86 @@   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)+  arbitrary = do+    a <- arbitrary+    b <- arbitrary+    pure (Pair a b) --- * numeric heirarchy+-- numeric heirarchy instance (AdditiveMagma a) => AdditiveMagma (Pair a) where-    plus (Pair a0 b0) (Pair a1 b1) = Pair (a0 `plus` a1) (b0 `plus` b1)+  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+  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)+  negate (Pair a b) = Pair (negate a) (negate b) -instance (AdditiveUnital a, AdditiveInvertible a ) => AdditiveGroup (Pair a)+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)+  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+  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)+  recip (Pair a b) = Pair (recip a) (recip b) -instance (MultiplicativeUnital a, MultiplicativeInvertible a ) => MultiplicativeGroup (Pair a)+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+  (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)+  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 (ExpField a, AdditiveGroup a, MultiplicativeUnital a) =>+         Normed (Pair a) a where+  size (Pair a b) = sqrt (a ** (one + one) + b ** (one + one)) +-- | L1-based Ord instance+instance (Eq a, Ord a, Signed a, Additive a) => Ord (Pair a) where+  (<=) (Pair x y) (Pair x' y') = (abs x + abs y) <= (abs x' + abs y')+ instance (Epsilon a) => Epsilon (Pair a) where-    nearZero (Pair a b) = nearZero a && nearZero b-    aboutEqual a b = nearZero $ a - b+  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))+  distance (Pair a0 b0) (Pair a1 b1) = size (Pair (a1 - a0) (b1 - b0)) --- | ring instances-instance (AdditiveGroup a, Distribution a) =>-    Distribution (Pair a)+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)+  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+  isNaN (Pair a b) = isNaN a || isNaN b

@@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternSynonyms #-}@@ -14,38 +14,19 @@ {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} #endif -{- |--'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.---}-+-- | representation of a continuous range of a type module NumHask.Range   ( Range(..)   , pattern Range   , gridSensible  ) where -import NumHask.Prelude+import NumHask.Prelude hiding (singleton) import NumHask.Space  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(..))@@ -53,21 +34,61 @@  -- $setup -- >>> :set -XNoImplicitPrelude--- >>> :set -XExtendedDefaultRules++-- | A continuous range over type a --+-- >>> let a = Range (-1) 1+-- >>> a+-- Range -1 1+-- >>> fmap (+1) (Range 1 2)+-- Range 2 3+-- >>> one :: Range Double+-- Range -0.5 0.5+-- >>> zero :: Range Double+-- Range Infinity -Infinity --- | Range is a newtype wrapped (a,a) tuple+-- | as a Field instance+--+-- >>> Range 0 1 + zero+-- Range 0.0 1.0+-- >>> Range 0 1 + Range 2 3+-- Range 0.0 3.0+-- >>> Range 1 1 - one+-- Range 0.5 1.0+-- >>> Range 0 1 * one+-- Range 0.0 1.0+-- >>> Range 0 1 / one+-- Range 0.0 1.0+-- >>> singleton 2.3 :: Range Double+-- Range 2.3 2.3+-- >>> abs (Range 1 0)+-- Range 0.0 1.0+-- >>> sign (Range 1 0) == negate one+-- True+--+-- Idempotent+--+-- >>> Range 0 2 + Range 0 2+-- Range 0.0 2.0+--+-- as a space instance+--+-- >>> project (Range 0 1) (Range 1 4) 0.5+-- 2.5+-- >>> grid OuterPos (Range 0 10) 5+-- [0.0,2.0,4.0,6.0,8.0,10.0]+-- >>> gridSpace (Range 0 1) 4+-- [Range 0.0 0.25,Range 0.25 0.5,Range 0.5 0.75,Range 0.75 1.0]+-- >>> gridSensible OuterPos (Range (-12) 23) 6+-- [-10.0,-5.0,0.0,5.0,10.0,15.0,20.0] newtype Range a = Range' (a,a)   deriving (Eq, Generic)  -- | 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#-} --- | recovering the synonym name instance (Show a) => Show (Range a) where     show (Range a b) = "Range " <> show a <> " " <> show b @@ -77,7 +98,6 @@ instance Show1 Range where     liftShowsPrec sp _ d (Range' (a,b)) = showsBinaryWith sp sp "Range" d a b --- | 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) @@ -130,26 +150,39 @@ half :: (Field a) => a half = one / two +-- | convex hull union+instance (FromInteger a, Ord a, BoundedField a) => AdditiveMagma (Range a) where+    plus (Range l0 u0) (Range l1 u1) = Range (min l0 l1) (max u0 u1) ++instance (FromInteger a, Ord a, BoundedField a) => AdditiveUnital (Range a) where+    zero = Range infinity neginfinity++instance (FromInteger a, Ord a, BoundedField a) => AdditiveAssociative (Range a)++instance (FromInteger a, Ord a, BoundedField a) => AdditiveInvertible (Range a) where+    negate (Range l u) = Range u l++instance (FromInteger a, Ord a, BoundedField a) => AdditiveCommutative (Range a)+instance (FromInteger a, Ord a, BoundedField a) => Additive (Range a)+instance (FromInteger a, Ord a, BoundedField a) => AdditiveGroup (Range a)+ -- | times may well be some sort of affine projection lurking under the hood-instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeMagma (Range a) where+instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeMagma (Range a) where     times a b = Range (m - r/two) (m + r/two)         where           m = mid a + mid b           r = width a * width b --- | The unital object derives from:------ width one = one------ mid zero = zero+-- | The unital object (Range -0.5 0.5) satisfies: ----- ie (-0.5,0.5)-instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeUnital (Range a) where+-- > width one = one+-- > mid zero = zero+instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeUnital (Range a) where     one = Range (negate half) half -instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeAssociative (Range a)+instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeAssociative (Range a) -instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeInvertible (Range a) where+instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeInvertible (Range a) where     recip a = case width a == zero of       True  -> theta       False -> Range (m - r/two) (m + r/two)@@ -157,12 +190,12 @@           m = negate (mid a)           r = recip (width 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 (FromInteger a, Ord a, BoundedField a) => MultiplicativeCommutative (Range a)+instance (FromInteger a, Ord a, BoundedField a) => Multiplicative (Range a)+instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeGroup (Range a) -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))+instance (FromInteger a, AdditiveInvertible a, BoundedField a, Ord 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@@ -174,11 +207,15 @@         | u' < l = l - u'         | otherwise = zero +instance (BoundedField a, Ord a, FromInteger a, Epsilon a) => Epsilon (Range a) where+    nearZero (Range l u) = nearZero (l - u)+    aboutEqual (Range l u) (Range l' u')= aboutEqual l l' && aboutEqual u u'+ -- | theta is a bit like 1/infinity theta :: (AdditiveUnital a) => Range a theta = Range zero zero -instance (Ord a, BoundedField a, FromInteger a) => Space (Range a) where+instance (FromInteger a, Ord a, BoundedField 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@@ -186,7 +223,7 @@     upper (Range _ u) = u     singleton a = Range a a     type Grid (Range a) = Int-    grid :: (FromInteger a) => Pos -> Range a -> Int -> [a]+    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]@@ -230,3 +267,4 @@                 LowerPos -> (0,n' - 1)                 UpperPos -> (1,n')                 MidPos -> (0,n' - 1)+

@@ -1,12 +1,18 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# 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 +-- | a two-dimensional plane, implemented as a composite of a 'Pair' of 'Range's. module NumHask.Rect   ( Rect(..)   , pattern Rect@@ -15,116 +21,225 @@   , projectRect   ) where -import NumHask.Space-import NumHask.Range-import NumHask.Pair-import NumHask.Prelude-import Data.Functor.Compose+import Data.Distributive import Data.Functor.Apply (Apply(..))+import Data.Functor.Compose import Data.Semigroup.Foldable (Foldable1(..))-import Data.Functor.Rep-import Data.Distributive+import Data.Semigroup.Traversable (Traversable1(..))+import NumHask.Pair+import NumHask.Prelude hiding ((<.>), singleton)+import NumHask.Range+import NumHask.Space+import qualified Text.Show as Show+import Test.QuickCheck.Arbitrary (Arbitrary(..)) --- | 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)+-- $setup+-- >>> :set -XNoImplicitPrelude +-- | a 'Pair' of 'Ranges' that form a rectangle in what is often thought of as the XY plane.+--+-- >>> let a = Rect (-1) 1 (-2) 4+-- >>> a+-- Rect -1 1 -2 4+-- >>> let (Ranges x y) = a+-- >>> x+-- Range -1 1+-- >>> y+-- Range -2 4+-- >>> fmap (+1) (Rect 1 2 3 4)+-- Rect 2 3 4 5+-- >>> one :: Rect Double+-- Rect -0.5 0.5 -0.5 0.5+-- >>> zero :: Rect Double+-- Rect Infinity -Infinity Infinity -Infinity+--+-- as a Field instance+--+-- >>> Rect 0 1 2 3 + zero+-- Rect 0.0 1.0 2.0 3.0+-- >>> Rect 0 1 (-2) (-1) + Rect 2 3 (-5) 3+-- Rect 0.0 3.0 -5.0 3.0+-- >>> Rect 1 1 1 1 - one+-- Rect 0.5 1.0 0.5 1.0+-- >>> Rect 0 1 0 1 * one+-- Rect 0.0 1.0 0.0 1.0+-- >>> Rect 0 1 0 1 / one+-- Rect 0.0 1.0 0.0 1.0+-- >>> singleton (Pair 1.0 2.0) :: Rect Double+-- Rect 1.0 1.0 2.0 2.0+-- >>> abs (Rect 1 0 1 0)+-- Rect 0.0 1.0 0.0 1.0+-- >>> sign (Rect 1 0 1 0) == negate one+-- True+--+-- as a Space instance+--+-- >>> project (Rect 0 1 (-1) 0) (Rect 1 4 10 0) (Pair 0.5 1)+-- Pair 2.5 -10.0+-- >>> gridSpace (Rect 0 10 0 1) (Pair 2 2)+-- [Rect 0.0 5.0 0.0 0.5,Rect 0.0 5.0 0.5 1.0,Rect 5.0 10.0 0.0 0.5,Rect 5.0 10.0 0.5 1.0]+-- >>> grid MidPos (Rect 0 10 0 1) (Pair 2 2)+-- [Pair 2.5 0.25,Pair 2.5 0.75,Pair 7.5 0.25,Pair 7.5 0.75]+newtype Rect a =+  Rect' (Compose Pair Range a)+  deriving (Eq, Functor, Apply, Applicative, Foldable, Foldable1, Traversable)++-- | pattern of Rect lowerx upperx lowery uppery 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#-} +-- | pattern of Ranges xrange yrange pattern Ranges :: Range a -> Range a -> Rect a pattern Ranges a b = Rect' (Compose (Pair a b)) {-# COMPLETE Ranges#-} -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 (Show a) => Show (Rect a) where+  show (Rect a b c d) =+    "Rect " <> show a <> " " <> show b <> " " <> show c <> " " <> show d -instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeUnital (Rect a) where-    one = Ranges one one+instance Traversable1 Rect where+  traverse1 f (Rect a b c d) = Rect <$> f a <.> f b <.> f c <.> f d -instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeAssociative (Rect a)+instance (Ord a, BoundedField a, FromInteger a) =>+         AdditiveMagma (Rect a) where+  plus (Ranges x0 y0) (Ranges x1 y1) = Ranges (x0 `plus` x1) (y0 `plus` y1) -instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeCommutative (Rect a)+instance (Ord a, BoundedField a, FromInteger a) =>+         AdditiveUnital (Rect a) where+  zero = Ranges zero zero +instance (Ord a, FromInteger a, BoundedField a) =>+         AdditiveAssociative (Rect a)++instance (Ord a, BoundedField a, FromInteger a) =>+         AdditiveCommutative (Rect a)++instance (Ord a, FromInteger a, BoundedField a) =>+         AdditiveIdempotent (Rect a)++instance (Ord a, BoundedField a, FromInteger a) => Additive (Rect a)++instance (Ord a, FromInteger a, BoundedField a) =>+         AdditiveInvertible (Rect a) where+  negate (Ranges x y) = Ranges (negate x) (negate y)++instance (Ord a, BoundedField a, FromInteger a) =>+         AdditiveGroup (Rect a)++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 (Ord a, BoundedField a, FromInteger a) =>+         MultiplicativeUnital (Rect a) where+  one = Ranges one one++instance (Ord a, FromInteger a, BoundedField a) =>+         MultiplicativeAssociative (Rect a)++instance (Ord a, BoundedField a, FromInteger a) =>+         MultiplicativeCommutative (Rect a)+ instance (Ord a, BoundedField a, FromInteger a) => Multiplicative (Rect a) -instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeInvertible (Rect a) where-    recip (Ranges x y) = Ranges (recip x) (recip y)+instance (Ord a, FromInteger a, BoundedField a) =>+         MultiplicativeInvertible (Rect a) where+  recip (Ranges x y) = Ranges (recip x) (recip y) -instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeGroup (Rect a)+instance (Ord a, BoundedField a, FromInteger a) =>+         MultiplicativeGroup (Rect a) -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)+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)  instance (AdditiveGroup a) => Normed (Rect a) (Pair a) where-    size (Ranges l u) = Pair (size l) (size u)+  size (Ranges l u) = Pair (size l) (size u) +instance (BoundedField a, Ord a, FromInteger a, Epsilon a) => Epsilon (Rect a) where+    nearZero (Ranges a b) = nearZero a && nearZero b+    aboutEqual (Ranges a b) (Ranges a' b')= aboutEqual a a' && aboutEqual b b'+ 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-+    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+  instance Representable Rect where   type Rep Rect = (Bool, Bool)   tabulate f =-      Rect-      (f (False, False))-      (f (False, True))-      (f (True, False))-      (f (True, True))+    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 -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+instance (Signed a, 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 -instance (Ord a, BoundedField a, FromInteger a) => Monoid (Rect a) where-    mempty = nul-    mappend = union+instance (Signed a, Ord a, BoundedField a, FromInteger a) => Monoid (Rect a) where+  mempty = nul+  mappend = union -corners :: (FromInteger a, BoundedField a, Ord a) => Rect a -> [Pair a]+instance (Arbitrary a) => Arbitrary (Rect a) where+    arbitrary = do+        a <- arbitrary+        b <- arbitrary+        pure (Ranges a b)++instance NFData a => NFData (Rect a) where+  rnf (Ranges a b) = rnf a `seq` rnf b++-- | create a list of pairs representing the lower left and upper right cormners of a rectangle.+corners :: (Signed a, 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 :: (FromInteger a, Ord a, BoundedField a) =>-    Rect a -> Rect a -> Rect a -> Rect a-projectRect r0 r1 (Rect a b c d) = Rect a' b' c' d' where+-- | project a Rect from an old range to a new one+projectRect ::+     (Signed a, FromInteger a, Ord a, BoundedField a)+  => Rect a+  -> Rect a+  -> Rect a+  -> Rect a+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)

@@ -1,12 +1,5 @@ {-# 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 )@@ -14,19 +7,21 @@ {-# 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.---}-+-- | A 'Space' represents an abstract continuous range class for a type. The <https://hackage.haskell.org/package/intervals interval> package is an alternative approach. module NumHask.Space   ( Space(..)   , Pos(..)   ) where -import NumHask.Prelude+import NumHask.Prelude hiding (singleton) +-- | space laws+--+-- > a `union` nul == a+-- > a `union` a == a+-- > project o n (lower o) == lower n+-- > project o n (upper o) == upper n+-- > project a a == id class (Eq (Element s), Ord (Element s), Field (Element s)) => Space s where     type Element s :: *     -- | lower boundary of space@@ -58,12 +53,6 @@     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

@@ -2,6 +2,5 @@  packages:   - '.'- extra-deps:-  - numhask-0.0.9+  - numhask-0.1.2

@@ -1,30 +1,44 @@ {-# 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 +import NumHask.Pair import NumHask.Prelude import NumHask.Range+import NumHask.Rect+import NumHask.Space -import Test.Tasty (TestName, TestTree, testGroup, defaultMain, localOption)-import Test.Tasty.QuickCheck import Test.DocTest+import Test.Tasty (TestName, TestTree, defaultMain, testGroup)+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)+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) +data LawArity2 a b+  = Unary2 (a -> Bool)+  | Binary2 (a -> b -> Bool)+  | Ternary2 (a -> a -> b -> Bool)+  | Ternary2' (a -> b -> b -> Bool)+  | Ternary2'' (a -> a -> a -> Bool)+  | Quad31 (a -> a -> a -> b -> Bool)+  | Quad22 (a -> a -> b -> b -> Bool)+  | Failiary2 (a -> Property)+ type Law a = (TestName, LawArity a) -testLawOf  :: (Arbitrary a, Show a) => [a] -> Law a -> TestTree+type Law2 a b = (TestName, LawArity2 a b)++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@@ -32,30 +46,217 @@ testLawOf _ (name, Ornary f) = testProperty name f testLawOf _ (name, Failiary f) = testProperty name f -testRange :: TestTree-testRange = testGroup "Data.Range" $ testLawOf ([]::[Range Double]) <$> rangeLaws+testLawOf2 ::+     (Arbitrary a, Show a, Arbitrary b, Show b)+  => [(a, b)]+  -> Law2 a b+  -> TestTree+testLawOf2 _ (name, Unary2 f) = testProperty name f+testLawOf2 _ (name, Binary2 f) = testProperty name f+testLawOf2 _ (name, Ternary2 f) = testProperty name f+testLawOf2 _ (name, Ternary2' f) = testProperty name f+testLawOf2 _ (name, Ternary2'' f) = testProperty name f+testLawOf2 _ (name, Quad22 f) = testProperty name f+testLawOf2 _ (name, Quad31 f) = testProperty name f+testLawOf2 _ (name, Failiary2 f) = testProperty name f  main :: IO () main = do-    defaultMain $ testGroup "range" [localOption (QuickCheckTests 100) testRange]-    doctest ["src/NumHask/Range.hs"]+  doctest ["src/NumHask/Range.hs", "src/NumHask/Rect.hs", "src/NumHask/Pair.hs"]+  defaultMain $+    testGroup+      "numhask-range"+      [ testGroup "project" $+        testLawOf2 ([] :: [(Range Double, Double)]) <$>+        projectSpaceFuzzyLaws 10.0+      , testGroup "Additive" $+        testLawOf ([] :: [Range Double]) <$> additiveSpaceFuzzyLaws 10.0+      , testGroup "Multiplicative" $+        testLawOf ([] :: [Range Double]) <$> multiplicativeSpaceFuzzyLaws 10.0+      , testGroup "MultiplicativeGroup" $+        testLawOf ([] :: [Range Double]) <$>+        multiplicativeGroupSpaceFuzzyLaws 10.0+      , testGroup "Pair" $+        testLawOf ([] :: [Pair Double]) <$> fieldFuzzyLaws 10.0+      , testGroup "rect project" $+        testLawOf2 ([] :: [(Rect Double, Pair Double)]) <$>+        projectSpaceFuzzyLaws (Pair 10.0 10.0)+      , testGroup "Additive" $+        testLawOf ([] :: [Rect Double]) <$>+        additiveSpaceFuzzyLaws (Pair 10.0 10.0)+      , testGroup "Multiplicative" $+        testLawOf ([] :: [Rect Double]) <$>+        multiplicativeSpaceFuzzyLaws (Pair 10.0 10.0)+      , testGroup "MultiplicativeGroup" $+        testLawOf ([] :: [Rect Double]) <$>+        multiplicativeGroupSpaceFuzzyLaws (Pair 10.0 10.0)+      ] -rangeLaws :: [Law (Range Double)]-rangeLaws =-    [ ("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", 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))-    ]+projectSpaceFuzzyLaws ::+     ( Epsilon (Element s)+     , Signed (Element s)+     , Ord (Element s)+     , Normed s (Element s)+     , Signed s+     , Space s+     , Epsilon s+     , Eq s+     , Multiplicative s+     )+  => Element s+  -> [Law2 s (Element s)]+projectSpaceFuzzyLaws x =+  [ ( "project o n (lower o) ≈ lower n"+    , Ternary2+        (\o n _ ->+           singular o ||+           singular n ||+           x < abs (size o) ||+           x < abs (size n) || project o n (lower o) ≈ lower n))+  , ( "project o n (upper o) ≈ upper n"+    , Ternary2+        (\o n _ ->+           singular o ||+           singular n ||+           x < abs (size o) ||+           x < abs (size n) || project o n (upper o) ≈ upper n))+  , ( "project a a x ≈ x"+    , Ternary2 (\o _ s -> singular o || x < abs (size o) || project o o s ≈ s))+  ] -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 +additiveSpaceFuzzyLaws ::+     ( Epsilon (Element s)+     , Signed (Element s)+     , Ord (Element s)+     , Normed s (Element s)+     , Signed s+     , Space s+     , Epsilon s+     , Eq s+     )+  => Element s+  -> [Law s]+additiveSpaceFuzzyLaws n =+  [ ( "left unital: zero + a ≈ a"+    , Unary (\a -> n < abs (size a) || zero + a ≈ a))+  , ( "right unital: a + zero ≈ a"+    , Unary (\a -> n < abs (size a) || zero + a ≈ a))+  , ( "associative: (a + b) + c ≈ a + (b +c)"+    , Ternary (\a b c -> n < abs (size a) || (a + b) + c ≈ a + (b + c)))+  , ( "commutative a + b ≈ b + a"+    , Binary (\a b -> n < abs (size a) || a + b ≈ b + a))+  , ("idempotent a + a ≈ a", Unary (\a -> n < abs (size a) || a + a ≈ a))+  , ( "idempotent negate a + negate a ≈ abs a"+    , Unary (\a -> n < abs (size a) || a + negate a ≈ abs a))+  ] -zeroRange :: (Eq a) => Range a -> Bool-zeroRange (Range l u) = l==u+multiplicativeSpaceFuzzyLaws ::+     ( Epsilon (Element s)+     , Signed (Element s)+     , Ord (Element s)+     , Normed s (Element s)+     , Signed s+     , Space s+     , Epsilon s+     , Eq s+     , Multiplicative s+     )+  => Element s+  -> [Law s]+multiplicativeSpaceFuzzyLaws n =+  [ ("left unital: one * a ≈ a", Unary (\a -> n < abs (size a) || one * a ≈ a))+  , ("right unital: a * one ≈ a", Unary (\a -> n < abs (size a) || one * a ≈ a))+  , ( "associative: (a * b) * c ≈ a * (b *c)"+    , Ternary+        (\a b c ->+           n < abs (size a) ||+           n < abs (size b) || n < abs (size c) || (a * b) * c ≈ a * (b * c)))+  , ( "commutative a * b ≈ b * a"+    , Binary (\a b -> n < abs (size a) || a * b ≈ b * a))+  ] +multiplicativeGroupSpaceFuzzyLaws ::+     ( Epsilon (Element s)+     , Signed (Element s)+     , Ord (Element s)+     , Normed s (Element s)+     , Signed s+     , Space s+     , Epsilon s+     , Eq s+     , MultiplicativeGroup s+     )+  => Element s+  -> [Law s]+multiplicativeGroupSpaceFuzzyLaws n =+  [ ( "divide: a / a ≈ one"+    , Unary (\a -> singular a || n < abs (size a) || (a / a) ≈ one))+  , ( "recip divide: recip a ≈ one / a"+    , Unary (\a -> singular a || n < abs (size a) || recip a ≈ one / a))+  , ( "recip left: recip a * a ≈ one"+    , Unary (\a -> singular a || n < abs (size a) || recip a * a ≈ one))+  , ( "recip right: a * recip a ≈ one"+    , Unary (\a -> singular a || n < abs (size a) || a * recip a ≈ one))+  ]++fieldFuzzyLaws ::+     ( Signed a+     , Ord a+     , Normed (r a) a+     , Signed (r a)+     , Multiplicative (r a)+     , MultiplicativeGroup (r a)+     , Epsilon (r a)+     , Eq (r a)+     )+  => a+  -> [Law (r a)]+fieldFuzzyLaws n =+  [ ( "left unital: zero + a ≈ a"+    , Unary (\a -> n < abs (size a) || zero + a ≈ a))+  , ( "right unital: a + zero ≈ a"+    , Unary (\a -> n < abs (size a) || zero + a ≈ a))+  , ( "associative: (a + b) + c ≈ a + (b +c)"+    , Ternary (\a b c -> n < abs (size a) || (a + b) + c ≈ a + (b + c)))+  , ( "commutative a + b ≈ b + a"+    , Binary (\a b -> n < abs (size a) || a + b ≈ b + a))+  , ( "minus: a - a ≈ zero"+    , Unary (\a -> nearZero a || n < abs (size a) || (a - a) ≈ zero))+  , ( "negate minus: negate a ≈ zero - a"+    , Unary (\a -> nearZero a || n < abs (size a) || negate a ≈ zero - a))+  , ( "negate left: negate a * a ≈ zero"+    , Unary (\a -> nearZero a || n < abs (size a) || negate a + a ≈ zero))+  , ( "negate right: a * negate a ≈ zero"+    , Unary (\a -> nearZero a || n < abs (size a) || a + negate a ≈ zero))+  , ("left unital: one * a ≈ a", Unary (\a -> n < abs (size a) || one * a ≈ a))+  , ("right unital: a * one ≈ a", Unary (\a -> n < abs (size a) || one * a ≈ a))+  , ( "associative: (a * b) * c ≈ a * (b *c)"+    , Ternary+        (\a b c ->+           n < abs (size a) ||+           n < abs (size b) || n < abs (size c) || (a * b) * c ≈ a * (b * c)))+  , ( "commutative a * b ≈ b * a"+    , Binary (\a b -> n < abs (size a) || a * b ≈ b * a))+  , ( "divide: a / a ≈ one"+    , Unary (\a -> nearZero a || n < abs (size a) || (a / a) ≈ one))+  , ( "recip divide: recip a ≈ one / a"+    , Unary (\a -> nearZero a || n < abs (size a) || recip a ≈ one / a))+  , ( "recip left: recip a * a ≈ one"+    , Unary (\a -> nearZero a || n < abs (size a) || recip a * a ≈ one))+  , ( "recip right: a * recip a ≈ one"+    , Unary (\a -> nearZero a || n < abs (size a) || a * recip a ≈ one))+  , ( "left annihilation: a * zero ≈ zero"+    , Unary (\a -> n < abs (size a) || a * zero ≈ zero))+  , ( "right annihilation: zero * a ≈ zero"+    , Unary (\a -> n < abs (size a) || zero * a ≈ zero))+  , ( "left distributivity: a * (b + c) ≈ a * b + a * c"+    , Ternary+        (\a b c ->+           n < abs (size a) ||+           n < abs (size b) || n < abs (size c) || a * (b + c) ≈ a * b + a * c))+  , ( "right distributivity: (a + b) * c ≈ a * c + b * c"+    , Ternary+        (\a b c ->+           n < abs (size a) ||+           n < abs (size b) || n < abs (size c) || (a + b) * c ≈ a * c + b * c))+  ]