diff --git a/massiv-test.cabal b/massiv-test.cabal --- a/massiv-test.cabal +++ b/massiv-test.cabal @@ -1,5 +1,5 @@ name: massiv-test -version: 0.1.3 +version: 0.1.3.1 synopsis: Library that contains generators, properties and tests for Massiv Array Library. description: This library is designed for users of massiv library that need random generators for writing custom property tests and reusing some of the predefined ones. homepage: https://github.com/lehins/massiv @@ -15,7 +15,7 @@ cabal-version: >=1.10 library - hs-source-dirs: src + hs-source-dirs: src exposed-modules: Test.Massiv.Core , Test.Massiv.Core.Common , Test.Massiv.Core.Index @@ -57,6 +57,9 @@ , Test.Massiv.Array.MutableSpec , Test.Massiv.Array.Ops.TransformSpec , Test.Massiv.Array.Ops.SortSpec + , Test.Massiv.Array.Ops.MapSpec + , Test.Massiv.Array.Numeric.IntegralSpec + , Test.Massiv.Array.StencilSpec , Test.Massiv.VectorSpec -- TODO: Below should be moved to Test.Massiv.Array , Data.Massiv.Array.Delayed.InterleavedSpec @@ -65,12 +68,9 @@ , Data.Massiv.Array.DelayedSpec , Data.Massiv.Array.Manifest.VectorSpec , Data.Massiv.Array.ManifestSpec - , Data.Massiv.Array.Numeric.IntegralSpec , Data.Massiv.Array.Ops.ConstructSpec , Data.Massiv.Array.Ops.FoldSpec - , Data.Massiv.Array.Ops.MapSpec , Data.Massiv.Array.Ops.SliceSpec - , Data.Massiv.Array.StencilSpec , Data.Massiv.ArraySpec build-depends: base , bytestring @@ -78,10 +78,11 @@ , data-default , deepseq , genvalidity-hspec - , massiv + , massiv >= 0.5.2 , massiv-test , mwc-random , hspec + , primitive , scheduler , QuickCheck , vector diff --git a/tests/Data/Massiv/Array/Numeric/IntegralSpec.hs b/tests/Data/Massiv/Array/Numeric/IntegralSpec.hs deleted file mode 100644 --- a/tests/Data/Massiv/Array/Numeric/IntegralSpec.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Data.Massiv.Array.Numeric.IntegralSpec - ( spec - ) where - -import Data.Massiv.Array as A -import Data.Massiv.Array.Numeric.Integral -import Test.Hspec - -gaussian :: Float -> Float -gaussian x = exp (x ^ (2 :: Int)) - -spec :: Spec -spec = do - let (a, b) = (0, 2) - integrator rule = rule Seq N (\ scale -> gaussian . scale) a b (Sz1 1) - describe "Integral Approximation" $ do - it "Midpoint Rule" $ do - integrator midpointRule 4 ! 0 `shouldBe` 14.485613 - integrator midpointRule 8 ! 0 `shouldBe` 15.905677 - integrator midpointRule 16 ! 0 `shouldBe` 16.311854 - integrator midpointRule 32 ! 0 `shouldBe` 16.417171 - integrator midpointRule 64 ! 0 `shouldBe` 16.443748 - integrator midpointRule 128 ! 0 `shouldBe` 16.450407 - it "Trapezoid Rule" $ do - integrator trapezoidRule 4 ! 0 `shouldBe` 20.644558 - integrator trapezoidRule 8 ! 0 `shouldBe` 17.565086 - integrator trapezoidRule 16 ! 0 `shouldBe` 16.735381 - integrator trapezoidRule 32 ! 0 `shouldBe` 16.523618 - integrator trapezoidRule 64 ! 0 `shouldBe` 16.470394 - integrator trapezoidRule 128 ! 0 `shouldBe` 16.457073 - it "Simspon's Rule" $ do - integrator simpsonsRule 4 ! 0 `shouldBe` 17.353626 - integrator simpsonsRule 8 ! 0 `shouldBe` 16.538595 - integrator simpsonsRule 16 ! 0 `shouldBe` 16.458815 - integrator simpsonsRule 32 ! 0 `shouldBe` 16.453030 - integrator simpsonsRule 64 ! 0 `shouldBe` 16.452653 - integrator simpsonsRule 128 ! 0 `shouldBe` 16.452629 diff --git a/tests/Data/Massiv/Array/Ops/MapSpec.hs b/tests/Data/Massiv/Array/Ops/MapSpec.hs deleted file mode 100644 --- a/tests/Data/Massiv/Array/Ops/MapSpec.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module Data.Massiv.Array.Ops.MapSpec (spec) where - -import Data.IORef -import Control.Monad.ST -import Data.Foldable as F -import Data.Massiv.Array.Unsafe -import Data.Massiv.Array as A -import Test.Massiv.Core -import Prelude as P -import Control.Scheduler.Internal - -prop_zipUnzip :: - (Index ix, Show (Array D ix Int)) - => Array D ix Int - -> Array D ix Int - -> Property -prop_zipUnzip arr1 arr2 = - (extract' zeroIndex sz arr1, extract' zeroIndex sz arr2) === A.unzip (A.zip arr1 arr2) - where sz = Sz (liftIndex2 min (unSz (size arr1)) (unSz (size arr2))) - -prop_zipFlip :: - (Index ix, Show (Array D ix (Int, Int))) - => Array D ix Int - -> Array D ix Int - -> Property -prop_zipFlip arr1 arr2 = - A.zip arr1 arr2 === - A.map (\(e2, e1) -> (e1, e2)) (A.zip arr2 arr1) - -prop_zipUnzip3 :: - (Index ix, Show (Array D ix Int)) - => Array D ix Int - -> Array D ix Int - -> Array D ix Int - -> Property -prop_zipUnzip3 arr1 arr2 arr3 = - (extract' zeroIndex sz arr1, extract' zeroIndex sz arr2, extract' zeroIndex sz arr3) === - A.unzip3 (A.zip3 arr1 arr2 arr3) - where - sz = - Sz (liftIndex2 min (liftIndex2 min (unSz (size arr1)) (unSz (size arr2))) (unSz (size arr3))) - -prop_zipFlip3 :: - (Index ix, Show (Array D ix (Int, Int, Int))) - => Array D ix Int - -> Array D ix Int - -> Array D ix Int - -> Property -prop_zipFlip3 arr1 arr2 arr3 = - A.zip3 arr1 arr2 arr3 === A.map (\(e3, e2, e1) -> (e1, e2, e3)) (A.zip3 arr3 arr2 arr1) - - - -prop_itraverseA :: - (Index ix, Show (Array U ix Int)) => Array D ix Int -> Fun (ix, Int) Int -> Property -prop_itraverseA arr fun = - alt_imapM (\ix -> Just . applyFun2Compat fun ix) arr === - itraverseA @U (\ix -> Just . applyFun2Compat fun ix) arr - - -mapSpec :: - forall ix. - ( Arbitrary ix - , CoArbitrary ix - , Index ix - , Function ix - , Show (Array U ix Int) - , Show (Array D ix Int) - , Show (Array D ix (Int, Int)) - , Show (Array D ix (Int, Int, Int)) - ) - => Spec -mapSpec = do - describe "Zipping" $ do - it "zipUnzip" $ property $ prop_zipUnzip @ix - it "zipFlip" $ property $ prop_zipFlip @ix - it "zipUnzip3" $ property $ prop_zipUnzip3 @ix - it "zipFlip3" $ property $ prop_zipFlip3 @ix - describe "Traversing" $ - it "itraverseA" $ property $ prop_itraverseA @ix - describe "StatefulMapping" $ - it "mapWS" $ property $ prop_MapWS @ix - -spec :: Spec -spec = do - describe "Ix1" $ mapSpec @Ix1 - describe "Ix2" $ mapSpec @Ix2 - describe "Ix3" $ mapSpec @Ix3 - describe "Ix4" $ mapSpec @Ix4 - - - -alt_imapM - :: (Applicative f, Mutable r2 t1 b, Source r1 t1 t2) => - (t1 -> t2 -> f b) -> Array r1 t1 t2 -> f (Array r2 t1 b) -alt_imapM f arr = fmap loadList $ P.traverse (uncurry f) $ foldrS (:) [] (zipWithIndex arr) - where - loadList xs = - runST $ do - marr <- unsafeNew (size arr) - _ <- F.foldlM (\i e -> unsafeLinearWrite marr i e >> return (i + 1)) 0 xs - unsafeFreeze (getComp arr) marr - {-# INLINE loadList #-} - -zipWithIndex :: forall r ix e . Source r ix e => Array r ix e -> Array D ix (ix, e) -zipWithIndex arr = A.zip (range Seq zeroIndex (unSz (size arr))) arr -{-# INLINE zipWithIndex #-} - - -prop_MapWS :: (Show (Array U ix Int), Index ix) => Array U ix Int -> Property -prop_MapWS arr = - monadicIO $ - run $ do - states <- initWorkerStates (getComp arr) (\_ -> newIORef 0) - arr' <- - forWS states arr $ \e ref -> do - acc <- readIORef ref - writeIORef ref (acc + e) - pure e - accsArr <- A.mapM @P readIORef (evalArray Seq (_workerStatesArray states)) - pure (A.sum arr' === A.sum accsArr .&&. arr === arr') diff --git a/tests/Data/Massiv/Array/StencilSpec.hs b/tests/Data/Massiv/Array/StencilSpec.hs deleted file mode 100644 --- a/tests/Data/Massiv/Array/StencilSpec.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module Data.Massiv.Array.StencilSpec (spec) where - -import Prelude as P -import Control.DeepSeq (deepseq) -import Data.Default (Default(def)) -import Data.Massiv.Array as A -import Data.Massiv.Array.Unsafe as A -import Test.Massiv.Core - -avg3x3Stencil :: Fractional a => Stencil Ix2 a a -avg3x3Stencil = (/9) <$> makeConvolutionStencil (Sz 3) (1 :. 1) $ \ get -> - get (-1 :. -1) 1 . get (-1 :. 0) 1 . get (-1 :. 1) 1 . - get ( 0 :. -1) 1 . get ( 0 :. 0) 1 . get ( 0 :. 1) 1 . - get ( 1 :. -1) 1 . get ( 1 :. 0) 1 . get ( 1 :. 1) 1 - - -singletonStencil :: (Index ix) => (Int -> Int) -> Stencil ix Int Int -singletonStencil f = - makeStencil oneSz zeroIndex $ \ get -> fmap f (get zeroIndex) - - -prop_MapSingletonStencil :: (Load DW ix Int, Manifest U ix Int, Show (Array U ix Int)) => - Proxy ix -> Fun Int Int -> Border Int -> ArrNE U ix Int -> Property -prop_MapSingletonStencil _ f b (ArrNE arr) = - computeAs U (mapStencil b (singletonStencil (apply f)) arr) === computeAs U (A.map (apply f) arr) - -prop_ApplyZeroStencil :: - (Load DW ix Int, Manifest U ix Int) => Proxy ix -> Int -> Array U ix Int -> Property -prop_ApplyZeroStencil _ e arr = - assertSomeException $ computeAs U (applyStencil noPadding zeroStencil arr) - where - zeroStencil = makeStencil zeroSz zeroIndex $ \_get -> pure e - - -prop_MapSingletonStencilWithStride :: - (StrideLoad DW ix Int, Manifest U ix Int, Show (Array U ix Int)) - => Proxy ix - -> Fun Int Int - -> Border Int - -> ArrNE U ix Int - -> Property -prop_MapSingletonStencilWithStride _ f b (ArrNE arr) = - computeWithStride oneStride (mapStencil b (singletonStencil (apply f)) arr) === - computeAs U (A.map (apply f) arr) - --- Tests out of bounds stencil indexing -prop_DangerousStencil :: - Index ix => Proxy ix -> NonZero Int -> DimIx ix -> SzIx ix -> Property -prop_DangerousStencil _ (NonZero s) (DimIx r) (SzIx sz ix) = - ix' `deepseq` assertSomeException $ makeStencil sz ix $ \get -> get ix' :: Value Int - where - ix' = liftIndex (* signum s) (setDim' zeroIndex r (getDim' (unSz sz) r)) - - -instance Index ix => Show (Stencil ix a b) where - show stencil = - "Stencil " ++ show (getStencilSize stencil) ++ " " ++ show (getStencilCenter stencil) - - -prop_MapEqApplyStencil :: - (Show (Array P ix Int), StrideLoad DW ix Int) - => Stride ix - -> SzTiny ix - -> Border Int - -> Array P ix Int - -> Property -prop_MapEqApplyStencil stride (SzTiny sz) b arr = - forAll (elements (P.zip [0 ..] (toList $ A.map (\(n, _, _) -> n) stencils))) $ \(i, _) -> - let (_, stencil, g) = stencils ! i - in computeAs P (unsafeMapStencil b sz zeroIndex (const g) arr) === - computeAs P (applyStencil (samePadding stencil b) stencil arr) .&&. - computeWithStrideAs P stride (unsafeMapStencil b sz zeroIndex (const g) arr) === - computeWithStrideAs P stride (applyStencil (samePadding stencil b) stencil arr) - where - stencils = mkCommonStencils sz - -mkCommonStencils :: - (Bounded a, Num a, Ord a, Index ix) - => Sz ix - -> Array B Ix1 (String, Stencil ix a a, (ix -> a) -> a) -mkCommonStencils sz = - fromList - Seq - [ (name, stencil sz, \get -> foldlS f acc0 $ fmap get (zeroIndex ..: unSz sz)) - | (name, stencil, f, acc0) <- - [ ("maxStencil", maxStencil, max, minBound) - , ("minStencil", minStencil, min, maxBound) - , ("sumStencil", sumStencil, (+), 0) - , ("productStencil", productStencil, (*), 1) - ] - ] - -prop_FoldrStencil :: Load DW ix (Array DL Ix1 Int) => ArrNE P ix Int -> Property -prop_FoldrStencil (ArrNE arr) = - computeAs P (computeAs B folded ! zeroIndex) === A.fromList Seq (foldrS (:) [] arr) - where - folded = applyStencil noPadding (foldrStencil cons A.empty (size arr)) arr - -stencilSpec :: Spec -stencilSpec = do - describe "MapSingletonStencil" $ do - it "Ix1" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix1) - it "Ix2" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2) - it "Ix3" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix3) - it "Ix4" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix4) - it "Ix2T" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2T) - describe "MapSingletonStencilWithStride" $ do - it "Ix1" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix1) - it "Ix2" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix2) - it "Ix3" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix3) - describe "ApplyZeroStencil" $ do - it "Ix1" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix1) - it "Ix2" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix2) - it "Ix3" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix3) - it "Ix4" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix4) - it "Ix2T" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix2T) - describe "DangerousStencil" $ do - it "Ix1" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix1) - it "Ix2" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix2) - it "Ix3" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix3) - it "Ix4" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix4) - describe "MapEqApplyStencil" $ do - it "Ix1" $ property $ prop_MapEqApplyStencil @Ix1 - it "Ix2" $ property $ prop_MapEqApplyStencil @Ix2 - it "Ix3" $ property $ prop_MapEqApplyStencil @Ix3 - it "Ix4" $ property $ prop_MapEqApplyStencil @Ix4 - describe "FoldrStencil" $ do - it "Ix1" $ property $ prop_FoldrStencil @Ix1 - it "Ix2" $ property $ prop_FoldrStencil @Ix2 - it "Ix3" $ property $ prop_FoldrStencil @Ix3 - it "Ix4" $ property $ prop_FoldrStencil @Ix4 - describe "Simple" $ do - it "sumStencil" $ property $ \ (arr :: Array B Ix2 Rational) border -> - computeAs N (mapStencil border avg3x3Stencil arr) === - computeAs N (applyStencil (Padding 1 1 border) (avgStencil (Sz 3)) arr) - it "sameSizeAndCenter" $ property $ \ (SzIx sz ix) -> - let stencil = makeStencil sz ix ($ Ix1 0) :: Stencil Ix1 Int Int - in getStencilSize stencil === sz .&&. getStencilCenter stencil === ix - -stencilDirection :: Ix2 -> Array U Ix2 Int -> Array U Ix2 Int -stencilDirection ix = computeAs U . mapStencil (Fill def) (makeStencil (Sz 3) (1 :. 1) $ \f -> f ix) - - -stencilCorners :: Ix2 -> Ix2 -> Array U Ix2 Int -> Array U Ix2 Int -stencilCorners ixC ix = computeAs U . mapStencil (Fill def) (makeStencil (Sz 3) ixC $ \f -> f ix) - - -stencilConvolution :: Spec -stencilConvolution = do - let xs3 :: Array U Ix1 Int - xs3 = [1, 2, 3] - xs3f f = f (-1) 1 . f 0 2 . f 1 3 - xs4 :: Array U Ix1 Int - xs4 = [1, 2, 3, 4] - xs4f f = f (-2) 1 . f (-1) 2 . f 0 3 . f 1 4 - ys :: Array U Ix1 Int - ys = [1, 2, 3, 4, 5] - ysConvXs3 = [4, 10, 16, 22, 22] - ysConvXs4 = [10, 20, 30, 34, 31] - ysCorrXs3 = [8, 14, 20, 26, 14] - ysCorrXs4 = [11, 20, 30, 40, 26] - ysConvXs4' = [4, 10, 20, 30, 34] - ysCorrXs4' = [20, 30, 40, 26, 14] - xs4f' f = f (-1) 1 . f 0 2 . f 1 3 . f 2 4 - mapStencil1 :: Stencil Ix1 Int Int -> Array U Ix1 Int -> Array U Ix1 Int - mapStencil1 s = computeAs U . mapStencil (Fill 0) s - mapStencil2 :: Stencil Ix2 Int Int -> Array U Ix2 Int -> Array U Ix2 Int - mapStencil2 s = computeAs U . mapStencil (Fill 0) s - applyStencil1 :: Stencil Ix1 Int Int -> Array U Ix1 Int -> Array U Ix1 Int - applyStencil1 s = computeAs U . applyStencil noPadding s - describe "makeConvolutionStencilFromKernel" $ do - it "1x3 map" $ mapStencil1 (makeConvolutionStencilFromKernel xs3) ys `shouldBe` ysConvXs3 - it "1x4 map" $ mapStencil1 (makeConvolutionStencilFromKernel xs4) ys `shouldBe` ysConvXs4 - it "1x3 apply" $ - applyStencil1 (makeConvolutionStencilFromKernel xs3) ys `shouldBe` - compute (extract' 1 3 ysConvXs3) - it "1x4 apply" $ - applyStencil1 (makeConvolutionStencilFromKernel xs4) ys `shouldBe` - compute (extract' 1 2 ysConvXs4) - describe "makeCorrelationStencilFromKernel" $ do - it "1x3 map" $ mapStencil1 (makeCorrelationStencilFromKernel xs3) ys `shouldBe` ysCorrXs3 - it "1x4 map" $ mapStencil1 (makeCorrelationStencilFromKernel xs4) ys `shouldBe` ysCorrXs4 - describe "makeConvolutionStencil" $ do - it "1x3" $ mapStencil1 (makeConvolutionStencil (Sz1 3) 1 xs3f) ys `shouldBe` ysConvXs3 - it "1x4" $ mapStencil1 (makeConvolutionStencil (Sz1 4) 2 xs4f) ys `shouldBe` ysConvXs4 - it "1x4" $ mapStencil1 (makeConvolutionStencil (Sz1 4) 1 xs4f') ys `shouldBe` ysConvXs4' - describe "makeCorrelationStencil" $ do - it "1x3" $ mapStencil1 (makeCorrelationStencil (Sz1 3) 1 xs3f) ys `shouldBe` ysCorrXs3 - it "1x4" $ mapStencil1 (makeCorrelationStencil (Sz1 4) 2 xs4f) ys `shouldBe` ysCorrXs4 - it "1x4" $ mapStencil1 (makeCorrelationStencil (Sz1 4) 1 xs4f') ys `shouldBe` ysCorrXs4' - describe "makeConvolutionStencil == makeConvolutionStencilFromKernel" $ do - it "Sobel Horizontal" $ - property $ \(arr :: Array U Ix2 Int) -> - mapStencil2 (makeConvolutionStencil (Sz 3) 1 sobelX) arr === - mapStencil2 (makeConvolutionStencilFromKernel sobelKernelX) arr - it "1x3" $ - property $ \(arr :: Array U Ix1 Int) -> - mapStencil1 (makeConvolutionStencil (Sz1 3) 1 xs3f) arr === - mapStencil1 (makeConvolutionStencilFromKernel xs3) arr - it "1x4" $ - property $ \(arr :: Array U Ix1 Int) -> - mapStencil1 (makeConvolutionStencil (Sz1 4) 2 xs4f) arr === - mapStencil1 (makeConvolutionStencilFromKernel xs4) arr - describe "makeCorrelationStencil == makeCorrelationStencilFromKernel" $ do - it "Sobel Horizontal" $ - property $ \(arr :: Array U Ix2 Int) -> - mapStencil2 (makeCorrelationStencil (Sz 3) 1 sobelX) arr === - mapStencil2 (makeCorrelationStencilFromKernel sobelKernelX) arr - it "1x3" $ - property $ \(arr :: Array U Ix1 Int) -> - mapStencil1 (makeCorrelationStencil (Sz1 3) 1 xs3f) arr === - mapStencil1 (makeCorrelationStencilFromKernel xs3) arr - it "1x4" $ - property $ \(arr :: Array U Ix1 Int) -> - mapStencil1 (makeCorrelationStencil (Sz1 4) 2 xs4f) arr === - mapStencil1 (makeCorrelationStencilFromKernel xs4) arr - describe "makeConvolutionStencil == makeCorrelationStencil . rotate180" $ do - it "Sobel Horizontal" $ - property $ \(arr :: Array U Ix2 Int) -> - mapStencil2 (makeConvolutionStencilFromKernel sobelKernelX) arr === - mapStencil2 (makeCorrelationStencilFromKernel (rotate180 sobelKernelX)) arr - it "1x3" $ - property $ \(arr :: Array U Ix1 Int) -> - mapStencil1 (makeConvolutionStencilFromKernel xs3) arr === - mapStencil1 (makeCorrelationStencilFromKernel (rotate180 xs3)) arr - it "1x5" $ - property $ \(arr :: Array U Ix1 Int) -> - mapStencil1 (makeConvolutionStencilFromKernel ys) arr === - mapStencil1 (makeCorrelationStencilFromKernel (rotate180 ys)) arr - -spec :: Spec -spec = do - describe "Stencil" $ do - stencilSpec - let arr = [[1, 2, 3], [4, 5, 6], [7, 8, 9]] :: Array U Ix2 Int - describe "Unit tests Ix2" $ do - it "Direction Left" $ - stencilDirection (0 :. 1) arr `shouldBe` [[2, 3, 0], [5, 6, 0], [8, 9, 0]] - it "Direction Right" $ - stencilDirection (0 :. -1) arr `shouldBe` [[0, 1, 2], [0, 4, 5], [0, 7, 8]] - it "Direction Down" $ - stencilDirection (1 :. 0) arr `shouldBe` [[4, 5, 6], [7, 8, 9], [0, 0, 0]] - it "Direction Up" $ - stencilDirection (-1 :. 0) arr `shouldBe` [[0, 0, 0], [1, 2, 3], [4, 5, 6]] - it "Direction Left/Top Corner" $ - stencilCorners (0 :. 0) (2 :. 2) arr `shouldBe` [[9, 0, 0], [0, 0, 0], [0, 0, 0]] - it "Direction Right/Top Corner" $ - stencilCorners (0 :. 2) (2 :. -2) arr `shouldBe` [[0, 0, 7], [0, 0, 0], [0, 0, 0]] - it "Direction Right/Bottom Corner" $ - stencilCorners (2 :. 2) (-2 :. -2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [0, 0, 1]] - it "Direction Left/Bottom Corner" $ - stencilCorners (2 :. 0) (-2 :. 2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [3, 0, 0]] - describe "mapStencil with stride" $ do - let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int - stencil = makeConvolutionStencilFromKernel kernel - stride = Stride 2 - it "map stencil with stride on small array" $ - let strideArr = mapStencil (Fill 0) stencil arr - in computeWithStrideAs U stride strideArr `shouldBe` [[-4, 8], [2, 14]] - it "map stencil with stride on larger array" $ - let largeArr = makeArrayR U Seq (Sz 5) (succ . toLinearIndex (Sz 5)) - strideArr = mapStencil (Fill 0) stencil largeArr - in computeWithStrideAs U stride strideArr `shouldBe` - [[-6, 1, 14], [-13, 9, 43], [4, 21, 44]] - stencilConvolution - -sobelX :: Num e => (Ix2 -> e -> e -> e) -> e -> e -sobelX f = f (-1 :. -1) (-1) . f (-1 :. 1) 1 . - f ( 0 :. -1) (-2) . f ( 0 :. 1) 2 . - f ( 1 :. -1) (-1) . f ( 1 :. 1) 1 - -sobelKernelX :: Array U Ix2 Int -sobelKernelX = [ [-1, 0, 1] - , [-2, 0, 2] - , [-1, 0, 1] ] - -rotate180 :: (Num ix, Index ix) => Array U ix Int -> Array U ix Int -rotate180 = computeAs U . transform' (\sz -> (sz, sz)) (\(Sz sz) f ix -> f (sz - 1 - ix)) diff --git a/tests/Test/Massiv/Array/Numeric/IntegralSpec.hs b/tests/Test/Massiv/Array/Numeric/IntegralSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/Array/Numeric/IntegralSpec.hs @@ -0,0 +1,37 @@ +module Test.Massiv.Array.Numeric.IntegralSpec + ( spec + ) where + +import Data.Massiv.Array as A +import Data.Massiv.Array.Numeric.Integral +import Test.Massiv.Core + +gaussian :: Float -> Float +gaussian x = exp (x ^ (2 :: Int)) + +spec :: Spec +spec = do + let (a, b) = (0, 2) + integrator rule = rule Seq N (\ s -> gaussian . s) a b (Sz1 1) + describe "Integral Approximation" $ do + it "Midpoint Rule" $ do + integrator midpointRule 4 ! 0 `shouldBe` 14.485613 + integrator midpointRule 8 ! 0 `shouldBe` 15.905677 + integrator midpointRule 16 ! 0 `shouldBe` 16.311854 + integrator midpointRule 32 ! 0 `shouldBe` 16.417171 + integrator midpointRule 64 ! 0 `shouldBe` 16.443748 + integrator midpointRule 128 ! 0 `shouldBe` 16.450407 + it "Trapezoid Rule" $ do + integrator trapezoidRule 4 ! 0 `shouldBe` 20.644558 + integrator trapezoidRule 8 ! 0 `shouldBe` 17.565086 + integrator trapezoidRule 16 ! 0 `shouldBe` 16.735381 + integrator trapezoidRule 32 ! 0 `shouldBe` 16.523618 + integrator trapezoidRule 64 ! 0 `shouldBe` 16.470394 + integrator trapezoidRule 128 ! 0 `shouldBe` 16.457073 + it "Simspon's Rule" $ do + integrator simpsonsRule 4 ! 0 `shouldBe` 17.353626 + integrator simpsonsRule 8 ! 0 `shouldBe` 16.538595 + integrator simpsonsRule 16 ! 0 `shouldBe` 16.458815 + integrator simpsonsRule 32 ! 0 `shouldBe` 16.453030 + integrator simpsonsRule 64 ! 0 `shouldBe` 16.452653 + integrator simpsonsRule 128 ! 0 `shouldBe` 16.452629 diff --git a/tests/Test/Massiv/Array/Ops/MapSpec.hs b/tests/Test/Massiv/Array/Ops/MapSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/Array/Ops/MapSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Massiv.Array.Ops.MapSpec (spec) where + +import Control.Monad.ST +import Data.Foldable as F +import Data.Massiv.Array.Unsafe +import Data.Massiv.Array as A +import Test.Massiv.Core +import Prelude as P +import Control.Scheduler + +prop_zipUnzip :: + (Index ix, Show (Array D ix Int)) + => Array D ix Int + -> Array D ix Int + -> Property +prop_zipUnzip arr1 arr2 = + (extract' zeroIndex sz arr1, extract' zeroIndex sz arr2) === A.unzip (A.zip arr1 arr2) + where sz = Sz (liftIndex2 min (unSz (size arr1)) (unSz (size arr2))) + +prop_zipFlip :: + (Index ix, Show (Array D ix (Int, Int))) + => Array D ix Int + -> Array D ix Int + -> Property +prop_zipFlip arr1 arr2 = + A.zip arr1 arr2 === + A.map (\(e2, e1) -> (e1, e2)) (A.zip arr2 arr1) + +prop_zipUnzip3 :: + (Index ix, Show (Array D ix Int)) + => Array D ix Int + -> Array D ix Int + -> Array D ix Int + -> Property +prop_zipUnzip3 arr1 arr2 arr3 = + (extract' zeroIndex sz arr1, extract' zeroIndex sz arr2, extract' zeroIndex sz arr3) === + A.unzip3 (A.zip3 arr1 arr2 arr3) + where + sz = + Sz (liftIndex2 min (liftIndex2 min (unSz (size arr1)) (unSz (size arr2))) (unSz (size arr3))) + +prop_zipFlip3 :: + (Index ix, Show (Array D ix (Int, Int, Int))) + => Array D ix Int + -> Array D ix Int + -> Array D ix Int + -> Property +prop_zipFlip3 arr1 arr2 arr3 = + A.zip3 arr1 arr2 arr3 === A.map (\(e3, e2, e1) -> (e1, e2, e3)) (A.zip3 arr3 arr2 arr1) + + + +prop_itraverseA :: + (Index ix, Show (Array U ix Int)) => Array D ix Int -> Fun (ix, Int) Int -> Property +prop_itraverseA arr fun = + alt_imapM (\ix -> Just . applyFun2Compat fun ix) arr === + itraverseA @U (\ix -> Just . applyFun2Compat fun ix) arr + + +mapSpec :: + forall ix. + ( Arbitrary ix + , CoArbitrary ix + , Index ix + , Function ix + , Show (Array U ix Int) + , Show (Array D ix Int) + , Show (Array D ix (Int, Int)) + , Show (Array D ix (Int, Int, Int)) + ) + => Spec +mapSpec = do + describe "Zipping" $ do + it "zipUnzip" $ property $ prop_zipUnzip @ix + it "zipFlip" $ property $ prop_zipFlip @ix + it "zipUnzip3" $ property $ prop_zipUnzip3 @ix + it "zipFlip3" $ property $ prop_zipFlip3 @ix + describe "Traversing" $ + it "itraverseA" $ property $ prop_itraverseA @ix + describe "StatefulMapping" $ + it "mapWS" $ property $ prop_MapWS @ix + +spec :: Spec +spec = do + describe "Ix1" $ mapSpec @Ix1 + describe "Ix2" $ mapSpec @Ix2 + describe "Ix3" $ mapSpec @Ix3 + describe "Ix4" $ mapSpec @Ix4 + + + +alt_imapM + :: (Applicative f, Mutable r2 t1 b, Source r1 t1 t2) => + (t1 -> t2 -> f b) -> Array r1 t1 t2 -> f (Array r2 t1 b) +alt_imapM f arr = fmap loadList $ P.traverse (uncurry f) $ foldrS (:) [] (zipWithIndex arr) + where + loadList xs = + runST $ do + marr <- unsafeNew (size arr) + _ <- F.foldlM (\i e -> unsafeLinearWrite marr i e >> return (i + 1)) 0 xs + unsafeFreeze (getComp arr) marr + {-# INLINE loadList #-} + +zipWithIndex :: forall r ix e . Source r ix e => Array r ix e -> Array D ix (ix, e) +zipWithIndex arr = A.zip (range Seq zeroIndex (unSz (size arr))) arr +{-# INLINE zipWithIndex #-} + + +prop_MapWS :: (Show (Array U ix Int), Index ix) => Array U ix Int -> Property +prop_MapWS arr = + monadicIO $ + run $ do + let comp = getComp arr + count <- getCompWorkers comp + arrStates <- new @P (Sz count) + states <- initWorkerStates comp (\(WorkerId i) -> pure $ \f -> modifyM_ arrStates f i) + arr' <- + forWS states arr $ \e smod -> do + smod $ \acc -> pure (acc + e) + pure e + accsArr <- freeze Seq arrStates + pure (A.sum arr' === A.sum accsArr .&&. arr === arr') diff --git a/tests/Test/Massiv/Array/StencilSpec.hs b/tests/Test/Massiv/Array/StencilSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/Array/StencilSpec.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Massiv.Array.StencilSpec (spec) where + +import Prelude as P +import Data.Massiv.Array as A +import Data.Massiv.Array.Unsafe as A +import Test.Massiv.Core + +avg3x3Stencil :: Fractional a => Stencil Ix2 a a +avg3x3Stencil = (/9) <$> makeConvolutionStencil (Sz 3) (1 :. 1) $ \ get -> + get (-1 :. -1) 1 . get (-1 :. 0) 1 . get (-1 :. 1) 1 . + get ( 0 :. -1) 1 . get ( 0 :. 0) 1 . get ( 0 :. 1) 1 . + get ( 1 :. -1) 1 . get ( 1 :. 0) 1 . get ( 1 :. 1) 1 + + +singletonStencil :: (Index ix) => (Int -> Int) -> Stencil ix Int Int +singletonStencil f = + makeStencil oneSz zeroIndex $ \ get -> fmap f (get zeroIndex) + + +prop_MapSingletonStencil :: (Load DW ix Int, Manifest U ix Int, Show (Array U ix Int)) => + Proxy ix -> Fun Int Int -> Border Int -> ArrNE U ix Int -> Property +prop_MapSingletonStencil _ f b (ArrNE arr) = + computeAs U (mapStencil b (singletonStencil (apply f)) arr) === computeAs U (A.map (apply f) arr) + +prop_ApplyZeroStencil :: + (Load DW ix Int, Manifest U ix Int) => Proxy ix -> Int -> Array U ix Int -> Property +prop_ApplyZeroStencil _ e arr = + assertSomeException $ computeAs U (applyStencil noPadding zeroStencil arr) + where + zeroStencil = makeStencil zeroSz zeroIndex $ \_get -> pure e + + +prop_MapSingletonStencilWithStride :: + (StrideLoad DW ix Int, Manifest U ix Int, Show (Array U ix Int)) + => Proxy ix + -> Fun Int Int + -> Border Int + -> ArrNE U ix Int + -> Property +prop_MapSingletonStencilWithStride _ f b (ArrNE arr) = + computeWithStride oneStride (mapStencil b (singletonStencil (apply f)) arr) === + computeAs U (A.map (apply f) arr) + +-- Tests out of bounds stencil indexing +prop_DangerousStencil :: + Index ix => Proxy ix -> NonZero Int -> DimIx ix -> SzIx ix -> Property +prop_DangerousStencil _ (NonZero s) (DimIx r) (SzIx sz ix) = + ix' `deepseq` assertSomeException $ makeStencil sz ix $ \get -> get ix' :: Value Int + where + ix' = liftIndex (* signum s) (setDim' zeroIndex r (getDim' (unSz sz) r)) + + +instance Index ix => Show (Stencil ix a b) where + show stencil = + "Stencil " ++ show (getStencilSize stencil) ++ " " ++ show (getStencilCenter stencil) + + +prop_MapEqApplyStencil :: + (Show (Array P ix Int), StrideLoad DW ix Int) + => Stride ix + -> SzTiny ix + -> Border Int + -> Array P ix Int + -> Property +prop_MapEqApplyStencil stride (SzTiny sz) b arr = + forAll (elements (P.zip [0 ..] (toList $ A.map (\(n, _, _) -> n) stencils))) $ \(i, _) -> + let (_, stencil, g) = stencils ! i + in computeAs P (unsafeMapStencil b sz zeroIndex (const g) arr) === + computeAs P (applyStencil (samePadding stencil b) stencil arr) .&&. + computeWithStrideAs P stride (unsafeMapStencil b sz zeroIndex (const g) arr) === + computeWithStrideAs P stride (applyStencil (samePadding stencil b) stencil arr) + where + stencils = mkCommonStencils sz + +mkCommonStencils :: + (Bounded a, Num a, Ord a, Index ix) + => Sz ix + -> Array B Ix1 (String, Stencil ix a a, (ix -> a) -> a) +mkCommonStencils sz = + fromList + Seq + [ (name, stencil sz, \get -> foldlS f acc0 $ fmap get (zeroIndex ..: unSz sz)) + | (name, stencil, f, acc0) <- + [ ("maxStencil", maxStencil, max, minBound) + , ("minStencil", minStencil, min, maxBound) + , ("sumStencil", sumStencil, (+), 0) + , ("productStencil", productStencil, (*), 1) + ] + ] + +prop_FoldrStencil :: Load DW ix (Array DL Ix1 Int) => ArrNE P ix Int -> Property +prop_FoldrStencil (ArrNE arr) = + computeAs P (computeAs B folded ! zeroIndex) === A.fromList Seq (foldrS (:) [] arr) + where + folded = applyStencil noPadding (foldrStencil cons A.empty (size arr)) arr + +stencilSpec :: Spec +stencilSpec = do + describe "MapSingletonStencil" $ do + it "Ix1" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix4) + it "Ix2T" $ property $ prop_MapSingletonStencil (Proxy :: Proxy Ix2T) + describe "MapSingletonStencilWithStride" $ do + it "Ix1" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_MapSingletonStencilWithStride (Proxy :: Proxy Ix3) + describe "ApplyZeroStencil" $ do + it "Ix1" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix4) + it "Ix2T" $ property $ prop_ApplyZeroStencil (Proxy :: Proxy Ix2T) + describe "DangerousStencil" $ do + it "Ix1" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix1) + it "Ix2" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix2) + it "Ix3" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix3) + it "Ix4" $ property $ prop_DangerousStencil (Proxy :: Proxy Ix4) + describe "MapEqApplyStencil" $ do + it "Ix1" $ property $ prop_MapEqApplyStencil @Ix1 + it "Ix2" $ property $ prop_MapEqApplyStencil @Ix2 + it "Ix3" $ property $ prop_MapEqApplyStencil @Ix3 + it "Ix4" $ property $ prop_MapEqApplyStencil @Ix4 + describe "FoldrStencil" $ do + it "Ix1" $ property $ prop_FoldrStencil @Ix1 + it "Ix2" $ property $ prop_FoldrStencil @Ix2 + it "Ix3" $ property $ prop_FoldrStencil @Ix3 + it "Ix4" $ property $ prop_FoldrStencil @Ix4 + describe "Simple" $ do + it "sumStencil" $ property $ \ (arr :: Array B Ix2 Rational) border -> + computeAs N (mapStencil border avg3x3Stencil arr) === + computeAs N (applyStencil (Padding 1 1 border) (avgStencil (Sz 3)) arr) + it "sameSizeAndCenter" $ property $ \ (SzIx sz ix) -> + let stencil = makeStencil sz ix ($ Ix1 0) :: Stencil Ix1 Int Int + in getStencilSize stencil === sz .&&. getStencilCenter stencil === ix + +stencilDirection :: Ix2 -> Array U Ix2 Int -> Array U Ix2 Int +stencilDirection ix = computeAs U . mapStencil (Fill def) (makeStencil (Sz 3) (1 :. 1) $ \f -> f ix) + + +stencilCorners :: Ix2 -> Ix2 -> Array U Ix2 Int -> Array U Ix2 Int +stencilCorners ixC ix = computeAs U . mapStencil (Fill def) (makeStencil (Sz 3) ixC $ \f -> f ix) + + +stencilConvolution :: Spec +stencilConvolution = do + let xs3 :: Array U Ix1 Int + xs3 = [1, 2, 3] + xs3f f = f (-1) 1 . f 0 2 . f 1 3 + xs4 :: Array U Ix1 Int + xs4 = [1, 2, 3, 4] + xs4f f = f (-2) 1 . f (-1) 2 . f 0 3 . f 1 4 + ys :: Array U Ix1 Int + ys = [1, 2, 3, 4, 5] + ysConvXs3 = [4, 10, 16, 22, 22] + ysConvXs4 = [10, 20, 30, 34, 31] + ysCorrXs3 = [8, 14, 20, 26, 14] + ysCorrXs4 = [11, 20, 30, 40, 26] + ysConvXs4' = [4, 10, 20, 30, 34] + ysCorrXs4' = [20, 30, 40, 26, 14] + xs4f' f = f (-1) 1 . f 0 2 . f 1 3 . f 2 4 + mapStencil1 :: Stencil Ix1 Int Int -> Array U Ix1 Int -> Array U Ix1 Int + mapStencil1 s = computeAs U . mapStencil (Fill 0) s + mapStencil2 :: Stencil Ix2 Int Int -> Array U Ix2 Int -> Array U Ix2 Int + mapStencil2 s = computeAs U . mapStencil (Fill 0) s + applyStencil1 :: Stencil Ix1 Int Int -> Array U Ix1 Int -> Array U Ix1 Int + applyStencil1 s = computeAs U . applyStencil noPadding s + describe "makeConvolutionStencilFromKernel" $ do + it "1x3 map" $ mapStencil1 (makeConvolutionStencilFromKernel xs3) ys `shouldBe` ysConvXs3 + it "1x4 map" $ mapStencil1 (makeConvolutionStencilFromKernel xs4) ys `shouldBe` ysConvXs4 + it "1x3 apply" $ + applyStencil1 (makeConvolutionStencilFromKernel xs3) ys `shouldBe` + compute (extract' 1 3 ysConvXs3) + it "1x4 apply" $ + applyStencil1 (makeConvolutionStencilFromKernel xs4) ys `shouldBe` + compute (extract' 1 2 ysConvXs4) + describe "makeCorrelationStencilFromKernel" $ do + it "1x3 map" $ mapStencil1 (makeCorrelationStencilFromKernel xs3) ys `shouldBe` ysCorrXs3 + it "1x4 map" $ mapStencil1 (makeCorrelationStencilFromKernel xs4) ys `shouldBe` ysCorrXs4 + describe "makeConvolutionStencil" $ do + it "1x3" $ mapStencil1 (makeConvolutionStencil (Sz1 3) 1 xs3f) ys `shouldBe` ysConvXs3 + it "1x4" $ mapStencil1 (makeConvolutionStencil (Sz1 4) 2 xs4f) ys `shouldBe` ysConvXs4 + it "1x4" $ mapStencil1 (makeConvolutionStencil (Sz1 4) 1 xs4f') ys `shouldBe` ysConvXs4' + describe "makeCorrelationStencil" $ do + it "1x3" $ mapStencil1 (makeCorrelationStencil (Sz1 3) 1 xs3f) ys `shouldBe` ysCorrXs3 + it "1x4" $ mapStencil1 (makeCorrelationStencil (Sz1 4) 2 xs4f) ys `shouldBe` ysCorrXs4 + it "1x4" $ mapStencil1 (makeCorrelationStencil (Sz1 4) 1 xs4f') ys `shouldBe` ysCorrXs4' + describe "makeConvolutionStencil == makeConvolutionStencilFromKernel" $ do + it "Sobel Horizontal" $ + property $ \(arr :: Array U Ix2 Int) -> + mapStencil2 (makeConvolutionStencil (Sz 3) 1 sobelX) arr === + mapStencil2 (makeConvolutionStencilFromKernel sobelKernelX) arr + it "1x3" $ + property $ \(arr :: Array U Ix1 Int) -> + mapStencil1 (makeConvolutionStencil (Sz1 3) 1 xs3f) arr === + mapStencil1 (makeConvolutionStencilFromKernel xs3) arr + it "1x4" $ + property $ \(arr :: Array U Ix1 Int) -> + mapStencil1 (makeConvolutionStencil (Sz1 4) 2 xs4f) arr === + mapStencil1 (makeConvolutionStencilFromKernel xs4) arr + describe "makeCorrelationStencil == makeCorrelationStencilFromKernel" $ do + it "Sobel Horizontal" $ + property $ \(arr :: Array U Ix2 Int) -> + mapStencil2 (makeCorrelationStencil (Sz 3) 1 sobelX) arr === + mapStencil2 (makeCorrelationStencilFromKernel sobelKernelX) arr + it "1x3" $ + property $ \(arr :: Array U Ix1 Int) -> + mapStencil1 (makeCorrelationStencil (Sz1 3) 1 xs3f) arr === + mapStencil1 (makeCorrelationStencilFromKernel xs3) arr + it "1x4" $ + property $ \(arr :: Array U Ix1 Int) -> + mapStencil1 (makeCorrelationStencil (Sz1 4) 2 xs4f) arr === + mapStencil1 (makeCorrelationStencilFromKernel xs4) arr + describe "makeConvolutionStencil == makeCorrelationStencil . rotate180" $ do + it "Sobel Horizontal" $ + property $ \(arr :: Array U Ix2 Int) -> + mapStencil2 (makeConvolutionStencilFromKernel sobelKernelX) arr === + mapStencil2 (makeCorrelationStencilFromKernel (rotate180 sobelKernelX)) arr + it "1x3" $ + property $ \(arr :: Array U Ix1 Int) -> + mapStencil1 (makeConvolutionStencilFromKernel xs3) arr === + mapStencil1 (makeCorrelationStencilFromKernel (rotate180 xs3)) arr + it "1x5" $ + property $ \(arr :: Array U Ix1 Int) -> + mapStencil1 (makeConvolutionStencilFromKernel ys) arr === + mapStencil1 (makeCorrelationStencilFromKernel (rotate180 ys)) arr + +spec :: Spec +spec = do + describe "Stencil" $ do + stencilSpec + let arr = [[1, 2, 3], [4, 5, 6], [7, 8, 9]] :: Array U Ix2 Int + describe "Unit tests Ix2" $ do + it "Direction Left" $ + stencilDirection (0 :. 1) arr `shouldBe` [[2, 3, 0], [5, 6, 0], [8, 9, 0]] + it "Direction Right" $ + stencilDirection (0 :. -1) arr `shouldBe` [[0, 1, 2], [0, 4, 5], [0, 7, 8]] + it "Direction Down" $ + stencilDirection (1 :. 0) arr `shouldBe` [[4, 5, 6], [7, 8, 9], [0, 0, 0]] + it "Direction Up" $ + stencilDirection (-1 :. 0) arr `shouldBe` [[0, 0, 0], [1, 2, 3], [4, 5, 6]] + it "Direction Left/Top Corner" $ + stencilCorners (0 :. 0) (2 :. 2) arr `shouldBe` [[9, 0, 0], [0, 0, 0], [0, 0, 0]] + it "Direction Right/Top Corner" $ + stencilCorners (0 :. 2) (2 :. -2) arr `shouldBe` [[0, 0, 7], [0, 0, 0], [0, 0, 0]] + it "Direction Right/Bottom Corner" $ + stencilCorners (2 :. 2) (-2 :. -2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [0, 0, 1]] + it "Direction Left/Bottom Corner" $ + stencilCorners (2 :. 0) (-2 :. 2) arr `shouldBe` [[0, 0, 0], [0, 0, 0], [3, 0, 0]] + describe "mapStencil with stride" $ do + let kernel = [[-1, 0, 1], [0, 1, 0], [-1, 0, 1]] :: Array U Ix2 Int + stencil = makeConvolutionStencilFromKernel kernel + stride = Stride 2 + it "map stencil with stride on small array" $ + let strideArr = mapStencil (Fill 0) stencil arr + in computeWithStrideAs U stride strideArr `shouldBe` [[-4, 8], [2, 14]] + it "map stencil with stride on larger array" $ + let largeArr = makeArrayR U Seq (Sz 5) (succ . toLinearIndex (Sz 5)) + strideArr = mapStencil (Fill 0) stencil largeArr + in computeWithStrideAs U stride strideArr `shouldBe` + [[-6, 1, 14], [-13, 9, 43], [4, 21, 44]] + stencilConvolution + +sobelX :: Num e => (Ix2 -> e -> e -> e) -> e -> e +sobelX f = f (-1 :. -1) (-1) . f (-1 :. 1) 1 . + f ( 0 :. -1) (-2) . f ( 0 :. 1) 2 . + f ( 1 :. -1) (-1) . f ( 1 :. 1) 1 + +sobelKernelX :: Array U Ix2 Int +sobelKernelX = [ [-1, 0, 1] + , [-2, 0, 2] + , [-1, 0, 1] ] + +rotate180 :: (Num ix, Index ix) => Array U ix Int -> Array U ix Int +rotate180 = computeAs U . transform' (\sz -> (sz, sz)) (\(Sz sz) f ix -> f (sz - 1 - ix)) diff --git a/tests/Test/Massiv/VectorSpec.hs b/tests/Test/Massiv/VectorSpec.hs --- a/tests/Test/Massiv/VectorSpec.hs +++ b/tests/Test/Massiv/VectorSpec.hs @@ -1,123 +1,1120 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Test.Massiv.VectorSpec (spec) where - -import Control.Exception -import Data.Bits -import Data.Massiv.Array as A -import Data.Massiv.Vector as V -import qualified Data.Vector.Primitive as VP -import Data.Word -import Test.Massiv.Core - -import System.Random.MWC as MWC - -infix 4 !==!, !!==!! - -sizeException :: SizeException -> Bool -sizeException _ = True - -(!==!) :: (Eq e, Show e, Prim e, Load r Ix1 e) => V.Vector r e -> VP.Vector e -> Property -(!==!) arr vec = toPrimitiveVector (convert arr) === vec - -(!!==!!) :: (Eq e, Show e, Prim e, Source r Ix1 e) => V.Vector r e -> VP.Vector e -> Property -(!!==!!) arr vec = property $ do - eRes <- try (pure $! vec) - case eRes of - Right vec' -> toPrimitiveVector (computeSource arr) `shouldBe` vec' - Left (_exc :: ErrorCall) -> - shouldThrow (pure $! toPrimitiveVector (computeSource arr)) sizeException - -newtype SeedVector = SeedVector (VP.Vector Word32) deriving (Eq, Show) - -instance Arbitrary SeedVector where - arbitrary = SeedVector . VP.fromList <$> arbitrary - -withSeed :: forall a. SeedVector -> (forall s. MWC.Gen s -> ST s a) -> a -withSeed (SeedVector seed) f = runST $ do - gen <- MWC.initialize seed - f gen - -prop_sreplicateM :: SeedVector -> Int -> Property -prop_sreplicateM seed k = - withSeed @(V.Vector DS Word) seed (V.sreplicateM (Sz k) . uniform) - !==! withSeed seed (VP.replicateM k . uniform) - -prop_sgenerateM :: SeedVector -> Int -> Fun Int Word -> Property -prop_sgenerateM seed k f = - withSeed @(V.Vector DS Word) seed (genWith (V.sgenerateM (Sz k))) - !==! withSeed seed (genWith (VP.generateM k)) - where - genWith :: PrimMonad f => ((Int -> f Word) -> t) -> MWC.Gen (PrimState f) -> t - genWith genM gen = genM (\i -> xor (apply f i) <$> uniform gen) - - -prop_siterateNM :: SeedVector -> Int -> Word -> Property -prop_siterateNM seed k a = - withSeed @(V.Vector DS Word) seed (genWith (\action -> V.siterateNM (Sz k) action a)) - !==! withSeed seed (genWith (\action -> VP.iterateNM k action a)) - where - genWith :: PrimMonad f => ((Word -> f Word) -> t) -> MWC.Gen (PrimState f) -> t - genWith genM gen = genM (\prev -> xor prev <$> uniform gen) - - -spec :: Spec -spec = do - describe "Vector" $ do - describe "same-as-vector-package" $ do - describe "Accessors" $ do - describe "Slicing" $ do - prop "slice'" $ \i sz (arr :: Array P Ix1 Word) -> - V.slice' i sz arr !!==!! VP.slice i (unSz sz) (toPrimitiveVector arr) - prop "init'" $ \(arr :: Array P Ix1 Word) -> - V.init' arr !!==!! VP.init (toPrimitiveVector arr) - prop "tail'" $ \(arr :: Array P Ix1 Word) -> - V.tail' arr !!==!! VP.tail (toPrimitiveVector arr) - prop "take" $ \n (arr :: Array P Ix1 Word) -> - V.take (Sz n) arr !==! VP.take n (toPrimitiveVector arr) - prop "stake" $ \n (arr :: Array P Ix1 Word) -> - V.stake (Sz n) arr !==! VP.take n (toPrimitiveVector arr) - prop "drop" $ \n (arr :: Array P Ix1 Word) -> - V.drop (Sz n) arr !==! VP.drop n (toPrimitiveVector arr) - prop "sdrop" $ \n (arr :: Array P Ix1 Word) -> - V.sdrop (Sz n) arr !==! VP.drop n (toPrimitiveVector arr) - prop "sliceAt" $ \sz (arr :: Array P Ix1 Word) -> - let (larr, rarr) = V.sliceAt (Sz sz) arr - (lvec, rvec) = VP.splitAt sz (toPrimitiveVector arr) - in (larr !==! lvec) .&&. (rarr !==! rvec) - describe "Constructors" $ do - describe "Initialization" $ do - it "empty" $ toPrimitiveVector (V.empty :: V.Vector P Word) `shouldBe` VP.empty - prop "singleton" $ \e -> (V.singleton e :: V.Vector P Word) !==! VP.singleton e - prop "ssingleton" $ \(e :: Word) -> V.ssingleton e !==! VP.singleton e - prop "replicate" $ \comp k (e :: Word) -> V.replicate comp (Sz k) e !==! VP.replicate k e - prop "sreplicate" $ \k (e :: Word) -> V.sreplicate (Sz k) e !==! VP.replicate k e - prop "generate" $ \comp k (f :: Fun Int Word) -> - V.generate comp (Sz k) (apply f) !==! VP.generate k (apply f) - prop "sgenerate" $ \k (f :: Fun Int Word) -> - V.sgenerate (Sz k) (apply f) !==! VP.generate k (apply f) - prop "siterateN" $ \n (f :: Fun Word Word) a -> - V.siterateN (Sz n) (apply f) a !==! VP.iterateN n (apply f) a - describe "Monadic initialization" $ do - prop "sreplicateM" prop_sreplicateM - prop "sgenerateM" prop_sgenerateM - prop "siterateNM" prop_siterateNM - describe "Unfolding" $ do - prop "sunfoldr" $ \(a :: Word) -> - let f b - | b > 10000 || b `div` 17 == 0 = Nothing - | otherwise = Just (b * b, b + 1) - in V.sunfoldr f a !==! VP.unfoldr f a - prop "sunfoldrN" $ \n (a :: Word) -> - let f b - | b > 10000 || b `div` 19 == 0 = Nothing - | otherwise = Just (b * b, b + 1) - in V.sunfoldrN (Sz n) f a !==! VP.unfoldrN n f a +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Test.Massiv.VectorSpec (spec) where + +import Control.Arrow (first) +import Control.Applicative +import Control.DeepSeq +import Control.Exception +import Data.Bits +import Data.Int +import qualified Data.Tuple as Tuple +import qualified Data.List as List +import Data.Massiv.Array as A +import Data.Massiv.Array.Unsafe as A +import Data.Massiv.Vector as V +import Data.Maybe +import Data.Primitive.MutVar +import qualified Data.Vector as VB +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Data.Word +import Test.Massiv.Core + +import System.Random.MWC as MWC + +infix 4 !==!, !!==!! + +sizeException :: SizeException -> Bool +sizeException exc = exc `deepseq` True + +toUnboxV2 :: + Unbox e1 + => (VU.Vector e2 -> VU.Vector e3 -> VU.Vector e1) + -> Array U ix1 e2 + -> Array U ix2 e3 + -> Array U Ix1 e1 +toUnboxV2 f v1 v2 = fromUnboxedVector (f (toUnboxedVector v1) (toUnboxedVector v2)) + +toUnboxV3 :: + Unbox e1 + => (VU.Vector e -> VU.Vector e2 -> VU.Vector e3 -> VU.Vector e1) + -> Array U ix e + -> Array U ix1 e2 + -> Array U ix2 e3 + -> Array U Ix1 e1 +toUnboxV3 f v1 = toUnboxV2 (f (toUnboxedVector v1)) + +toUnboxV4 :: + Unbox e1 + => (VU.Vector e2 -> VU.Vector e3 -> VU.Vector e4 -> VU.Vector e5 -> VU.Vector e1) + -> Array U ix1 e2 + -> Array U ix2 e3 + -> Array U ix3 e4 + -> Array U ix4 e5 + -> Array U Ix1 e1 +toUnboxV4 f v1 = toUnboxV3 (f (toUnboxedVector v1)) + +toUnboxV5 :: + Unbox e1 + => (VU.Vector e2 -> VU.Vector e3 -> VU.Vector e4 -> VU.Vector e5 -> VU.Vector e6 -> VU.Vector e1) + -> Array U ix1 e2 + -> Array U ix2 e3 + -> Array U ix3 e4 + -> Array U ix4 e5 + -> Array U ix5 e6 + -> Array U Ix1 e1 +toUnboxV5 f v1 = toUnboxV4 (f (toUnboxedVector v1)) + +toUnboxV6 :: + Unbox e1 + => (VU.Vector e2 -> VU.Vector e3 -> VU.Vector e4 -> VU.Vector e5 -> VU.Vector e6 -> VU.Vector e7 -> VU.Vector e1) + -> Array U ix1 e2 + -> Array U ix2 e3 + -> Array U ix3 e4 + -> Array U ix4 e5 + -> Array U ix5 e6 + -> Array U ix6 e7 + -> Array U Ix1 e1 +toUnboxV6 f v1 = toUnboxV5 (f (toUnboxedVector v1)) + +toPrimV2 :: (Index ix) => (VP.Vector e1 -> VP.Vector e2 -> t) -> Array P ix e1 -> Array P ix e2 -> t +toPrimV2 f v1 v2 = f (toPrimitiveVector v1) (toPrimitiveVector v2) + +toPrimV3 :: + Index ix + => (VP.Vector e -> VP.Vector e1 -> VP.Vector e2 -> t) + -> Array P ix e + -> Array P ix e1 + -> Array P ix e2 + -> t +toPrimV3 f v1 = toPrimV2 (f (toPrimitiveVector v1)) + +toPrimV4 :: + Index ix + => (VP.Vector e1 -> VP.Vector e2 -> VP.Vector e3 -> VP.Vector e4 -> t) + -> Array P ix e1 + -> Array P ix e2 + -> Array P ix e3 + -> Array P ix e4 + -> t +toPrimV4 f v1 = toPrimV3 (f (toPrimitiveVector v1)) + +toPrimV5 :: + Index ix + => (VP.Vector e -> VP.Vector e1 -> VP.Vector e2 -> VP.Vector e3 -> VP.Vector e4 -> t) + -> Array P ix e + -> Array P ix e1 + -> Array P ix e2 + -> Array P ix e3 + -> Array P ix e4 + -> t +toPrimV5 f v1 = toPrimV4 (f (toPrimitiveVector v1)) + +toPrimV6 :: + Index ix + => (VP.Vector e -> VP.Vector e1 -> VP.Vector e2 -> VP.Vector e3 -> VP.Vector e4 -> VP.Vector e5 -> t) + -> Array P ix e + -> Array P ix e1 + -> Array P ix e2 + -> Array P ix e3 + -> Array P ix e4 + -> Array P ix e5 + -> t +toPrimV6 f v1 = toPrimV5 (f (toPrimitiveVector v1)) + + +(!==!) :: (Eq e, Show e, Prim e, Load r Ix1 e) => V.Vector r e -> VP.Vector e -> Property +(!==!) arr vec = toPrimitiveVector (convert arr) === vec + +(!!==!!) :: (Eq e, Show e, Prim e, Source r Ix1 e) => V.Vector r e -> VP.Vector e -> Property +(!!==!!) arr vec = property $ do + eRes <- try (pure $! vec) + case eRes of + Right vec' -> toPrimitiveVector (computeSource arr) `shouldBe` vec' + Left (_exc :: ErrorCall) -> + shouldThrow (pure $! computeAs P arr) sizeException + +newtype SeedVector = SeedVector (VP.Vector Word32) deriving (Eq, Show) + +instance Arbitrary SeedVector where + arbitrary = SeedVector . VP.fromList <$> arbitrary + +withSeed :: forall a. SeedVector -> (forall s. MWC.Gen s -> ST s a) -> a +withSeed (SeedVector seed) f = runST $ MWC.initialize seed >>= f + +withSeed2 :: + forall a. (Eq a, Show a) + => SeedVector + -> (forall s. MWC.Gen s -> ST s a) + -> (forall s. MWC.Gen s -> ST s a) + -> Property +withSeed2 seed f g = withSeed @a seed f === withSeed seed g + +withSeedV2 :: + forall r e. (Eq e, Show e, Prim e, Load r Ix1 e) + => SeedVector + -> (forall s. MWC.Gen s -> ST s (V.Vector r e)) + -> (forall s. MWC.Gen s -> ST s (VP.Vector e)) + -> Property +withSeedV2 seed f g = withSeed @(V.Vector r e) seed f !==! withSeed seed g + + +prop_sreplicateM :: SeedVector -> Int -> Property +prop_sreplicateM seed k = withSeedV2 @DS @Word seed + (V.sreplicateM (Sz k) . uniform) + (VP.replicateM k . uniform) + +prop_sgenerateM :: SeedVector -> Int -> Fun Int Word -> Property +prop_sgenerateM seed k f = withSeedV2 @DS @Word seed + (genWith (V.sgenerateM (Sz k))) + (genWith (VP.generateM k)) + where + genWith :: PrimMonad f => ((Int -> f Word) -> t) -> MWC.Gen (PrimState f) -> t + genWith genM gen = genM (\i -> xor (apply f i) <$> uniform gen) + + +prop_siterateNM :: SeedVector -> Int -> Word -> Property +prop_siterateNM seed k a = + withSeed @(V.Vector DS Word) seed (genWith (\f -> V.siterateNM (Sz k) f a)) + !==! withSeed seed (genWith (\f -> VP.iterateNM k f a)) + where + genWith :: PrimMonad f => ((Word -> f Word) -> t) -> MWC.Gen (PrimState f) -> t + genWith genM gen = genM (\prev -> xor prev <$> uniform gen) + + +genWithUnfoldrM :: + PrimMonad f => ((Word -> f (Maybe (Word, Word))) -> t) -> MWC.Gen (PrimState f) -> t +genWithUnfoldrM genM gen = genM $ \prev -> do + x <- uniform gen + let cur = prev `xor` x + pure $ if cur `mod` 17 == 0 then Nothing else Just (x, cur) + +prop_sunfoldrM :: SeedVector -> Word -> Property +prop_sunfoldrM seed a = + withSeedV2 @DS @Word seed + (genWithUnfoldrM (`V.sunfoldrM` a)) + (genWithUnfoldrM (`VP.unfoldrM`a)) + +prop_sunfoldrNM :: SeedVector -> Int -> Word -> Property +prop_sunfoldrNM seed k a = + withSeedV2 @DS @Word seed + (genWithUnfoldrM (\f -> V.sunfoldrNM (Sz k) f a)) + (genWithUnfoldrM (\f -> VP.unfoldrNM k f a)) + .&&. + withSeedV2 @DS @Word seed + (genWithUnfoldrM (\f -> A.unsafeUnfoldrNM (Sz k) f a)) + (genWithUnfoldrM (\f -> VP.unfoldrNM k f a)) + +prop_sunfoldrExactNM :: SeedVector -> Int -> Word -> Property +prop_sunfoldrExactNM seed k a = + withSeedV2 @DS @Word seed + (genWith (\f -> V.sunfoldrExactNM (Sz k) f a)) + (genWith (\f -> VP.unfoldrNM k (fmap Just . f) a)) + where + genWith :: PrimMonad f => ((Word -> f (Word, Word)) -> t) -> MWC.Gen (PrimState f) -> t + genWith genM gen = genM $ \prev -> do + x <- uniform gen + pure (x, prev `xor` x) + + +genWithMapM :: PrimMonad m => ((Word -> m Word) -> m a) -> MWC.Gen (PrimState m) -> m a +genWithMapM genM gen = genM $ \e -> xor e <$> uniform gen +genWithMapWS :: PrimMonad m => ((Word -> MWC.Gen (PrimState m) -> m Word) -> m a) -> m a +genWithMapWS genM = genM $ \e gen -> xor e <$> uniform gen + +genWithIMapM :: PrimMonad m => ((Int -> Word -> m Word) -> m a) -> MWC.Gen (PrimState m) -> m a +genWithIMapM genM gen = genM $ \i e -> do + ir <- uniformR (0, fromIntegral i) gen + xor ir . xor e <$> uniform gen +genWithIMapWS :: PrimMonad m => ((Int -> Word -> MWC.Gen (PrimState m) -> m Word) -> m a) -> m a +genWithIMapWS genM = + genM $ \i e gen -> do + ir <- uniformR (0, fromIntegral i) gen + xor ir . xor e <$> uniform gen + + +genWithMapM_ :: PrimMonad m => ((Word -> m ()) -> m ()) -> MWC.Gen (PrimState m) -> m Word +genWithMapM_ genM gen = do + ref <- newMutVar =<< uniform gen + genM $ \e -> do + e' <- xor e <$> uniform gen + modifyMutVar ref (xor e') + readMutVar ref + +genWithIMapM_ :: PrimMonad m => ((Int -> Word -> m ()) -> m ()) -> MWC.Gen (PrimState m) -> m Word +genWithIMapM_ genM gen = do + ref <- newMutVar =<< uniform gen + genM $ \i e -> do + ir <- uniformR (0, fromIntegral i) gen + e' <- xor ir . xor e <$> uniform gen + modifyMutVar ref (xor e') + readMutVar ref + +prop_straverse :: SeedVector -> Array P Ix2 Word -> Property +prop_straverse seed a = + withSeed @(V.Vector DS Word) seed (genWithMapM (`V.straverse` a)) + !==! withSeed seed (genWithMapM (`VP.mapM` toPrimitiveVector a)) + +prop_smapM :: SeedVector -> Array P Ix2 Word -> Property +prop_smapM seed a = + withSeed @(V.Vector DS Word) seed (genWithMapM (`V.smapM` a)) + !==! withSeed seed (genWithMapM (`VP.mapM` toPrimitiveVector a)) + +prop_smapMaybeM :: SeedVector -> Array B Ix2 Word -> Fun Word (Maybe Word16) -> Property +prop_smapMaybeM seed a gm = + withSeed @(V.Vector DS Word16) seed (genWithMapM (\ f -> V.smapMaybeM (fmap g . f) a)) + !==! withSeed seed (genWithMapM + (\f -> VP.convert . VB.mapMaybe id <$> VB.mapM (fmap g . f) (toBoxedVector a))) + where g = apply gm + +prop_sitraverse :: SeedVector -> Vector P Word -> Property +prop_sitraverse seed a = + withSeed @(V.Vector DS Word) seed (genWithIMapM (`V.sitraverse` a)) + !==! withSeed seed (genWithIMapM (\f -> VP.convert <$> VU.mapM (uncurry f) vp)) + where + vp = VU.imap (,) $ toUnboxedVector (compute a) + +prop_simapM :: SeedVector -> Vector U Word -> Property +prop_simapM seed a = + withSeed @(V.Vector DS Word) seed (genWithIMapM (V.siforM a)) + !==! withSeed seed (genWithIMapM (\f -> VP.convert <$> VU.mapM (uncurry f) vp)) + where + vp = VU.imap (,) $ toUnboxedVector a + +prop_smapM_ :: SeedVector -> Array P Ix2 Word -> Property +prop_smapM_ seed a = + withSeed seed (genWithMapM_ (V.sforM_ a)) === + withSeed seed (genWithMapM_ (VP.forM_ (toPrimitiveVector a))) + +prop_simapM_ :: SeedVector -> Vector U Word -> Property +prop_simapM_ seed a = + withSeed seed (genWithIMapM_ (V.siforM_ a)) === + withSeed seed (genWithIMapM_ (\f -> VU.mapM_ (uncurry f) vp)) + where + vp = VU.imap (,) $ toUnboxedVector a + +prop_sfilterM :: SeedVector -> Fun Word Bool -> Vector P Word -> Property +prop_sfilterM seed g a = + withSeed @(V.Vector DS Word) seed (genWith (`V.sfilterM` a)) + !==! withSeed seed (genWith (`VP.filterM` toPrimitiveVector a)) + where + genWith :: PrimMonad f => ((Word -> f Bool) -> t) -> MWC.Gen (PrimState f) -> t + genWith genM gen = genM $ \e -> do + x <- xor e <$> uniform gen + pure $ apply g x + +prop_sifilterM :: SeedVector -> Fun Word Bool -> Vector U Word -> Property +prop_sifilterM seed g a = + withSeed @(V.Vector DS Word) seed (genWith (`V.sifilterM` a)) + !==! withSeed seed (genWith (\f -> VP.convert . VU.map snd <$> VU.filterM (uncurry f) vp)) + where + vp = VU.imap (,) $ toUnboxedVector a + genWith :: PrimMonad f => ((Int -> Word -> f Bool) -> t) -> MWC.Gen (PrimState f) -> t + genWith genM gen = genM $ \i e -> do + ir <- uniformR (0, fromIntegral i) gen + x <- xor ir . xor e <$> uniform gen + pure $ apply g x + + + +applyFun4 :: Fun (a, b, c, d) e -> (a -> b -> c -> d -> e) +applyFun4 (Fun _ f) a b c d = f (a, b, c, d) +applyFun5 :: Fun (a, b, c, d, e) f -> (a -> b -> c -> d -> e -> f) +applyFun5 (Fun _ g) a b c d f = g (a, b, c, d, f) +applyFun6 :: Fun (a, (b, c, d, e, f)) g -> (a -> b -> c -> d -> e -> f -> g) +applyFun6 (Fun _ h) a b c d f g = h (a, (b, c, d, f, g)) +applyFun7 :: Fun (a, b, (c, d, e, f, g)) h -> (a -> b -> c -> d -> e -> f -> g -> h) +applyFun7 (Fun _ i) a b c d f g h = i (a, b, (c, d, f, g, h)) + +com2M :: Fun (a, b) d -> (d -> c) -> a -> b -> c +com2M f g a = g . applyFun2 f a + +com3M :: Fun (a, b, c) d -> (d -> e) -> a -> b -> c -> e +com3M f g a b = g . applyFun3 f a b + +com4M :: Fun (a, b, c, d) e -> (e -> h) -> a -> b -> c -> d -> h +com4M f g a b c = g . applyFun4 f a b c + +com5M :: Fun (a, b, c, d, e) h -> (h -> i) -> a -> b -> c -> d -> e -> i +com5M f g a b c d = g . applyFun5 f a b c d + +com6M :: Fun (a, (b, c, d, e, h)) i -> (i -> j) -> a -> b -> c -> d -> e -> h -> j +com6M f g a b c d e = g . applyFun6 f a b c d e + +com7M :: Fun (a, b, (c, d, e, h, i)) j -> (j -> k) -> a -> b -> c -> d -> e -> h -> i -> k +com7M f g a b c d e h = g . applyFun7 f a b c d e h + + +prop_szip :: Vector U Word -> Vector U Int -> Property +prop_szip v1 v2 = compute (V.szip v1 v2) === toUnboxV2 VU.zip v1 v2 + +prop_szip3 :: Vector U Word64 -> Vector U Word32 -> Vector U Word16 -> Property +prop_szip3 v1 v2 v3 = compute (V.szip3 v1 v2 v3) === toUnboxV3 VU.zip3 v1 v2 v3 + +prop_szip4 :: Vector U Word64 -> Vector U Word32 -> Vector U Word16 -> Vector U Word8 -> Property +prop_szip4 v1 v2 v3 v4 = compute (V.szip4 v1 v2 v3 v4) === toUnboxV4 VU.zip4 v1 v2 v3 v4 + +prop_szip5 :: + Vector U Word64 + -> Vector U Word32 + -> Vector U Word16 + -> Vector U Word8 + -> Vector U Int8 + -> Property +prop_szip5 v1 v2 v3 v4 v5 = compute (V.szip5 v1 v2 v3 v4 v5) === toUnboxV5 VU.zip5 v1 v2 v3 v4 v5 + +prop_szip6 :: + Vector U Word64 + -> Vector U Word32 + -> Vector U Word16 + -> Vector U Word8 + -> Vector U Int8 + -> Vector U Int16 + -> Property +prop_szip6 v1 v2 v3 v4 v5 v6 = + compute (V.szip6 v1 v2 v3 v4 v5 v6) === toUnboxV6 VU.zip6 v1 v2 v3 v4 v5 v6 + + +prop_szipWith :: Vector P Word -> Vector P Int -> Fun (Word, Int) Int -> Property +prop_szipWith v1 v2 f = + V.szipWith (applyFun2 f) v1 v2 !==! toPrimV2 (VP.zipWith (applyFun2 f)) v1 v2 + +prop_szipWith3 :: + Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Fun (Word64, Word32, Word16) Int + -> Property +prop_szipWith3 v1 v2 v3 f = + V.szipWith3 (applyFun3 f) v1 v2 v3 !==! toPrimV3 (VP.zipWith3 (applyFun3 f)) v1 v2 v3 + +prop_szipWith4 :: + Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Fun (Word64, Word32, Word16, Word8) Int + -> Property +prop_szipWith4 v1 v2 v3 v4 f = + V.szipWith4 (applyFun4 f) v1 v2 v3 v4 !==! toPrimV4 (VP.zipWith4 (applyFun4 f)) v1 v2 v3 v4 + +prop_szipWith5 :: + Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Word64, Word32, Word16, Word8, Int8) Int + -> Property +prop_szipWith5 v1 v2 v3 v4 v5 f = + V.szipWith5 (applyFun5 f) v1 v2 v3 v4 v5 !==! toPrimV5 (VP.zipWith5 (applyFun5 f)) v1 v2 v3 v4 v5 + +prop_szipWith6 :: + Vector DS Word64 + -> Vector B Word32 + -> Vector N Word16 + -> Vector S Word8 + -> Vector U Int8 + -> Vector P Int16 + -> Fun (Word64, (Word32, Word16, Word8, Int8, Int16)) Int + -> Property +prop_szipWith6 v1 v2 v3 v4 v5 v6 f = + V.szipWith6 (applyFun6 f) v1 v2 v3 v4 v5 v6 !==! + toPrimV6 + (VP.zipWith6 (applyFun6 f)) + (compute v1) + (compute v2) + (compute v3) + (compute v4) + (compute v5) + v6 + +prop_sizipWith :: Vector DS Word64 -> Vector DS Word32 -> Fun (Ix1, Word64, Word32) Int -> Property +prop_sizipWith v1 v2 f = + sizipWith (applyFun3 f) v1 v2 !==! + toPrimV2 (VP.izipWith (applyFun3 f)) (compute v1) (compute v2) + +prop_sizipWith3 :: + Vector P Word64 + -> Vector D Word32 + -> Vector D Word16 + -> Fun (Ix1, Word64, Word32, Word16) Int + -> Property +prop_sizipWith3 v1 v2 v3 f = + sizipWith3 (applyFun4 f) v1 v2 v3 !==! + toPrimV3 (VP.izipWith3 (applyFun4 f)) (compute v1) (compute v2) (compute v3) + +prop_sizipWith4 :: + Vector D Word64 + -> Vector DS Word32 + -> Vector P Word16 + -> Vector U Word8 + -> Fun (Ix1, Word64, Word32, Word16, Word8) Int + -> Property +prop_sizipWith4 v1 v2 v3 v4 f = + sizipWith4 (applyFun5 f) v1 v2 v3 v4 !==! + toPrimV4 (VP.izipWith4 (applyFun5 f)) (compute v1) (compute v2) (compute v3) (compute v4) + +prop_sizipWith5 :: + Vector DS Word64 + -> Vector S Word32 + -> Vector P Word16 + -> Vector U Word8 + -> Vector N Int8 + -> Fun (Ix1, (Word64, Word32, Word16, Word8, Int8)) Int + -> Property +prop_sizipWith5 v1 v2 v3 v4 v5 f = + sizipWith5 (applyFun6 f) v1 v2 v3 v4 v5 !==! + toPrimV5 (VP.izipWith5 (applyFun6 f)) (compute v1) (compute v2) v3 (compute v4) (compute v5) + +prop_sizipWith6 :: + Vector DS Word64 + -> Vector D Word32 + -> Vector B Word16 + -> Vector N Word8 + -> Vector P Int8 + -> Vector P Int16 + -> Fun (Ix1, Word64, (Word32, Word16, Word8, Int8, Int16)) Int + -> Property +prop_sizipWith6 v1 v2 v3 v4 v5 v6 f = + sizipWith6 (applyFun7 f) v1 v2 v3 v4 v5 v6 !==! + toPrimV6 (VP.izipWith6 (applyFun7 f)) (compute v1) (compute v2) (compute v3) (compute v4) v5 v6 + + +prop_szipWithM :: + SeedVector -> Vector P Word64 -> Vector P Word32 -> Fun (Word64, Word32) Word -> Property +prop_szipWithM seed v1 v2 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.szipWithM (com2M f g) v1 v2)) + (genWithMapM (\g -> toPrimV2 (VP.zipWithM (com2M f g)) v1 v2)) + +prop_szipWith3M :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Fun (Word64, Word32, Word16) Word + -> Property +prop_szipWith3M seed v1 v2 v3 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.szipWith3M (com3M f g) v1 v2 v3)) + (genWithMapM (VP.forM (toPrimV3 (VP.zipWith3 (applyFun3 f)) v1 v2 v3))) + +prop_szipWith4M :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Fun (Word64, Word32, Word16, Word8) Word + -> Property +prop_szipWith4M seed v1 v2 v3 v4 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.szipWith4M (com4M f g) v1 v2 v3 v4)) + (genWithMapM (VP.forM (toPrimV4 (VP.zipWith4 (applyFun4 f)) v1 v2 v3 v4))) + + +prop_szipWith5M :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Word64, Word32, Word16, Word8, Int8) Word + -> Property +prop_szipWith5M seed v1 v2 v3 v4 v5 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.szipWith5M (com5M f g) v1 v2 v3 v4 v5)) + (genWithMapM (VP.forM (toPrimV5 (VP.zipWith5 (applyFun5 f)) v1 v2 v3 v4 v5))) + + +prop_szipWith6M :: + SeedVector + -> Vector P Int16 + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Int16, (Word64, Word32, Word16, Word8, Int8)) Word + -> Property +prop_szipWith6M seed v1 v2 v3 v4 v5 v6 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.szipWith6M (com6M f g) v1 v2 v3 v4 v5 v6)) + (genWithMapM (VP.forM (toPrimV6 (VP.zipWith6 (applyFun6 f)) v1 v2 v3 v4 v5 v6))) + + +prop_szipWithM_ :: + SeedVector -> Vector P Word64 -> Vector P Word32 -> Fun (Word64, Word32) Word -> Property +prop_szipWithM_ seed v1 v2 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.szipWithM_ (com2M f g) v1 v2)) + (genWithMapM_ (\g -> toPrimV2 (VP.zipWithM_ (com2M f g)) v1 v2)) + +prop_szipWith3M_ :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Fun (Word64, Word32, Word16) Word + -> Property +prop_szipWith3M_ seed v1 v2 v3 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.szipWith3M_ (com3M f g) v1 v2 v3)) + (genWithMapM_ (VP.forM_ (toPrimV3 (VP.zipWith3 (applyFun3 f)) v1 v2 v3))) + +prop_szipWith4M_ :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Fun (Word64, Word32, Word16, Word8) Word + -> Property +prop_szipWith4M_ seed v1 v2 v3 v4 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.szipWith4M_ (com4M f g) v1 v2 v3 v4)) + (genWithMapM_ (VP.forM_ (toPrimV4 (VP.zipWith4 (applyFun4 f)) v1 v2 v3 v4))) + + +prop_szipWith5M_ :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Word64, Word32, Word16, Word8, Int8) Word + -> Property +prop_szipWith5M_ seed v1 v2 v3 v4 v5 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.szipWith5M_ (com5M f g) v1 v2 v3 v4 v5)) + (genWithMapM_ (VP.forM_ (toPrimV5 (VP.zipWith5 (applyFun5 f)) v1 v2 v3 v4 v5))) + +prop_szipWith6M_ :: + SeedVector + -> Vector P Int16 + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Int16, (Word64, Word32, Word16, Word8, Int8)) Word + -> Property +prop_szipWith6M_ seed v1 v2 v3 v4 v5 v6 f = + withSeed2 seed + (genWithMapM_ (\g -> V.szipWith6M_ (com6M f g) v1 v2 v3 v4 v5 v6)) + (genWithMapM_ (VP.forM_ (toPrimV6 (VP.zipWith6 (applyFun6 f)) v1 v2 v3 v4 v5 v6))) + +prop_sizipWithM :: + SeedVector -> Vector U Word64 -> Vector U Word32 -> Fun (Ix1, Word64, Word32) Word -> Property +prop_sizipWithM seed v1 v2 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.sizipWithM (com3M f g) v1 v2)) + (genWithMapM (\g -> VP.convert <$> + VU.izipWithM (com3M f g) (toUnboxedVector v1) (toUnboxedVector v2))) + +prop_sizipWith3M :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Fun (Ix1, Word64, Word32, Word16) Word + -> Property +prop_sizipWith3M seed v1 v2 v3 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.sizipWith3M (com4M f g) v1 v2 v3)) + (genWithMapM (VP.forM (toPrimV3 (VP.izipWith3 (applyFun4 f)) v1 v2 v3))) + +prop_sizipWith4M :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Fun (Ix1, Word64, Word32, Word16, Word8) Word + -> Property +prop_sizipWith4M seed v1 v2 v3 v4 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.sizipWith4M (com5M f g) v1 v2 v3 v4)) + (genWithMapM (VP.forM (toPrimV4 (VP.izipWith4 (applyFun5 f)) v1 v2 v3 v4))) + +prop_sizipWith5M :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Ix1, (Word64, Word32, Word16, Word8, Int8)) Word + -> Property +prop_sizipWith5M seed v1 v2 v3 v4 v5 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.sizipWith5M (com6M f g) v1 v2 v3 v4 v5)) + (genWithMapM (VP.forM (toPrimV5 (VP.izipWith5 (applyFun6 f)) v1 v2 v3 v4 v5))) + + +prop_sizipWith6M :: + SeedVector + -> Vector P Int16 + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Ix1, Int16, (Word64, Word32, Word16, Word8, Int8)) Word + -> Property +prop_sizipWith6M seed v1 v2 v3 v4 v5 v6 f = + withSeedV2 @DS @Word seed + (genWithMapM (\g -> V.sizipWith6M (com7M f g) v1 v2 v3 v4 v5 v6)) + (genWithMapM (VP.forM (toPrimV6 (VP.izipWith6 (applyFun7 f)) v1 v2 v3 v4 v5 v6))) + + +prop_sizipWithM_ :: + SeedVector -> Vector U Word64 -> Vector U Word32 -> Fun (Ix1, Word64, Word32) Word -> Property +prop_sizipWithM_ seed v1 v2 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.sizipWithM_ (com3M f g) v1 v2)) + (genWithMapM_ (\g -> VU.izipWithM_ (com3M f g) (toUnboxedVector v1) (toUnboxedVector v2))) + +prop_sizipWith3M_ :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Fun (Ix1, Word64, Word32, Word16) Word + -> Property +prop_sizipWith3M_ seed v1 v2 v3 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.sizipWith3M_ (com4M f g) v1 v2 v3)) + (genWithMapM_ (VP.forM_ (toPrimV3 (VP.izipWith3 (applyFun4 f)) v1 v2 v3))) + +prop_sizipWith4M_ :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Fun (Ix1, Word64, Word32, Word16, Word8) Word + -> Property +prop_sizipWith4M_ seed v1 v2 v3 v4 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.sizipWith4M_ (com5M f g) v1 v2 v3 v4)) + (genWithMapM_ (VP.forM_ (toPrimV4 (VP.izipWith4 (applyFun5 f)) v1 v2 v3 v4))) + + +prop_sizipWith5M_ :: + SeedVector + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Ix1, (Word64, Word32, Word16, Word8, Int8)) Word + -> Property +prop_sizipWith5M_ seed v1 v2 v3 v4 v5 f = + withSeed2 + seed + (genWithMapM_ (\g -> V.sizipWith5M_ (com6M f g) v1 v2 v3 v4 v5)) + (genWithMapM_ (VP.forM_ (toPrimV5 (VP.izipWith5 (applyFun6 f)) v1 v2 v3 v4 v5))) + + +prop_sizipWith6M_ :: + SeedVector + -> Vector P Int16 + -> Vector P Word64 + -> Vector P Word32 + -> Vector P Word16 + -> Vector P Word8 + -> Vector P Int8 + -> Fun (Ix1, Int16, (Word64, Word32, Word16, Word8, Int8)) Word + -> Property +prop_sizipWith6M_ seed v1 v2 v3 v4 v5 v6 f = + withSeed2 seed + (genWithMapM_ (\g -> V.sizipWith6M_ (com7M f g) v1 v2 v3 v4 v5 v6)) + (genWithMapM_ (VP.forM_ (toPrimV6 (VP.izipWith6 (applyFun7 f)) v1 v2 v3 v4 v5 v6))) + +spec :: Spec +spec = + describe "Vector" $ do + describe "same-as-array" $ do + describe "traverse" $ do + prop "straverse == traversePrim" prop_straverse_traversePrim + prop "sitraverse == itraversePrim" prop_sitraverse_itraversePrim + prop "sitraverse == itraverseA" prop_sitraverse_itraverseA + prop "simapM_ == itraverseA_" prop_simapM_itraverseA_ + prop "smapM_ == traverseA_" prop_smapM_traverseA_ + prop "sforM == forM" prop_sforM_forM + prop "siforM == iforM" prop_siforM_iforM + prop "sforM_ == forM_" prop_sforM_forM_ + prop "siforM_ == iforM_" prop_siforM_iforM_ + prop "sforM_ == forIO_ (ParN 1)" prop_sforM_forIO_ + prop "sforM == forIO (Seq)" prop_sforM_forIO + prop "siforM == iforIO (ParN 1)" prop_siforM_iforIO + prop "siforM == iforIO_ (ParN 1)" prop_siforM_iforIO_ + prop "siforM == iforWS (ParN 1)" prop_siforM_iforWS + prop "smapM == mapWS (Seq)" prop_smapM_mapWS + describe "Enumeration" $ do + prop "senumFromN" $ \comp (i :: Int) sz -> + computeAs S (V.senumFromN i sz) === compute (A.enumFromN comp i sz) + prop "senumFromStepN" $ \comp (i :: Int) s sz -> + computeAs S (V.senumFromStepN i s sz) === compute (A.enumFromStepN comp i s sz) + describe "same-as-vector-package" $ do + describe "Accessors" $ do + describe "Size" $ do + it "slength" $ do + slength (sfromList []) `shouldBe` Nothing + slength (sfromListN 1 []) `shouldBe` Nothing + slength (sgenerate 1 id) `shouldBe` Just 1 + it "snull" $ do + snull sempty `shouldBe` True + snull (fromLists' Seq [[]] :: Array P Ix2 Int) `shouldBe` True + snull (siterateN 3 id ()) `shouldBe` False + snull (0 ..: 1 :> 2 :> 3 :. 0) `shouldBe` True + describe "Indexing" $ do + prop "head' (non-empty)" $ \(ArrNE arr :: ArrNE D Ix1 Int) -> + head' arr === evaluate' arr 0 .&&. head' arr === shead' arr + prop "head'" $ \(arr :: Array D Ix1 Int) -> + (singleton (head' arr) :: Array D Ix1 Int) !!==!! + VP.singleton (VP.head (toPrimitiveVector (compute arr))) + prop "shead'" $ \(arr :: Array P Ix1 Int) -> + (singleton (shead' arr) :: Array D Ix1 Int) !!==!! + VP.singleton (VP.head (toPrimitiveVector arr)) + prop "last'" $ \(arr :: Array P Ix1 Int) -> + (singleton (last' arr) :: Array D Ix1 Int) !!==!! + VP.singleton (VP.last (toPrimitiveVector arr)) + prop "unconsM" $ \(v :: Vector D Int) -> + fmap (computeAs P <$>) (A.unconsM v :: Maybe (Int, Vector D Int)) === + fmap (fmap (A.fromList Seq)) (List.uncons (A.toList v)) + prop "unsnocM" $ \(v :: Vector D Int) -> + fmap (first (computeAs P)) (A.unsnocM v :: Maybe (Vector D Int, Int)) === + fmap + (Tuple.swap . fmap (A.fromList Seq . List.reverse)) + (List.uncons (A.toList (A.reverse Dim1 v))) + describe "Slicing" $ do + prop "slice" $ \i sz (arr :: Array P Ix1 Word) -> + V.slice i sz arr !!==!! VP.take (unSz sz) (VP.drop i (toPrimitiveVector arr)) + prop "sslice" $ \i sz (arr :: Array P Ix1 Word) -> + computeAs B (V.sslice i sz arr) !!==!! + VP.take (unSz sz) (VP.drop i (toPrimitiveVector arr)) + prop "slice'" $ \i sz (arr :: Array P Ix1 Word) -> + V.slice' i sz arr !!==!! VP.slice i (unSz sz) (toPrimitiveVector arr) + prop "init" $ \(arr :: Array P Ix1 Word) -> + V.init arr !==! VP.reverse (VP.drop 1 (VP.reverse (toPrimitiveVector arr))) + prop "init'" $ \(arr :: Array P Ix1 Word) -> + V.init' arr !!==!! VP.init (toPrimitiveVector arr) + prop "tail" $ \(arr :: Array P Ix1 Word) -> + let vp = toPrimitiveVector arr + in (V.tail arr !==! VP.drop 1 vp) .&&. + (not (isEmpty arr) ==> V.tail arr !==! VP.tail vp) + prop "tail'" $ \(arr :: Array P Ix1 Word) -> + V.tail' arr !!==!! VP.tail (toPrimitiveVector arr) + prop "take" $ \n (arr :: Array P Ix1 Word) -> + V.take (Sz n) arr !==! VP.take n (toPrimitiveVector arr) + prop "take'" $ \sz@(Sz n) (arr :: Array P Ix1 Word) -> + V.take' sz arr !!==!! VP.slice 0 n (toPrimitiveVector arr) + prop "stake" $ \n (arr :: Array P Ix1 Word) -> + V.stake (Sz n) arr !==! VP.take n (toPrimitiveVector arr) + prop "drop" $ \n (arr :: Array P Ix1 Word) -> + V.drop (Sz n) arr !==! VP.drop n (toPrimitiveVector arr) + prop "drop'" $ \sz@(Sz n) (arr :: Array P Ix1 Word) -> + V.drop' sz arr !!==!! VP.slice n (unSz (size arr) - n) (toPrimitiveVector arr) + prop "sdrop" $ \n (arr :: Array P Ix1 Word) -> + V.sdrop (Sz n) arr !==! VP.drop n (toPrimitiveVector arr) + prop "sliceAt" $ \sz (arr :: Array P Ix1 Word) -> + let (larr, rarr) = V.sliceAt (Sz sz) arr + (lvec, rvec) = VP.splitAt sz (toPrimitiveVector arr) + in (larr !==! lvec) .&&. (rarr !==! rvec) + prop "sliceAt'" $ \sz@(Sz n) (arr :: Array P Ix1 Word) -> + let (larr, rarr) = V.sliceAt' sz arr + lvec = VP.slice 0 n (toPrimitiveVector arr) + rvec = VP.slice n (unSz (size arr) - n) (toPrimitiveVector arr) + in (larr !!==!! lvec) .&&. (rarr !!==!! rvec) + describe "Constructors" $ do + describe "Initialization" $ do + it "empty" $ toPrimitiveVector (V.empty :: V.Vector P Word) `shouldBe` VP.empty + it "sempty" $ + toPrimitiveVector (compute (V.sempty :: V.Vector DS Word)) `shouldBe` VP.empty + prop "singleton" $ \e -> (V.singleton e :: V.Vector P Word) !==! VP.singleton e + prop "ssingleton" $ \(e :: Word) -> V.ssingleton e !==! VP.singleton e + prop "replicate" $ \comp k (e :: Word) -> V.replicate comp (Sz k) e !==! VP.replicate k e + prop "sreplicate" $ \k (e :: Word) -> V.sreplicate (Sz k) e !==! VP.replicate k e + prop "generate" $ \comp k (f :: Fun Int Word) -> + V.generate comp (Sz k) (apply f) !==! VP.generate k (apply f) + prop "sgenerate" $ \k (f :: Fun Int Word) -> + V.sgenerate (Sz k) (apply f) !==! VP.generate k (apply f) + prop "siterateN" $ \n (f :: Fun Word Word) a -> + V.siterateN (Sz n) (apply f) a !==! VP.iterateN n (apply f) a + prop "siterate" $ \n (f :: Fun Word Word) a -> + computeAs P (V.stake n (V.siterate (apply f) a)) === + computeAs P (V.siterateN n (apply f) a) + prop "cons" $ \e (v :: Vector P Word) -> + computeAs P (V.cons e (toLoadArray v)) !!==!! VP.cons e (toPrimitiveVector v) + describe "Monadic initialization" $ do + prop "sreplicateM" prop_sreplicateM + prop "sgenerateM" prop_sgenerateM + prop "siterateNM" prop_siterateNM + describe "Unfolding" $ do + prop "sunfoldr" $ \(a :: Word) -> + let f b + | b > 10000 || b `div` 17 == 0 = Nothing + | otherwise = Just (b * b, b + 1) + in V.sunfoldr f a !==! VP.unfoldr f a + prop "sunfoldrN" $ \n (a :: Word) -> + let f b + | b > 10000 || b `div` 19 == 0 = Nothing + | otherwise = Just (b * b, b + 1) + in V.sunfoldrN (Sz n) f a !==! VP.unfoldrN n f a .&&. A.unsafeUnfoldrN (Sz n) f a !==! + VP.unfoldrN n f a + it "sunfoldrN (maxBound)" $ + let maxv = V.sunfoldrN (Sz maxBound) (const (Nothing :: Maybe (Word8, Word8))) 0 + in computeAs P maxv `shouldBe` A.empty + prop "sunfoldrExactN" $ \n (a :: Word) -> + let f b = (b * b, b + 1) + in V.sunfoldrExactN (Sz n) f a !==! VP.unfoldrN n (Just . f) a + prop "sunfoldrM" prop_sunfoldrM + prop "sunfoldrNM" prop_sunfoldrNM + it "sunfoldrNM (maxBound)" $ + let maxv = V.sunfoldrNM (Sz maxBound) (pure . const (Nothing :: Maybe (Word8, Word8))) 0 + in computeAs P <$> maxv `shouldReturn` A.empty + prop "sunfoldrExactM" prop_sunfoldrExactNM + describe "Enumeration" $ do + prop "senumFromN" $ \(i :: Int) n -> V.senumFromN i (Sz n) !==! VP.enumFromN i n + prop "senumFromStepN" $ \(i :: Int) s n -> + V.senumFromStepN i s (Sz n) !==! VP.enumFromStepN i s n + describe "Concatenation" $ do + prop "sappend" $ \(v1 :: Vector D Int) (v2 :: Vector P Int) -> + V.sappend v1 v2 !==! toPrimitiveVector (compute v1) VP.++ toPrimitiveVector v2 + prop "sconcat" $ \(vs :: [Vector P Int]) -> + V.sconcat vs !==! VP.concat (fmap toPrimitiveVector vs) + describe "Predicates" $ do + describe "Filtering" $ do + prop "sfilter" $ \(v :: Vector P Word) (f :: Fun Word Bool) -> + V.sfilter (apply f) v !==! VP.filter (apply f) (toPrimitiveVector v) + prop "sifilter" $ \(v :: Vector P Word) (f :: Fun (Int, Word) Bool) -> + V.sifilter (applyFun2 f) v !==! VP.ifilter (applyFun2 f) (toPrimitiveVector v) + prop "sfilterM" prop_sfilterM + prop "sifilterM" prop_sifilterM + prop "smapMaybe" $ \(v :: Vector P Word) (f :: Fun Word (Maybe Int)) -> + V.smapMaybe (apply f) v !==! VP.mapMaybe (apply f) (toPrimitiveVector v) + prop "simapMaybe" $ \(v :: Vector P Word) (f :: Fun (Int, Word) (Maybe Int)) -> + V.simapMaybe (applyFun2 f) v !==! VP.imapMaybe (applyFun2 f) (toPrimitiveVector v) + prop "scatMaybes" $ \(v :: Vector D (Maybe Word)) -> + V.scatMaybes v !==! toPrimitiveVector (compute (smap fromJust (sfilter isJust v))) + prop "smapMaybeM" prop_smapMaybeM + describe "Mapping" $ do + prop "fmap" $ \(v :: Vector DS Word) (f :: Fun Word Int) -> + fmap (apply f) v !==! VP.map (apply f) (toPrimitiveVector (compute v)) + prop "<$" $ \(v :: Vector DS Word) (a :: Char) -> + (a <$ v) !==! VP.replicate (totalElem (size v)) a + prop "smap" $ \(v :: Vector P Word) (f :: Fun Word Int) -> + V.smap (apply f) v !==! VP.map (apply f) (toPrimitiveVector v) + prop "simap" $ \(v :: Vector P Word) (f :: Fun (Int, Word) Int) -> + V.simap (applyFun2 f) v !==! VP.imap (applyFun2 f) (toPrimitiveVector v) + prop "straverse" prop_straverse + prop "sitraverse" prop_sitraverse + prop "smapM" prop_smapM + prop "simapM" prop_simapM + prop "smapM" prop_smapM_ + prop "simapM" prop_simapM_ + prop "szip" prop_szip + prop "szip3" prop_szip3 + prop "szip4" prop_szip4 + prop "szip5" prop_szip5 + prop "szip6" prop_szip6 + prop "szipWith" prop_szipWith + prop "szipWith3" prop_szipWith3 + prop "szipWith4" prop_szipWith4 + prop "szipWith5" prop_szipWith5 + prop "szipWith6" prop_szipWith6 + prop "sizipWith" prop_sizipWith + prop "sizipWith3" prop_sizipWith3 + prop "sizipWith4" prop_sizipWith4 + prop "sizipWith5" prop_sizipWith5 + prop "sizipWith6" prop_sizipWith6 + prop "liftA2" $ \(v1 :: Vector DS Word) (v2 :: Vector DS Int) (f :: Fun (Word, Int) Int) -> + liftA2 (applyFun2 f) v1 v2 !==! + toPrimV2 (VP.zipWith (applyFun2 f)) (compute v1) (compute v2) + prop "szipWithM" prop_szipWithM + prop "szipWith3M" prop_szipWith3M + prop "szipWith4M" prop_szipWith4M + prop "szipWith5M" prop_szipWith5M + prop "szipWith6M" prop_szipWith6M + prop "sizipWithM" prop_sizipWithM + prop "sizipWith3M" prop_sizipWith3M + prop "sizipWith4M" prop_sizipWith4M + prop "sizipWith5M" prop_sizipWith5M + prop "sizipWith6M" prop_sizipWith6M + prop "szipWithM_" prop_szipWithM_ + prop "szipWith3M_" prop_szipWith3M_ + prop "szipWith4M_" prop_szipWith4M_ + prop "szipWith5M_" prop_szipWith5M_ + prop "szipWith6M_" prop_szipWith6M_ + prop "sizipWithM_" prop_sizipWithM_ + prop "sizipWith3M_" prop_sizipWith3M_ + prop "sizipWith4M_" prop_sizipWith4M_ + prop "sizipWith5M_" prop_sizipWith5M_ + prop "sizipWith6M_" prop_sizipWith6M_ + describe "Folding" $ do + prop "sfoldl" $ \(v :: Vector P Word32) (f :: Fun (Word, Word32) Word) a0 -> + V.sfoldl (applyFun2 f) a0 v === VP.foldl (applyFun2 f) a0 (toPrimitiveVector v) + prop "sifoldl" $ \(v :: Vector P Word32) (f :: Fun (Word, Ix1, Word32) Word) a0 -> + V.sifoldl (applyFun3 f) a0 v === VP.ifoldl (applyFun3 f) a0 (toPrimitiveVector v) + prop "sfoldl1'" prop_sfoldl1' + describe "Specialized" $ do + prop "sor" $ \(v :: Vector S Bool) -> V.sor v === VS.or (toStorableVector v) + prop "sand" $ \(v :: Vector S Bool) -> V.sand v === VS.and (toStorableVector v) + prop "sany" $ \(v :: Vector P Word) (f :: Fun Word Bool) -> + V.sany (apply f) v === VP.any (apply f) (toPrimitiveVector v) + prop "sall" $ \(v :: Vector P Word) (f :: Fun Word Bool) -> + V.sall (apply f) v === VP.all (apply f) (toPrimitiveVector v) + prop "ssum" $ \(v :: Vector P Word) -> V.ssum v === VP.sum (toPrimitiveVector v) + prop "sproduct" $ \(v :: Vector P Word) -> + V.sproduct v === VP.product (toPrimitiveVector v) + prop "maximum'" prop_maximum' + prop "minimum'" prop_minimum' + prop "maximumM" prop_maximumM + prop "minimumM" prop_minimumM + describe "Conversion" $ + describe "Lists" $ do + prop "sfromList" $ \comp (xs :: [Word]) -> + sfromList xs !==! toPrimitiveVector (fromList comp xs) + prop "sfromList" $ \(xs :: [Word]) -> sfromList xs !==! VP.fromList xs + prop "sfromListN" $ \sz@(Sz n) (xs :: [Word]) -> sfromListN sz xs !==! VP.fromListN n xs + prop "sfromListN (maxBound)" $ \(xs :: [Word]) -> + sfromListN (Sz (maxBound `div` 8)) xs !==! VP.fromList xs + prop "unsafeFromListN" $ \sz@(Sz n) (xs :: [Word]) -> + A.unsafeFromListN sz xs !==! VP.fromListN n xs + +prop_sfoldl1' :: Vector P Word -> Fun (Word, Word) Word -> Property +prop_sfoldl1' v f = + V.singleton @D (V.sfoldl1' (applyFun2 f) v) !!==!! + VP.singleton (VP.foldl1' (applyFun2 f) (toPrimitiveVector v)) + +prop_maximum' :: Vector P Word -> Property +prop_maximum' v = + V.singleton @D (V.smaximum' v) !!==!! VP.singleton (VP.maximum (toPrimitiveVector v)) + +prop_minimum' :: Vector P Word -> Property +prop_minimum' v = + V.singleton @D (V.sminimum' v) !!==!! VP.singleton (VP.minimum (toPrimitiveVector v)) + +prop_maximumM :: Vector P Word -> Property +prop_maximumM v = + let vp = toPrimitiveVector v + in V.smaximumM v === (guard (not (VP.null vp)) >> Just (VP.maximum vp)) + +prop_minimumM :: Vector P Word -> Property +prop_minimumM v = + let vp = toPrimitiveVector v + in V.sminimumM v === (guard (not (VP.null vp)) >> Just (VP.minimum vp)) + +prop_sitraverse_itraverseA :: SeedVector -> Vector S Word -> Property +prop_sitraverse_itraverseA seed a = + withSeed2 @(V.Vector P Word) seed + (fmap compute . genWithIMapM (`V.sitraverse` a)) + (genWithIMapM (`itraverseA` a)) + +prop_straverse_traversePrim :: SeedVector -> Vector S Word -> Property +prop_straverse_traversePrim seed a = + withSeed2 @(V.Vector P Word) seed + (fmap compute . genWithIMapM (\f -> V.straverse (f 0) a)) + (genWithIMapM (\f -> traversePrim (f 0) a)) + +prop_sitraverse_itraversePrim :: SeedVector -> Array P Ix3 Word -> Property +prop_sitraverse_itraversePrim seed a = + withSeed2 @(V.Vector P Word) seed + (genWithIMapM (\f -> compute <$> V.sitraverse (xorToLinear f) a)) + (genWithIMapM (\f -> flatten <$> itraversePrim @P (xorToLinear f) a)) + where + xorToLinear f i = f (foldlIndex xor 0 i) + +prop_smapM_traverseA_ :: SeedVector -> Array P Ix2 Word -> Property +prop_smapM_traverseA_ seed a = + withSeed seed (genWithMapM_ (`V.smapM_` a)) === withSeed seed (genWithMapM_ (`traverseA_` a)) + +prop_simapM_itraverseA_ :: SeedVector -> Array P Ix2 Word -> Property +prop_simapM_itraverseA_ seed a = + withSeed2 + seed + (genWithIMapM_ (\f -> V.simapM_ (xorToLinear f) a)) + (genWithIMapM_ (\f -> itraverseA_ (xorToLinear f) a)) + where + xorToLinear f i = f (foldlIndex xor 0 i) + +prop_sforM_forM :: SeedVector -> Vector S Word -> Property +prop_sforM_forM seed a = + withSeed @(V.Vector P Word) seed (fmap compute . genWithMapM (V.sforM a)) + === withSeed seed (genWithMapM (A.forM a)) + +prop_siforM_iforM :: SeedVector -> Vector S Word -> Property +prop_siforM_iforM seed a = + withSeed @(V.Vector P Word) seed (fmap compute . genWithIMapM (V.siforM a)) + === withSeed seed (genWithIMapM (iforM a)) + +withSeedIO :: forall a. SeedVector -> (MWC.Gen (PrimState IO) -> IO a) -> IO a +withSeedIO (SeedVector seed) f = MWC.initialize seed >>= f + +prop_sforM_forIO :: SeedVector -> Vector S Word -> Property +prop_sforM_forIO seed a = property $ + withSeedIO seed (genWithMapM (forIO (setComp Seq a))) `shouldReturn` + withSeed @(V.Vector P Word) seed (fmap compute . genWithMapM (V.sforM a)) + +prop_siforM_iforIO :: SeedVector -> Vector S Word -> Property +prop_siforM_iforIO seed a = property $ + withSeedIO seed (genWithIMapM (iforIO (setComp (ParN 1) a))) `shouldReturn` + withSeed @(V.Vector P Word) seed (fmap compute . genWithIMapM (V.siforM a)) + +prop_sforM_forM_ :: SeedVector -> Vector S Word -> Property +prop_sforM_forM_ seed a = property $ + withSeed seed (genWithMapM_ (A.forM_ a)) `shouldBe` + withSeed @Word seed (genWithMapM_ (V.sforM_ a)) + +prop_siforM_iforM_ :: SeedVector -> Vector S Word -> Property +prop_siforM_iforM_ seed a = property $ + withSeed seed (genWithIMapM_ (iforM_ a)) `shouldBe` + withSeed @Word seed (genWithIMapM_ (V.siforM_ a)) + +prop_sforM_forIO_ :: SeedVector -> Vector S Word -> Property +prop_sforM_forIO_ seed a = property $ + withSeedIO seed (genWithMapM_ (forIO_ (setComp (ParN 1) a))) `shouldReturn` + withSeed @Word seed (genWithMapM_ (V.sforM_ a)) + +prop_siforM_iforIO_ :: SeedVector -> Vector S Word -> Property +prop_siforM_iforIO_ seed a = property $ + withSeedIO seed (genWithIMapM_ (iforIO_ (setComp (ParN 1) a))) `shouldReturn` + withSeed @Word seed (genWithIMapM_ (V.siforM_ a)) + + +prop_siforM_iforWS :: SeedVector -> Vector S Word -> Property +prop_siforM_iforWS seed@(SeedVector sv) a = + property $ do + wsArray <- + do ws <- initWorkerStates (ParN 1) (const (MWC.initialize sv)) + genWithIMapWS (iforWS ws a) + wsArray `shouldBe` withSeed @(V.Vector P Word) seed (fmap compute . genWithIMapM (V.siforM a)) + +prop_smapM_mapWS :: SeedVector -> Vector S Word -> Property +prop_smapM_mapWS seed@(SeedVector sv) a = + property $ do + wsArray <- + do ws <- initWorkerStates Seq (const (MWC.initialize sv)) + genWithMapWS (\f -> mapWS ws f a) + wsArray `shouldBe` withSeed @(V.Vector P Word) seed (fmap compute . genWithMapM (`V.smapM` a))