{-# 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))
  ]