accelerate-examples-1.0.0.0: examples/nofib/Test/Prelude/Permute.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Test.Prelude.Permute (
test_permute
) where
import Prelude as P
import Data.Label
import Data.Maybe
import Data.Typeable
import Control.Monad
import Test.QuickCheck
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Config
import Test.Base
import QuickCheck.Arbitrary.Array
import Data.Array.Accelerate as A
import Data.Array.Accelerate.IO as A
import Data.Array.Accelerate.Array.Sugar ( rank )
import Data.Array.Accelerate.Examples.Internal as A
import Data.Array.ST ( runSTArray )
import Data.Array.Unboxed ( IArray, UArray )
import qualified Data.Array.Unboxed as IArray
import qualified Data.Array.MArray as M
--
-- Forward permutation ---------------------------------------------------------
--
test_permute :: Backend -> Config -> Test
test_permute backend opt = testGroup "permute" $ catMaybes
[ testIntegralElt configInt8 (undefined :: Int8)
, testIntegralElt configInt16 (undefined :: Int16)
, testIntegralElt configInt32 (undefined :: Int32)
, testIntegralElt configInt64 (undefined :: Int64)
, testIntegralElt configWord8 (undefined :: Word8)
, testIntegralElt configWord16 (undefined :: Word16)
, testIntegralElt configWord32 (undefined :: Word32)
, testIntegralElt configWord64 (undefined :: Word64)
, testFloatingElt configFloat (undefined :: Float)
, testFloatingElt configDouble (undefined :: Double)
]
where
testIntegralElt :: forall e. (P.Integral e, A.Integral e, A.FromIntegral e Int, Arbitrary e, Similar e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test
testIntegralElt ok _
| P.not (get ok opt) = Nothing
| otherwise = Just $ testGroup (show (typeOf (undefined :: e)))
[
test_fill (undefined :: e)
, testProperty "scatter" (test_scatter :: e -> Property)
-- , testProperty "scatterIf" (test_scatterIf :: e -> Property)
, testProperty "histogram" (test_histogram A.fromIntegral P.fromIntegral :: Vector e -> Property)
]
testFloatingElt :: forall e. (P.RealFrac e, A.RealFrac e, Arbitrary e, Similar e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test
testFloatingElt ok _
| P.not (get ok opt) = Nothing
| otherwise = Just $ testGroup (show (typeOf (undefined :: e)))
[
test_fill (undefined :: e)
, testProperty "scatter" (test_scatter :: e -> Property)
-- , testProperty "scatterIf" (test_scatterIf :: e -> Property)
, testProperty "histogram" (test_histogram A.floor P.floor :: Vector e -> Property)
]
-- Test is permutation works by just copying elements directly from one
-- array to the other. Does not attempt to use elements from the defaults
-- array. Additionally, works for any dimension. (c.f. Issue #93)
--
test_fill :: forall e. (P.Num e, A.Num e, Arbitrary e, Similar e) => e -> Test
test_fill _ = testGroup "fill"
[ -- testDim dim0 -- Accelerate issue #87
testDim dim1
, testDim dim2
]
where
testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary (Array sh e)) => sh -> Test
testDim sh = testProperty ("DIM" P.++ show (rank sh)) (push_fill :: Array sh e -> Property)
where
push_fill :: Array sh e -> Property
push_fill xs = run1 backend go xs ~?= xs
where
go arr = permute const (A.fill (A.shape arr) (constant 0)) id arr
-- Test if the combining operation for forward permutation works, by
-- building a histogram. Often tricky for parallel backends.
--
test_histogram :: (P.Num e, A.Num e, Similar e, IArray UArray e) => (Exp e -> Exp Int) -> (e -> Int) -> Vector e -> Property
test_histogram f g xs =
forAll arbitrary $ \(Positive n) ->
run2 backend (histogramAcc f) (scalar n) xs ~?= histogramRef n g xs
histogramAcc :: A.Num e => (Exp e -> Exp Int) -> Acc (Scalar Int) -> Acc (Vector e) -> Acc (Vector e)
histogramAcc f n xs =
let zeros = A.fill (index1 $ the n) 0
ones = A.fill (shape xs) 1
in
permute (+) zeros (\ix -> index1 $ f (xs A.! ix) `mod` the n) ones
histogramRef :: forall e. (Elt e, P.Num e, IArray UArray e) => Int -> (e -> Int) -> Vector e -> Vector e
histogramRef n f xs =
let arr :: IArray.UArray Int e
arr = IArray.accumArray (+) 0 (0, n-1) [ (f e `mod` n, 1) | e <- toList xs ]
in
fromIArray arr
-- Test for scattering functions
--
test_scatter :: forall e. (Elt e, Similar e, Arbitrary e) => e -> Property
test_scatter _ =
forAll (sized $ \n -> choose (0,n)) $ \k -> let m = 2*k in
forAll (arbitraryArray (Z:.m+1)) $ \defaultV ->
forAll (arbitraryUniqueVectorOf (choose (0, m))) $ \mapV -> let n = arraySize (arrayShape mapV) in
forAll (arbitraryArray (Z:.n)) $ \(inputV :: Vector e) ->
toList (run3 backend A.scatter mapV defaultV inputV)
~?=
IArray.elems (scatterRef (toIArray mapV) (toIArray defaultV) (toIArray inputV))
-- test_scatterIf :: forall e. (Elt e, Similar e, Arbitrary e) => e -> Property
-- test_scatterIf _ =
-- forAll (sized $ \n -> choose (0,n)) $ \k -> let m = 2*k in
-- forAll (arbitraryArray (Z:.m+1)) $ \defaultV ->
-- forAll (arbitraryUniqueVectorOf (choose (0, m))) $ \mapV -> let n = arraySize (arrayShape mapV) in
-- forAll (arbitraryArray (Z:.n)) $ \(maskV :: Vector Int) ->
-- forAll (arbitraryArray (Z:.n)) $ \(inputV :: Vector e) ->
-- toList (run4 backend (\p v d x -> A.scatterIf p v A.even d x) mapV maskV defaultV inputV)
-- ~?=
-- IArray.elems (scatterIfRef (toIArray mapV) (toIArray maskV) P.even (toIArray defaultV) (toIArray inputV))
-- Reference Implementation
-- ------------------------
scatterRef
:: IArray.UArray Int Int
-> IArray.Array Int e
-> IArray.Array Int e
-> IArray.Array Int e
scatterRef mapV defaultV inputV
= runSTArray
$ do mu <- M.thaw defaultV
forM_ (IArray.assocs mapV) $ \(inIx, outIx) -> M.writeArray mu outIx (inputV IArray.! inIx)
return mu
-- scatterIfRef
-- :: IArray.UArray Int Int
-- -> IArray.Array Int e
-- -> (e -> Bool)
-- -> IArray.Array Int t
-- -> IArray.Array Int t
-- -> IArray.Array Int t
-- scatterIfRef mapV maskV f defaultV inputV
-- = runSTArray
-- $ do mu <- M.thaw defaultV
-- forM_ (IArray.assocs mapV) $ \(inIx, outIx) ->
-- when (f (maskV IArray.! inIx)) $
-- M.writeArray mu outIx (inputV IArray.! inIx)
-- return mu