{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
{-# 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.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 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)
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
testLawOf _ (name, Ternary f) = testProperty name f
testLawOf _ (name, Ornary f) = testProperty name f
testLawOf _ (name, Failiary f) = testProperty name f
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
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)
]
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))
]
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))
]
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))
]