packages feed

numhask-hedgehog 0.3 → 0.3.1

raw patch · 6 files changed

+80/−172 lines, 6 filesdep ~numhask-space

Dependency ranges changed: numhask-space

Files

numhask-hedgehog.cabal view
@@ -1,5 +1,5 @@ name: numhask-hedgehog-version: 0.3+version: 0.3.1 synopsis:   Laws and tests for numhask description:@@ -49,7 +49,7 @@       base >=4.7 && <5     , hedgehog >=0.5 && <1.1     , numhask >=0.3 && <0.4-    , numhask-space >=0.1.1 && <0.2+    , numhask-space >=0.2.0 && <0.4     , numhask-prelude >=0.3 && <0.4   exposed-modules:     NumHask.Hedgehog
src/NumHask/Hedgehog/Gen.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -19,6 +19,7 @@  import Hedgehog as H import NumHask.Prelude as P+import NumHask.Space as S import qualified Hedgehog.Internal.Gen as Gen import qualified Hedgehog.Internal.Seed as Seed import qualified Hedgehog.Range as Range@@ -27,18 +28,22 @@ -- 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 :: (ToRatio a Integer, FromRatio a Integer, 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+      fromRatio . (toRatio :: Double -> Ratio Integer) . fst $+        Seed.nextDouble (fromRatio (toRatio x :: Ratio Integer)) (fromRatio (toRatio y :: Ratio Integer)) seed --- | an integral-stype random variate-integral :: (ToInteger a, FromInteger a, MonadGen m) => Range.Range a -> m a++-- | an integral-type random variate+-- integral :: (ToIntegral a Integer, FromIntegral a Integer, MonadGen m) => Range.Range a -> m a+integral+  :: (MonadGen m, FromInteger a, ToInteger a)+  => Range.Range a -> m a integral r =   Gen.generate $ \size seed ->     let@@ -46,7 +51,7 @@         Range.bounds size r     in       fromIntegral . fst $-        Seed.nextInteger (fromIntegral x) (fromIntegral y) seed+        Seed.nextInteger (toInteger x) (toInteger y) seed  -- | an integral-style random variate utilising Bounds integral_ ::@@ -62,8 +67,8 @@ rational_ ::   ( Additive a   , Bounded a-  , ToRatio a-  , FromRatio a+  , ToRatio a Integer+  , FromRatio a Integer   , MonadGen m)   => m a rational_ = rational (Range.constantFrom zero minBound maxBound)@@ -71,8 +76,8 @@ -- | a uniform distribution between zero and one uniform ::   ( Field a-  , ToRatio a-  , FromRatio a+  , ToRatio a Integer+  , FromRatio a Integer   , MonadGen m)   => m a uniform = rational (Range.constantFrom zero zero one)@@ -80,8 +85,8 @@ -- | a uniform distribution between -1 and 1 negUniform ::   ( Field a-  , ToRatio a-  , FromRatio a+  , ToRatio a Integer+  , FromRatio a Integer   , Subtractive a   , MonadGen m)   => m a@@ -95,13 +100,13 @@   pure (r :+ i)  -- | Space-genRange :: forall a m. (JoinSemiLattice a, MeetSemiLattice a, MonadGen m) => m a -> m (P.Range a)+genRange :: forall a m. (Ord a, MonadGen m) => m a -> m (S.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 :: forall a m. (Ord a, MonadGen m) => m a -> m (S.Range a) genRangePos g = do   a <- g   b <- g
src/NumHask/Hedgehog/Prop.hs view
@@ -178,17 +178,18 @@         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+toFromRatio :: (Eq a, Show a, FromRatio a Integer, ToRatio a Integer) => Gen a -> Property+toFromRatio src = property $ do   rv <- forAll src-  let p = \a -> fromIntegral a == a+  let p = \a ->+        fromRatio (toRatio a :: Ratio Integer) == a   assert (p rv) -isRational :: (Eq a, Show a, FromRatio a, ToRatio a) => Gen a -> Property-isRational src = property $ do+toFromIntegral :: (Eq a, Show a, FromIntegral a Integer, ToIntegral a Integer) => Gen a -> Property+toFromIntegral src = property $ do   rv <- forAll src   let p = \a ->-        fromRational a == a+        fromIntegral_ (toIntegral a :: Integer) == a   assert (p rv)  isSigned :: (Eq a, Show a, Signed a) => Gen a -> Property
src/NumHask/Hedgehog/Prop/Space.hs view
@@ -1,17 +1,43 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wredundant-constraints #-}  module NumHask.Hedgehog.Prop.Space where  import NumHask.Prelude hiding ((%), (.*.)) import Hedgehog as H hiding (Range)+import NumHask.Space -type CanMeasure a = (Lattice a, Multiplicative a, Show a, Epsilon a)- +type CanMeasure a = (Ord a, Fractional a, Lattice a, Multiplicative a, Show a, Epsilon a)++-- | Numeric algebra based on Interval arithmetic+-- https://en.wikipedia.org/wiki/Interval_arithmetic+--+instance (Ord a, Additive a) => Additive (Range a) where+  (Range l u) + (Range l' u') = space1 [l+l',u+u']+  zero = zero ... zero++instance (Ord a, Subtractive a) => Subtractive (Range a) where+  negate (Range l u) = negate u ... negate l++instance (Ord a, Multiplicative a) => Multiplicative (Range a) where+  (Range l u) * (Range l' u') =+    space1 [l * l', l * u', u * l', u * u']+  one = one ... one++instance (Ord a, LowerBoundedField a, UpperBoundedField a, Epsilon a, Divisive a) =>+  Divisive (Range a)+  where+  recip i@(Range l u)+    | zero |.| i && not (epsilon |.| i) = negInfinity ... recip l+    | zero |.| i && not (negate epsilon |.| i) = infinity ... recip l+    | zero |.| i = Range negInfinity infinity+    | otherwise = recip l ... recip u+ -- * individual tests isIdempotent :: forall a. (CanMeasure a) =>   (Range a -> Range a -> Range a) -> a -> Gen a -> Property@@ -76,7 +102,7 @@   , ("commutative *", isCommutative (*) (*) acc src)   ] -isDivisive :: forall a. (CanMeasure a, BoundedLattice a, Divisive a) =>+isDivisive :: forall a. (CanMeasure a, LowerBoundedField a, UpperBoundedField a) =>   a -> Gen a -> Property isDivisive acc src = property $ do   rv <- forAll src@@ -100,19 +126,6 @@     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@@ -188,7 +201,7 @@          || (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) =>+isCommutativeSpace :: forall s. (Fractional (Element s), Show s, Space s) =>   (s -> s -> s) -> Element s -> Gen s -> Property isCommutativeSpace (#) acc src = property $ do   rv <- forAll src@@ -197,7 +210,7 @@         (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) =>+isAssociativeSpace :: forall s. (Fractional (Element s), Show s, Space s) =>   (s -> s -> s) -> Element s -> Gen s -> Property isAssociativeSpace (#) acc src = property $ do   rv <- forAll src@@ -208,7 +221,7 @@         (a # (b # c))   assert (p rv rv' rv'') -isUnitalSpace :: forall s. (Epsilon (Element s), Multiplicative (Element s), Show s, Space s) =>+isUnitalSpace :: forall s. (Fractional (Element s), Show s, Space s) =>   s -> (s -> s -> s) -> Element s -> Gen s -> Property isUnitalSpace u (#) acc src = property $ do   rv <- forAll src@@ -217,7 +230,7 @@         (widenEps acc a # widenEps acc u) `contains` a   assert (p rv) -isLatticeSpace :: forall s. (Show s, Space s) =>+isLatticeSpace :: forall s. (Show s, Space s, JoinSemiLattice (Element s), MeetSemiLattice (Element s)) =>   Gen s -> Property isLatticeSpace src = property $ do   rv <- norm <$> forAll src@@ -249,7 +262,7 @@         (one |.| (recip a * a))   assert (p rv) -isContainedUnion :: forall s. (Epsilon (Element s), Multiplicative (Element s), Show s, Space s) =>+isContainedUnion :: forall s. (Fractional (Element s), Show s, Space s) =>   Element s -> Gen s -> Property isContainedUnion acc src = property $ do   rv <- norm <$> forAll src@@ -259,21 +272,21 @@         (widenEps acc a `union` widenEps acc b) `contains` b   assert (p rv rv') -isProjectiveLower :: forall s. (FieldSpace s, Epsilon (Element s), Show s) =>+isProjectiveLower :: forall s. (FieldSpace s, Epsilon (Element s), Ord (Element s), Fractional (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))+        lower b |.| (eps acc (project a b (lower a)) :: NumHask.Space.Range (Element s))   assert (p rv rv') -isProjectiveUpper :: forall s. (FieldSpace s, Epsilon (Element s), Show s) =>+isProjectiveUpper :: forall s. (FieldSpace s, Epsilon (Element s), Ord (Element s), Fractional (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))+        upper b |.| ((project a b (upper a) +/- epsilon) :: NumHask.Space.Range (Element s))   assert (p rv rv')
src/NumHask/Hedgehog/Props.hs view
@@ -18,13 +18,13 @@   , Distributive a   , Subtractive a   , Integral a-  , FromInteger a-  , ToInteger a   , Signed a   , Bounded a   , Normed a a   , Metric a a   , JoinSemiLattice a+  , FromIntegral a Integer+  , ToIntegral a Integer   )   => Gen a   -> [(PropertyName, Property)]@@ -36,7 +36,7 @@   , \x -> [("distributive", isDistributive zero (+) (*) x)]   , \x -> [("absorbative zero", isAbsorbativeUnit zero (*) x)]   , \x -> [("integral", isIntegral x)]-  , \x -> [("fromIntegral", isFromIntegral x)]+  , \x -> [("ToIntegral", toFromIntegral x)]   , \x -> [("signed", isSigned x)]   , \x -> [("normed", isNormedBounded x)]   , \x -> [("metric", isMetricBounded x)]@@ -48,8 +48,6 @@   , Distributive a   , Subtractive a   , Integral a-  , FromInteger a-  , ToInteger a   , Signed a   , Normed a a   , Metric a a@@ -65,7 +63,6 @@   , \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)]@@ -76,8 +73,6 @@   ( Show a   , Distributive a   , Integral a-  , FromInteger a-  , ToInteger a   , Signed a   , Normed a a   , JoinSemiLattice a@@ -91,7 +86,6 @@   , \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)]   ]@@ -122,12 +116,12 @@   , Distributive a   , Subtractive a   , Divisive a-  , FromRatio a-  , ToRatio a   , Signed a   , Normed a a   , Metric a a   , JoinSemiLattice a+  , FromRatio a Integer+  , ToRatio a Integer   )   => Gen a   -> [(PropertyName, Property)]@@ -139,7 +133,7 @@   , \x -> [("distributive", isDistributive zero (+) (*) x)]   , \x -> [("absorbative unit", isAbsorbativeUnit zero (*) x)]   , isDivisive-  , \x -> [("rational", isRational x)]+  , \x -> [("rational", toFromRatio x)]   , \x -> [("signed", isSigned x)]   , \x -> [("normed", isNormedUnbounded x)]   , \x -> [("metric", isMetricUnbounded x)]@@ -149,7 +143,6 @@ fieldProps   :: forall a.   ( S.CanMeasure a-  , BoundedLattice a   , LowerBoundedField a   , UpperBoundedField a   , Signed a@@ -192,10 +185,9 @@ complexFieldProps   :: forall a.   ( S.CanMeasure (Complex a)-  , Epsilon a-  , BoundedLattice (Complex a)-  , Divisive a-  , FromRatio a+  , LowerBoundedField (Complex a)+  , UpperBoundedField (Complex a)+  , FromRational a   )   => Complex a   -> Gen (Complex a)@@ -214,8 +206,8 @@ logFieldProps   :: forall a.   ( S.CanMeasure a-  , BoundedLattice a-  , Divisive a+  , LowerBoundedField a+  , UpperBoundedField a   )   => Gen a   -> [(PropertyName, Property)]@@ -228,90 +220,3 @@   , \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
@@ -30,27 +30,11 @@   , assertProps "Bool" n Gen.bool     boolProps   , assertProps "Rational" n-    (negUniform :: H.Gen Rational) rationalProps+    (negUniform :: H.Gen (Ratio Integer)) 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 ()