{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
-- |
-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue264
-- Copyright   : [2009..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- https://github.com/AccelerateHS/accelerate/issues/264
--

module Data.Array.Accelerate.Test.NoFib.Issues.Issue264 (

  test_issue264

) where

import Prelude                                                      as P

import Data.Array.Accelerate                                        as A
import Data.Array.Accelerate.Sugar.Array                            as S
import Data.Array.Accelerate.Sugar.Elt                              as S
import Data.Array.Accelerate.Sugar.Shape                            as S
import Data.Array.Accelerate.Test.NoFib.Base
import Data.Array.Accelerate.Test.NoFib.Config
import Data.Array.Accelerate.Test.Similar

import Hedgehog
import qualified Hedgehog.Gen                                       as Gen

import Test.Tasty
import Test.Tasty.Hedgehog


test_issue264 :: RunN -> TestTree
test_issue264 runN =
  testGroup "264"
    [ testBool
    , at @TestInt8   $ testElt i8
    , at @TestInt16  $ testElt i16
    , at @TestInt32  $ testElt i32
    , at @TestInt64  $ testElt i64
    , at @TestWord8  $ testElt w8
    , at @TestWord16 $ testElt w16
    , at @TestWord32 $ testElt w32
    , at @TestWord64 $ testElt w64
    , at @TestFloat  $ testElt f32
    , at @TestDouble $ testElt f64
    ]
  where
    testElt
        :: forall a. (Similar a, Show a, P.Num a, A.Num a)
        => Gen a
        -> TestTree
    testElt e =
      testGroup (show (eltR @a))
        [ testProperty "neg.neg"        $ test_neg_neg runN e
        ]

    testBool :: TestTree
    testBool =
      testGroup "Bool"
        [ testProperty "not.not"        $ test_not_not runN
        , testProperty "not(&&)"        $ test_not_and runN
        , testProperty "not(||)"        $ test_not_or runN
        , testProperty "not(not(&&))"   $ test_not_not_and runN
        , testProperty "not(not(||))"   $ test_not_not_or runN
        ]

test_not_not
    :: RunN
    -> Property
test_not_not runN =
  property $ do
    xs <- forAll (array Z Gen.bool)
    let !go = runN (A.map A.not . A.map A.not) in go xs === mapRef (P.not . P.not) xs

test_not_and
    :: RunN
    -> Property
test_not_and runN =
  property $ do
    xs <- forAll (array Z Gen.bool)
    ys <- forAll (array Z Gen.bool)
    let !go = runN (A.zipWith (\u v -> A.not (u A.&& v))) in go xs ys === zipWithRef (\u v -> P.not (u P.&& v)) xs ys

test_not_or
    :: RunN
    -> Property
test_not_or runN =
  property $ do
    xs <- forAll (array Z Gen.bool)
    ys <- forAll (array Z Gen.bool)
    let !go = runN (A.zipWith (\u v -> A.not (u A.|| v))) in go xs ys === zipWithRef (\u v -> P.not (u P.|| v)) xs ys

test_not_not_and
    :: RunN
    -> Property
test_not_not_and runN =
  property $ do
    xs <- forAll (array Z Gen.bool)
    ys <- forAll (array Z Gen.bool)
    let !go = runN (A.zipWith (\u v -> A.not (A.not (u A.&& v)))) in go xs ys === zipWithRef (\u v -> P.not (P.not (u P.&& v))) xs ys

test_not_not_or
    :: RunN
    -> Property
test_not_not_or runN =
  property $ do
    xs <- forAll (array Z Gen.bool)
    ys <- forAll (array Z Gen.bool)
    let !go = runN (A.zipWith (\u v -> A.not (A.not (u A.|| v)))) in go xs ys === zipWithRef (\u v -> P.not (P.not (u P.|| v))) xs ys

test_neg_neg
    :: (P.Num e, A.Num e, Similar e, Show e)
    => RunN
    -> Gen e
    -> Property
test_neg_neg runN e =
  property $ do
    sh <- forAll dim1
    xs <- forAll (array sh e)
    let !go = runN (A.map negate . A.map negate) in go xs ~~~ mapRef (negate . negate) xs



mapRef :: (Shape sh, Elt a, Elt b) => (a -> b) -> Array sh a -> Array sh b
mapRef f xs = fromFunction (S.shape xs) (\ix -> f (xs S.! ix))

zipWithRef
    :: (Shape sh, Elt a, Elt b, Elt c)
    => (a -> b -> c)
    -> Array sh a
    -> Array sh b
    -> Array sh c
zipWithRef f xs ys =
  fromFunction
    (S.shape xs `S.intersect` S.shape ys)
    (\ix -> f (xs S.! ix) (ys S.! ix))