packages feed

numhask-hedgehog (empty) → 0.3

raw patch · 9 files changed

+1233/−0 lines, 9 filesdep +basedep +hedgehogdep +numhasksetup-changed

Dependencies added: base, hedgehog, numhask, numhask-hedgehog, numhask-prelude, numhask-space

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tony Day nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ numhask-hedgehog.cabal view
@@ -0,0 +1,79 @@+name: numhask-hedgehog+version: 0.3+synopsis:+  Laws and tests for numhask+description:+  Laws and tests for numhask.+category:+  mathematics+homepage:+  https://github.com/tonyday567/numhask#readme+bug-reports:+  https://github.com/tonyday567/numhask/issues+author:+  Tony Day+maintainer:+  tonyday567@gmail.com+copyright:+  Tony Day+license:+  BSD3+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  1.18+source-repository head+  type:+    git+  location:+    https://github.com/tonyday567/numhask+  subdir:+    numhask-hedgehog+library+  hs-source-dirs:+    src+  default-extensions:+    NegativeLiterals+    NoImplicitPrelude+    OverloadedStrings+    UnicodeSyntax+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , hedgehog >=0.5 && <1.1+    , numhask >=0.3 && <0.4+    , numhask-space >=0.1.1 && <0.2+    , numhask-prelude >=0.3 && <0.4+  exposed-modules:+    NumHask.Hedgehog+    NumHask.Hedgehog.Gen+    NumHask.Hedgehog.Prop+    NumHask.Hedgehog.Prop.Space+    NumHask.Hedgehog.Props+  default-language: Haskell2010+test-suite test+  type:+    exitcode-stdio-1.0+  main-is:+    test.hs+  hs-source-dirs:+    test+  default-extensions:+    NegativeLiterals+    NoImplicitPrelude+    OverloadedStrings+    UnicodeSyntax+  build-depends:+      base >=4.7 && <5+    , hedgehog >=0.5 && <1.1+    , numhask >=0.3 && <0.4+    , numhask-prelude >=0.3 && <0.4+    , numhask-hedgehog >=0.3 && <0.4+  default-language: Haskell2010
+ src/NumHask/Hedgehog.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wall #-}++module NumHask.Hedgehog+  ( module NumHask.Hedgehog.Gen+  , module NumHask.Hedgehog.Prop+  , module NumHask.Hedgehog.Props+  ) where++import NumHask.Hedgehog.Gen+import NumHask.Hedgehog.Prop+import NumHask.Hedgehog.Props+
+ src/NumHask/Hedgehog/Gen.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Hedgehog.Gen+  ( rational+  , rational_+  , integral+  , integral_+  , uniform+  , negUniform+  , genPair+  , genRange+  , genRangePos+  , genComplex+  ) where++import Hedgehog as H+import NumHask.Prelude as P+import qualified Hedgehog.Internal.Gen as Gen+import qualified Hedgehog.Internal.Seed as Seed+import qualified Hedgehog.Range as Range++-- * hedgehog rng's are Num instances, so we supply a few of our own+-- There are basically two types of random variates: a discrete Integer type and a continuous rational type++-- | a rational-style random variate+rational :: (ToRatio a, FromRatio a, MonadGen m) => Range.Range a -> m a+rational r =+  Gen.generate $ \size seed ->+    let+      (x, y) =+        Range.bounds size r+    in+      fromRational . fst $+        Seed.nextDouble (fromRational x) (fromRational y) seed++-- | an integral-stype random variate+integral :: (ToInteger a, FromInteger a, MonadGen m) => Range.Range a -> m a+integral r =+  Gen.generate $ \size seed ->+    let+      (x, y) =+        Range.bounds size r+    in+      fromIntegral . fst $+        Seed.nextInteger (fromIntegral x) (fromIntegral y) seed++-- | an integral-style random variate utilising Bounds+integral_ ::+  ( Additive a+  , Bounded a+  , ToInteger a+  , FromInteger a+  , MonadGen m)+  => m a+integral_ = integral (Range.constantFrom zero minBound maxBound)++-- | a rational style random variate utilising Bounds+rational_ ::+  ( Additive a+  , Bounded a+  , ToRatio a+  , FromRatio a+  , MonadGen m)+  => m a+rational_ = rational (Range.constantFrom zero minBound maxBound)++-- | a uniform distribution between zero and one+uniform ::+  ( Field a+  , ToRatio a+  , FromRatio a+  , MonadGen m)+  => m a+uniform = rational (Range.constantFrom zero zero one)++-- | a uniform distribution between -1 and 1+negUniform ::+  ( Field a+  , ToRatio a+  , FromRatio a+  , Subtractive a+  , MonadGen m)+  => m a+negUniform = rational (Range.constantFrom zero (negate one) one)++-- | a complex random variate+genComplex :: Monad m => m a -> m (Complex a)+genComplex g = do+  r <- g+  i <- g+  pure (r :+ i)++-- | Space+genRange :: forall a m. (JoinSemiLattice a, MeetSemiLattice a, MonadGen m) => m a -> m (P.Range a)+genRange g = do+  a <- g+  b <- g+  pure (a >.< b)++genRangePos :: forall a m. (JoinSemiLattice a, MeetSemiLattice a, MonadGen m) => m a -> m (P.Range a)+genRangePos g = do+  a <- g+  b <- g+  pure (a ... b)++-- | a pair+genPair :: (Monad m) => m a -> m (Pair a)+genPair g = do+  a <- g+  b <- g+  pure (Pair a b)
+ src/NumHask/Hedgehog/Prop.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Hedgehog.Prop where++import Hedgehog as H+import NumHask.Prelude hiding ((%))++-- | running tests in parallel+assertProps+  :: H.GroupName+  -> H.TestLimit+  -> H.Gen a+  -> (H.Gen a -> [(H.PropertyName, H.Property)])+  -> IO Bool+assertProps t n g ps =+  H.checkParallel $+  H.Group t $ (\(pn,pp) -> (pn, H.withTests n pp)) <$> ps g++-- | run tests sequentially+assertPropsSeq+  :: H.GroupName+  -> H.TestLimit+  -> H.Gen a+  -> (H.Gen a -> [(H.PropertyName, H.Property)])+  -> IO Bool+assertPropsSeq t n g ps =+  H.checkSequential $+  H.Group t $ (\(pn,pp) -> (pn, H.withTests n pp)) <$> ps g++-- * Combinators+-- These combinators seem neat, but hedgehog UI requires check fails to be closer to the source.+-- better to thus ignore the redundant code warnings.+--+-- with usage:+--       ┏━━ numhask-hedgehog/src/NumHask/Hedgehog/Prop.hs ━━━+--    12 ┃ unary :: (Show a) => Gen a -> (a -> Bool) -> Property+--    13 ┃ unary src p = property $ do+--    14 ┃   a <- forAll src+--       ┃   │ EmptyInterval+--    15 ┃   assert (p a)+--       ┃   ^^^^^^^^^^^^+--+-- with redundant code snippets:+--       ┏━━ numhask-hedgehog/src/NumHask/Hedgehog/Prop.hs ━━━+--    60 ┃ isUnital :: (Eq a, Show a) => a -> (a -> a -> a) -> Gen a -> Property+--    61 ┃ isUnital z (#) src = property $ do+--    62 ┃   rv <- forAll src+--       ┃   │ EmptyInterval+--    63 ┃   let p a = (z # a) == a && (a # z) == a+--    64 ┃   assert (p rv)+--       ┃   ^^^^^^^^^^^^^+-- ++-- | Combinator for a property of involving a single element+unary :: (Show a) => Gen a -> (a -> Bool) -> Property+unary src p = property $ do+  a <- forAll src+  assert (p a)++-- | Combinator for a property involving two elements+binary :: (Show a) => Gen a -> (a -> a -> Bool) -> Property+binary src p = property $ do+  a <- forAll src+  b <- forAll src+  assert (p a b)++-- | Combinator for a property involving three elements+ternary :: (Show a) => Gen a -> (a -> a -> a -> Bool) -> Property+ternary src p = property $ do+  a <- forAll src+  b <- forAll src+  c <- forAll src+  assert (p a b c)++isIdempotent :: (Eq a, Show a) =>+  (a -> a -> a) -> Gen a -> Property+isIdempotent (#) src = property $ do+  rv <- forAll src+  let p = \a -> (a # a) == a+  assert (p rv)++isCommutative :: (Eq a, Show a) =>+  (a -> a -> a) -> Gen a -> Property+isCommutative (#) src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b -> (a # b) == (b # a)+  assert (p rv rv')++isUnital :: (Eq a, Show a) => a -> (a -> a -> a) -> Gen a -> Property+isUnital z (#) src = property $ do+  rv <- forAll src+  let p = \a -> (z # a) == a && (a # z) == a+  assert (p rv)++isAssociative :: (Eq a, Show a) => (a -> a -> a) -> Gen a -> Property+isAssociative (#) src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c -> (a # b) # c == a # (b # c)+  assert (p rv rv' rv'')++isAdditive :: (Eq a, Show a, Additive a) => Gen a -> [(PropertyName, Property)]+isAdditive src =+  [ ("zero", isUnital zero (+) src)+  , ("associative +", isAssociative (+) src)+  , ("commutative +", isCommutative (+) src)+  ]++isGroup :: (Eq a, Show a) => a -> (a -> a -> a) -> (a -> a -> a) -> (a -> a) ->+  Gen a -> Property+isGroup u (#) (%) i src = property $ do+  rv <- forAll src+  let p = \a ->+        (a % a) == u &&+        (i a == u % a) &&+        (i a # a) == u &&+        (a # i a) == u+  assert (p rv)++isSubtractive :: (Eq a, Show a, Subtractive a) => Gen a -> [(PropertyName, Property)]+isSubtractive src =+  [ ("subtractive -", isGroup zero (+) (-) negate src)+  ]++isMultiplicative :: (Eq a, Show a, Multiplicative a) => Gen a -> [(PropertyName, Property)]+isMultiplicative src =+  [ ("one", isUnital one (*) src)+  , ("associative *", isAssociative (*) src)+  , ("commutative *", isCommutative (*) src)+  ]++isDivisive :: (Eq a, Show a, Divisive a) => Gen a -> [(PropertyName, Property)]+isDivisive src =+  [ ("divisive /", isGroup one (*) (/) recip src)+  ]++isDistributive :: (Eq a, Show a) => a -> (a -> a -> a) -> (a -> a -> a) ->+  Gen a -> Property+isDistributive u (#) (%) src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        a % u == u &&+        u % a == u &&+        a % (b # c) == (a % b) # (a % c) &&+        (a # b) % c == (a % c) # (b % c)+  assert (p rv rv' rv'')++isAbsorbativeUnit :: (Eq a, Show a) => a -> (a -> a -> a) -> Gen a -> Property+isAbsorbativeUnit u (#) src = property $ do+  rv <- forAll src+  let p = \a ->+        (a # u) == u &&+        (u # a) == u+  assert (p rv)++isAbsorbative :: (Eq a, Show a) => (a -> a -> a) -> (a -> a -> a) -> Gen a -> Property+isAbsorbative (#) (%) src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        (a # (a % b)) == (a % (a # b)) &&+        a == (a % (a # b))+  assert (p rv rv')++isIntegral :: (Eq a, Show a, Integral a) => Gen a -> Property+isIntegral src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        b == zero ||+        b * (a `div` b) + (a `mod` b) == a+  assert (p rv rv')++isFromIntegral :: (Eq a, Show a, FromInteger a, ToInteger a) => Gen a -> Property+isFromIntegral src = property $ do+  rv <- forAll src+  let p = \a -> fromIntegral a == a+  assert (p rv)++isRational :: (Eq a, Show a, FromRatio a, ToRatio a) => Gen a -> Property+isRational src = property $ do+  rv <- forAll src+  let p = \a ->+        fromRational a == a+  assert (p rv)++isSigned :: (Eq a, Show a, Signed a) => Gen a -> Property+isSigned src = property $ do+  rv <- forAll src+  let p = \a ->+        sign a * abs a == a+  assert (p rv)++isNormed :: forall a b. (JoinSemiLattice b, Show a, Normed a b)+  => [b] -> Gen a -> Property+isNormed _ src = property $ do+  rv <- forAll src+  let p = \a ->+        (normL1 a `joinLeq` (zero :: b)) &&+        normL1 (zero :: a) == (zero :: b)+  assert (p rv)++isNormedBounded :: forall a. (JoinSemiLattice a, Bounded a, Show a, Normed a a)+  => Gen a -> Property+isNormedBounded src = property $ do+  rv <- forAll src+  let p = \a ->+        a == minBound ||+        normL1 a `joinLeq` (zero :: a) &&+        normL1 (zero :: a) == (zero :: a)+  assert (p rv)++isNormedUnbounded :: forall a. (JoinSemiLattice a, Show a, Normed a a) => Gen a -> Property+isNormedUnbounded src = property $ do+  rv <- forAll src+  let p = \a ->+        (normL1 a `joinLeq` (zero :: a)) &&+        normL1 (zero :: a) == (zero :: a)+  assert (p rv)++isMetricBounded :: forall a. (JoinSemiLattice a, Bounded a, Additive a, Show a, Metric a a) => Gen a -> Property+isMetricBounded src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        distanceL1 a b `joinLeq` (zero :: a) &&+        distanceL1 a a == (zero :: a) ||+        distanceL1 a b == (minBound :: a)+  assert (p rv rv')++isMetricUnbounded :: forall a. (JoinSemiLattice a, Additive a, Show a, Metric a a) => Gen a -> Property+isMetricUnbounded src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        distanceL1 a b `joinLeq` (zero :: a) &&+        distanceL1 a a == (zero :: a) &&+        ((distanceL1 a c + distanceL1 b c) `joinLeq` (distanceL1 a b :: a)) &&+        ((distanceL1 a b + distanceL1 b c) `joinLeq` (distanceL1 a c :: a)) &&+        ((distanceL1 a b + distanceL1 a c) `joinLeq` (distanceL1 b c :: a))+  assert (p rv rv' rv'')++isUpperBoundedField :: forall a. (Eq a, UpperBoundedField a, Show a) => Gen a -> Property+isUpperBoundedField src = property $ do+  rv <- forAll src+  let p = \a ->+        ((one :: a) / zero + infinity == infinity) &&+        (infinity + a == infinity) &&+        ((zero :: a) / zero /= nan)+  assert (p rv)++isLowerBoundedField :: forall a. (Eq a, LowerBoundedField a, Show a) => Gen a -> Property+isLowerBoundedField src = property $ do+  rv <- forAll src+  let p = \a ->+        (negate (one :: a) / zero == negInfinity) &&+        ((negInfinity :: a) + negInfinity == negInfinity) &&+        (negInfinity + a == negInfinity)+  assert (p rv)++-- > a - one < floor a <= a <= ceiling a < a + one+-- > round a == floor (a + one/(one+one))+--+isQuotientIntegerField :: forall a. (JoinSemiLattice a, FromInteger a, QuotientField a Integer, Show a) => Gen a -> Property+isQuotientIntegerField src = property $ do+  rv <- forAll src+  let p = \a ->+        ((a - one) ~< fromInteger (floor a)) &&+        (fromInteger (floor a) ~<= a) &&+        (a ~<= fromInteger (ceiling a)) &&+        (fromInteger (ceiling a) ~< a + one) &&+        (case even ((floor $ a + one / (one + one)) :: Integer) of+           True -> (round a :: Integer) == floor (a + (one / (one + one)))+           False -> (round a :: Integer) == ceiling (a - (one / (one + one))))+  assert (p rv)+  where+    (~<) a b = joinLeq b a && not (a == b)+    (~<=) = flip joinLeq++-- > sqrt . (**(one+one)) == id+-- > log . exp == id+-- > for +ive b, a != 0,1: a ** logBase a b == b+isExpField :: forall a. (Ord a, Epsilon a, ExpField a, Show a, Normed a a) => Gen a -> Property+isExpField src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        (not (a > (zero :: a))+         || ((sqrt . (** (one + one)) $ a) == a)+         && (((** (one + one)) . sqrt $ a) == a)) &&+        (not (a > (zero :: a))+         || ((log . exp $ a) == a)+         && ((exp . log $ a) == a)) &&+        (not (normL1 b > (zero :: a))+         || not (nearZero (a - zero))+         || (a == one)+         || (a == zero && nearZero (logBase a b))+         || (a ** logBase a b == b))+  assert (p rv rv')++isSemiring :: (Eq a, Show a, Distributive a) => Gen a -> [(PropertyName, Property)]+isSemiring src =+  [ ("zero", isUnital zero (+) src)+  , ("associative +", isAssociative (+) src)+  , ("commutative +", isCommutative (+) src)+  , ("distributive", isDistributive zero (+) (*) src)+  , ("one", isUnital one (*) src)+  , ("associative *", isAssociative (*) src)  ]++isRing :: (Eq a, Show a, Distributive a, Subtractive a) => Gen a -> [(PropertyName, Property)]+isRing src =+  isSemiring src <> isSubtractive src++isStarSemiring :: (Eq a, Show a, StarSemiring a) => Gen a -> Property+isStarSemiring src = property $ do+  rv <- forAll src+  let p = \a ->+        star a == one + a * star a+  assert (p rv)++isInvolutive :: forall a. (Eq a, Show a, InvolutiveRing a) => Gen a -> Property+isInvolutive src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        adj (a + b) == adj a + adj b &&+        adj (a * b) == adj b * adj a &&+        adj (one :: a) == (one :: a) &&+        adj (adj a) == a+  assert (p rv rv')+
+ src/NumHask/Hedgehog/Prop/Space.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Hedgehog.Prop.Space where++import NumHask.Prelude hiding ((%), (.*.))+import Hedgehog as H hiding (Range)++type CanMeasure a = (Lattice a, Multiplicative a, Show a, Epsilon a)+ +-- * individual tests+isIdempotent :: forall a. (CanMeasure a) =>+  (Range a -> Range a -> Range a) -> a -> Gen a -> Property+isIdempotent (##) acc src = property $ do+  rv <- forAll src+  let p = \a ->+        a |.| (eps acc a ## eps acc a :: Range a)+  assert (p rv)++isCommutative :: forall a. (CanMeasure a) =>+  (a -> a -> a) -> (Range a -> Range a -> Range a) -> a -> Gen a -> Property+isCommutative (#) (##) acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        (a # b) |.| eps acc b ## eps acc a+  assert (p rv rv')++isUnital :: forall a. (CanMeasure a) =>+  a -> (a -> a -> a) -> a -> Gen a -> Property+isUnital u (#) acc src = property $ do+  rv <- forAll src+  let p = \a ->+        (u # a) |.| (eps acc a :: Range a) &&+        (a # u) |.| (eps acc a :: Range a)+  assert (p rv)++isAssociative :: forall a. (CanMeasure a) =>+  (a -> a -> a) -> (Range a -> Range a -> Range a) -> a -> Gen a -> Property+isAssociative (#) (##) acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        ((a # b) # c) |.| (eps acc a ## (eps acc b ## eps acc c))+  assert (p rv rv' rv'')++isAdditive :: forall a. (CanMeasure a) =>+  a -> Gen a -> [(PropertyName, Property)]+isAdditive acc src =+  [ ("zero", isUnital zero (+) acc src)+  , ("associative +", isAssociative (+) (+) acc src)+  , ("commutative +", isCommutative (+) (+) acc src)+  ]++isSubtractive :: forall a. (CanMeasure a) =>+  a -> Gen a -> Property+isSubtractive acc src = property $ do+  rv <- forAll src+  let p = \a -> +        (a - a) |.| (eps acc zero :: Range a) &&+        (negate a |.| (eps acc zero - (eps acc a :: Range a))) &&+        (negate a + a) |.| (eps acc zero :: Range a) &&+        (a + negate a) |.| (eps acc zero :: Range a)+  assert (p rv)++isMultiplicative :: forall a. (CanMeasure a) =>+  a -> Gen a -> [(PropertyName, Property)]+isMultiplicative acc src =+  [ ("one", isUnital one (*) acc src)+  , ("associative *", isAssociative (*) (*) acc src)+  , ("commutative *", isCommutative (*) (*) acc src)+  ]++isDivisive :: forall a. (CanMeasure a, BoundedLattice a, Divisive a) =>+  a -> Gen a -> Property+isDivisive acc src = property $ do+  rv <- forAll src+  let p = \a ->+        (a / a) |.| (eps acc one :: Range a) &&+        (recip a |.| (eps acc one / (eps acc a :: Range a))) &&+        (recip a * a) |.| (eps acc one :: Range a) &&+        (a * recip a) |.| (eps acc one :: Range a)+  assert (p rv)++isDistributiveTimesPlus :: forall a. (CanMeasure a) =>+  a -> Gen a -> Property+isDistributiveTimesPlus acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        (a * (b + c)) |.| ((a .*. b) + (a .*. c)) &&+        ((a + b) * c) |.| ((a .*. c) + (b .*. c))+  assert (p rv rv' rv'')+    where+      (.*.) x y = eps acc x * eps acc y :: Range a++isDistributiveJoinMeet :: forall a. (CanMeasure a) =>+  a -> Gen a -> Property+isDistributiveJoinMeet acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        (a \/ (b /\ c)) |.| ((a .\/. b) /\ (a .\/. c)) &&+        ((a /\ b) \/ c) |.| ((a .\/. c) /\ (b .\/. c))+  assert (p rv rv' rv'')+    where+      (.\/.) x y = eps acc x \/ eps acc y :: Range a++isZeroAbsorbative :: forall a. (CanMeasure a) =>+  (a -> a -> a) -> a -> Gen a -> Property+isZeroAbsorbative (#) acc src = property $ do+  rv <- forAll src+  let p = \a ->+        (a # zero) |.| (eps acc zero :: Range a) &&+        (zero # a) |.| (eps acc zero :: Range a)+  assert (p rv)++isAbsorbative :: forall a. (CanMeasure a) =>+  (a -> a -> a) -> (a -> a -> a) ->+  (Range a -> Range a -> Range a) -> (Range a -> Range a -> Range a) ->+  a -> Gen a -> Property+isAbsorbative (#) (%) (##) (%%) acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        (a # (a % b)) |.| (eps acc a %% (eps acc a ## eps acc b)) &&+        a |.| (eps acc a %% (eps acc a ## eps acc b :: Range a))+  assert (p rv rv')++isSigned :: forall a. (CanMeasure a, Signed a) => a -> Gen a -> Property+isSigned acc src = property $ do+  rv <- forAll src+  let p = \a ->+        (sign a * abs a) |.| (eps acc a :: Range a)+  assert (p rv)++isNormedUnbounded :: forall a. (CanMeasure a, Normed a a) =>+  a -> Gen a -> Property+isNormedUnbounded acc src = property $ do+  rv <- forAll src+  let p = \a ->+        (normL1 a `joinLeq` (zero :: a)) &&+        (normL1 (zero :: a) :: a) |.| (eps acc zero :: Range a)+  assert (p rv)++isMetricUnbounded :: forall a. (CanMeasure a, Metric a a) =>+  a -> Gen a -> Property+isMetricUnbounded acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        singleton (distanceL1 a b) |>| (eps acc zero :: Range a) ||+        distanceL1 a b |.| (eps acc zero  :: Range a) &&+        distanceL1 a a |.| (eps acc zero :: Range a) &&+        ((eps acc zero :: Range a)+         |<| singleton (distanceL1 a c + distanceL1 b c - distanceL1 a b)) &&+        (eps acc zero :: Range a)+        |<| singleton (distanceL1 a b + distanceL1 b c - distanceL1 a c) &&+        (eps acc zero :: Range a)+        |<| singleton (distanceL1 a b + distanceL1 a c - distanceL1 b c)+  assert (p rv rv' rv'')++isExpField :: forall a. (CanMeasure a, ExpField a, Signed a) =>+  a -> Gen a -> Property+isExpField acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        (not ((eps acc zero :: Range a) |<| singleton a)+         || ((sqrt . (** (one + one)) $ a) |.| (eps acc a :: Range a))+         && (((** (one + one)) . sqrt $ a) |.| (eps acc a :: Range a))) &&+        (not ((eps acc zero :: Range a) |<| singleton a)+         || ((log . exp $ a) |.| (eps acc a :: Range a))+         && ((exp . log $ a) |.| (eps acc a :: Range a))) &&+        (not ((eps acc zero :: Range a) |<| singleton (abs b))+         || not (nearZero (a - zero))+         || (a |.| (eps acc one :: Range a))+         || (a |.| (eps acc zero :: Range a) &&+            nearZero (logBase a b))+         || (a ** logBase a b |.| (eps acc b :: Range a)))+  assert (p rv rv')++isCommutativeSpace :: forall s. (Epsilon (Element s), Multiplicative (Element s), Show s, Space s) =>+  (s -> s -> s) -> Element s -> Gen s -> Property+isCommutativeSpace (#) acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        (widenEps acc b # widenEps acc a) `contains` (a # b)+  assert (p rv rv')++isAssociativeSpace :: forall s. (Epsilon (Element s), Multiplicative (Element s), Show s, Space s) =>+  (s -> s -> s) -> Element s -> Gen s -> Property+isAssociativeSpace (#) acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  rv'' <- forAll src+  let p = \a b c ->+        ((widenEps acc a # widenEps acc b) # widenEps acc c) `contains`+        (a # (b # c))+  assert (p rv rv' rv'')++isUnitalSpace :: forall s. (Epsilon (Element s), Multiplicative (Element s), Show s, Space s) =>+  s -> (s -> s -> s) -> Element s -> Gen s -> Property+isUnitalSpace u (#) acc src = property $ do+  rv <- forAll src+  let p = \a ->+        (widenEps acc u # widenEps acc a) `contains` a &&+        (widenEps acc a # widenEps acc u) `contains` a+  assert (p rv)++isLatticeSpace :: forall s. (Show s, Space s) =>+  Gen s -> Property+isLatticeSpace src = property $ do+  rv <- norm <$> forAll src+  let p = \a ->+        lower a \/ upper a == lower a &&+        lower a /\ upper a == upper a+  assert (p rv)++-- 'zero |.| a - a' not 'zero = a - a'+isSubtractiveSpace :: forall s. (Space s, Subtractive s, Eq s, CanMeasure (Element s), Show s) =>+  Gen s -> Property+isSubtractiveSpace src = property $ do+  rv <- forAll src+  let p = \a ->+        (zero |.| (a - a)) &&+        (negate a == zero - a) &&+        (zero |.| (negate a + a))+  assert (p rv) ++-- 'one |.| a / a' not 'one = a / a'+isDivisiveSpace :: forall s. (Space s, Divisive s, Eq s, CanMeasure (Element s)+                       , Show s) =>+  Gen s -> Property+isDivisiveSpace src = property $ do+  rv <- forAll src+  let p = \a ->+        (one |.| (a / a)) &&+        (recip a == one / a) &&+        (one |.| (recip a * a))+  assert (p rv)++isContainedUnion :: forall s. (Epsilon (Element s), Multiplicative (Element s), Show s, Space s) =>+  Element s -> Gen s -> Property+isContainedUnion acc src = property $ do+  rv <- norm <$> forAll src+  rv' <- norm <$> forAll src+  let p = \a b ->+        (widenEps acc a `union` widenEps acc b) `contains` a &&+        (widenEps acc a `union` widenEps acc b) `contains` b+  assert (p rv rv')++isProjectiveLower :: forall s. (FieldSpace s, Epsilon (Element s), Show s) =>+  Element s -> Gen s -> Property+isProjectiveLower acc src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        lower b |.| (eps acc (project a b (lower a)) :: NumHask.Prelude.Range (Element s))+  assert (p rv rv')++isProjectiveUpper :: forall s. (FieldSpace s, Epsilon (Element s), Show s) =>+  Gen s -> Property+isProjectiveUpper src = property $ do+  rv <- forAll src+  rv' <- forAll src+  let p = \a b ->+        upper b |.| ((project a b (upper a) +/- epsilon) :: NumHask.Prelude.Range (Element s))+  assert (p rv rv')+
+ src/NumHask/Hedgehog/Props.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -Wall #-}++module NumHask.Hedgehog.Props where++import Hedgehog as H hiding (Range)+import NumHask.Hedgehog.Prop+import NumHask.Prelude hiding (isSigned)+import qualified NumHask.Hedgehog.Prop.Space as S++-- * properties/law groupings+integralProps+  :: forall a.+  ( Show a+  , Distributive a+  , Subtractive a+  , Integral a+  , FromInteger a+  , ToInteger a+  , Signed a+  , Bounded a+  , Normed a a+  , Metric a a+  , JoinSemiLattice a+  )+  => Gen a+  -> [(PropertyName, Property)]+integralProps g = mconcat $+  (\x -> x g) <$>+  [ isAdditive+  , isSubtractive+  , isMultiplicative+  , \x -> [("distributive", isDistributive zero (+) (*) x)]+  , \x -> [("absorbative zero", isAbsorbativeUnit zero (*) x)]+  , \x -> [("integral", isIntegral x)]+  , \x -> [("fromIntegral", isFromIntegral x)]+  , \x -> [("signed", isSigned x)]+  , \x -> [("normed", isNormedBounded x)]+  , \x -> [("metric", isMetricBounded x)]+  ]++integralUnboundedProps+  :: forall a.+  ( Show a+  , Distributive a+  , Subtractive a+  , Integral a+  , FromInteger a+  , ToInteger a+  , Signed a+  , Normed a a+  , Metric a a+  , JoinSemiLattice a+  )+  => Gen a+  -> [(PropertyName, Property)]+integralUnboundedProps g = mconcat $+  (\x -> x g) <$>+  [ isAdditive+  , isSubtractive+  , isMultiplicative+  , \x -> [("distributive", isDistributive zero (+) (*) x)]+  , \x -> [("absorbative zero", isAbsorbativeUnit zero (*) x)]+  , \x -> [("integral", isIntegral x)]+  , \x -> [("fromIntegral", isFromIntegral x)]+  , \x -> [("signed", isSigned x)]+  , \x -> [("normed", isNormedUnbounded x)]+  , \x -> [("metric", isMetricUnbounded x)]+  ]++naturalProps+  :: forall a.+  ( Show a+  , Distributive a+  , Integral a+  , FromInteger a+  , ToInteger a+  , Signed a+  , Normed a a+  , JoinSemiLattice a+  )+  => Gen a+  -> [(PropertyName, Property)]+naturalProps g = mconcat $+  (\x -> x g) <$>+  [ isAdditive+  , isMultiplicative+  , \x -> [("distributive", isDistributive zero (+) (*) x)]+  , \x -> [("absorbative zero", isAbsorbativeUnit zero (*) x)]+  , \x -> [("integral", isIntegral x)]+  , \x -> [("fromIntegral", isFromIntegral x)]+  , \x -> [("signed", isSigned x)]+  , \x -> [("normed", isNormedUnbounded x)]+  ]++boolProps+  :: forall a.+  ( Show a+  , Ord a+  , Distributive a+  )+  => Gen a+  -> [(PropertyName, Property)]+boolProps g = mconcat $+  (\x -> x g) <$>+  [ isAdditive+  , isMultiplicative+  , \x -> [("idempotent +", isIdempotent (+) x)]+  , \x -> [("idempotent *", isIdempotent (*) x)]+  , \x -> [("distributive", isDistributive zero (+) (*) x)]+  , \x -> [("absorbative unit", isAbsorbativeUnit zero (*) x)]+  , \x -> [("absorbative", isAbsorbative (+) (*) x)]+  ]++rationalProps+  :: forall a.+  ( Show a+  , Ord a+  , Distributive a+  , Subtractive a+  , Divisive a+  , FromRatio a+  , ToRatio a+  , Signed a+  , Normed a a+  , Metric a a+  , JoinSemiLattice a+  )+  => Gen a+  -> [(PropertyName, Property)]+rationalProps g = mconcat $+  (\x -> x g) <$>+  [ isAdditive+  , isSubtractive+  , isMultiplicative+  , \x -> [("distributive", isDistributive zero (+) (*) x)]+  , \x -> [("absorbative unit", isAbsorbativeUnit zero (*) x)]+  , isDivisive+  , \x -> [("rational", isRational x)]+  , \x -> [("signed", isSigned x)]+  , \x -> [("normed", isNormedUnbounded x)]+  , \x -> [("metric", isMetricUnbounded x)]+  ]++-- | field laws+fieldProps+  :: forall a.+  ( S.CanMeasure a+  , BoundedLattice a+  , LowerBoundedField a+  , UpperBoundedField a+  , Signed a+  , Normed a a+  , Metric a a+  )+  => Gen a+  -> [(PropertyName, Property)]+fieldProps g = mconcat $+  (\x -> x g) <$>+  [ S.isAdditive one+  , \x -> [("subtractive", S.isSubtractive one x)]+  , S.isMultiplicative one+  , \x -> [("distributive", S.isDistributiveTimesPlus one x)]+  , \x -> [("absorbative", S.isZeroAbsorbative (*) one x)]+  , \x -> [("divisive", S.isDivisive one x)]+  , \x -> [("signed", S.isSigned one x)]+  , \x -> [("normed", S.isNormedUnbounded one x)]+  , \x -> [("metric", S.isMetricUnbounded one x)]+  , \x -> [("upper bounded field", isUpperBoundedField x)]+  , \x -> [("lower bounded field", isLowerBoundedField x)]+  -- FixMe: unstable test at any tolerance+  -- , \x -> [("expField", S.isExpField 100.0 x)]+  ]++-- | quotient field laws+quotientFieldProps+  :: forall a.+  ( S.CanMeasure a+  , FromInteger a+  , QuotientField a Integer+  )+  => Gen a+  -> [(PropertyName, Property)]+quotientFieldProps g = mconcat $+  (\x -> x g) <$>+  [ \x -> [("quotient field", isQuotientIntegerField x)]+  ]++complexFieldProps+  :: forall a.+  ( S.CanMeasure (Complex a)+  , Epsilon a+  , BoundedLattice (Complex a)+  , Divisive a+  , FromRatio a+  )+  => Complex a+  -> Gen (Complex a)+  -> [(PropertyName, Property)]+complexFieldProps acc g = mconcat $+  (\x -> x g) <$>+  [ S.isAdditive acc+  , \x -> [("subtractive", S.isSubtractive acc x)]+  , S.isMultiplicative acc+  , \x -> [("distributive", S.isDistributiveTimesPlus acc x)]+  , \x -> [("absorbative", S.isZeroAbsorbative (*) acc x)]+  , \x -> [("divisive", S.isDivisive (100.0 :+ 50.0) x)]+  ]++-- | field laws+logFieldProps+  :: forall a.+  ( S.CanMeasure a+  , BoundedLattice a+  , Divisive a+  )+  => Gen a+  -> [(PropertyName, Property)]+logFieldProps g = mconcat $+  (\x -> x g) <$>+  [ S.isAdditive one+  , S.isMultiplicative one+  , \x -> [("distributive", S.isDistributiveTimesPlus one x)]+  , \x -> [("absorbative", S.isZeroAbsorbative (*) one x)]+  , \x -> [("divisive", S.isDivisive one x)]+  ]++-- | lattice laws+latticeProps+  :: forall a.+  ( S.CanMeasure a+  )+  => Gen a+  -> [(PropertyName, Property)]+latticeProps g = mconcat $+  (\x -> x g) <$>+  [ \x -> [("join idem", S.isIdempotent (\/) one x)]+  , \x -> [("meet idem", S.isIdempotent (/\) one x)]+  , \x -> [("join comm", S.isCommutative (\/) (\/) one x)]+  , \x -> [("meet comm", S.isCommutative (/\) (/\) one x)]+  , \x -> [("join assoc", S.isAssociative (\/) (\/) one x)]+  , \x -> [("meet assoc", S.isAssociative (/\) (/\) one x)]+  , \x -> [("lattice distributive", S.isDistributiveJoinMeet one x)]+  , \x -> [("lattice absorb", S.isAbsorbative (\/) (/\) (\/) (/\) one x)]+  ]++-- | space laws+spaceProps+  :: forall s.+  ( Show s+  , Space s+  , Monoid s+  , Eq s+  , Epsilon (Element s)+  , LowerBoundedField (Element s)+  , UpperBoundedField (Element s)+  , BoundedJoinSemiLattice (Element s)+  , BoundedMeetSemiLattice (Element s)+  )+  => Gen s+  -> [(PropertyName, Property)]+spaceProps g = mconcat $+  (\x -> x g) <$>+  [ \x -> [("commutative union", isCommutative union x)]+  , \x -> [("commutative intersection", isCommutative intersection x)]+  , \x -> [("associative union", isAssociative union x)]+  , \x -> [("associative intersection", isAssociative intersection x)]+  , \x -> [("unital union", isUnital (infinity >.< negInfinity) union x)]+  , \x -> [("unital union", isUnital mempty mappend x)]+  , \x -> [("unital intersection", isUnital whole intersection x)]+  , \x -> [("distributive", isDistributive (infinity >.< negInfinity) union intersection x)]+  , \x -> [("distributive", isDistributive whole intersection union x)]+  , \x -> [("containment", S.isContainedUnion one x)]+  , \x -> [("positive space", S.isLatticeSpace x)]+  ]++-- | space laws+fieldSpaceProps+  :: forall s.+  ( Show s+  , FieldSpace s+  , Epsilon (Element s)+  )+  => Gen s+  -> [(PropertyName, Property)]+fieldSpaceProps g = mconcat $+  (\x -> x g) <$>+  [ \x -> [("projective upper preserved", S.isProjectiveUpper x)]+  , \x -> [("projective lower preserved", S.isProjectiveLower two x)]+  ]++-- | Interval algebra is not distributive+spaceAlgebraProps+  :: forall s.+  ( Eq s+  , Show s+  , Space s+  , Subtractive s+  , Divisive s+  , S.CanMeasure (Element s)+  )+  => Gen s+  -> [(PropertyName, Property)]+spaceAlgebraProps g = mconcat $+  (\x -> x g) <$>+  [ \x -> [("commutative (+))", S.isCommutativeSpace (+) one x)]+  , \x -> [("associative (+))", S.isAssociativeSpace (+) one x)]+  , \x -> [("unital (+))", S.isUnitalSpace zero (+) one x)]+  , \x -> [("subtractive space laws with zero |.| a - a", S.isSubtractiveSpace x)]+  , \x -> [("commutative (*))", S.isCommutativeSpace (*) one x)]+  , \x -> [("associative (*))", S.isAssociativeSpace (*) one x)]+  , \x -> [("unital (*))", S.isUnitalSpace one (*) one x)]+  , \x -> [("divisive space laws with one |.| a / a", S.isDivisiveSpace x)]+  ]
+ test/test.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import NumHask.Hedgehog+import NumHask.Prelude+import qualified Hedgehog as H+import qualified Hedgehog.Internal.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Prelude as P++asserts :: H.TestLimit -> [IO Bool]+asserts n =+  [ assertProps "Int" n (integral_ :: H.Gen Int) integralProps+  , assertProps "Int8" n+    (integral_ :: H.Gen Int8) integralProps+  , assertProps "Word8" n+    (integral_ :: H.Gen Word8)+    integralProps+  , assertProps "Integer" n+    (integral (Range.constantFrom zero -1000000 1000000) :: H.Gen Integer)+    integralUnboundedProps+  , assertProps "Natural" n+    (integral (Range.constantFrom zero zero 1000000) :: H.Gen Natural)+    naturalProps+  , assertProps "Bool" n Gen.bool+    boolProps+  , assertProps "Rational" n+    (negUniform :: H.Gen Rational) rationalProps+  , assertProps "Float" n+    (negUniform :: H.Gen Float) fieldProps+  , assertProps "Float - Quotient" n+    (negUniform :: H.Gen Float) quotientFieldProps+  , assertProps "Complex Float" n+    (genComplex (negUniform :: H.Gen Float))+    (complexFieldProps (5.0 :+ 5.0))+  , assertProps "Pair Float" n+    (genPair (negUniform :: H.Gen Float)) fieldProps+  , assertProps "Float Lattice" n+    (negUniform :: H.Gen Float) latticeProps+  , assertProps "Complex Lattice" n+    (genComplex (negUniform :: H.Gen Float)) latticeProps+  , assertProps "Space Properties" n+    (genRange (negUniform :: H.Gen Float)) spaceProps+  , assertProps "FieldSpace" n+    (genRange (negUniform :: H.Gen Float)) fieldSpaceProps+  , assertProps "Space Algebra" n+    (genRangePos (negUniform :: H.Gen Float))+    spaceAlgebraProps+  ]++main :: IO ()+main = do+  ok <- all P.id <$> sequence (asserts (P.fromInteger 100 :: H.TestLimit))+  unless ok+    exitFailure