accelerate-examples 0.15.1.0 → 1.0.0.0
raw patch · 119 files changed
+4453/−2958 lines, 119 filesdep +colour-acceleratedep +lens-acceleratedep +lineardep −attoparsecdep −ekgdep −primitivedep ~acceleratedep ~accelerate-cudadep ~accelerate-examplesnew-component:exe:accelerate-tunnel
Dependencies added: colour-accelerate, lens-accelerate, linear, linear-accelerate, matrix-market-attoparsec, pipes, scientific
Dependencies removed: attoparsec, ekg, primitive
Dependency ranges changed: accelerate, accelerate-cuda, accelerate-examples, accelerate-fft, accelerate-icc-opencl, accelerate-io, accelerate-llvm-native, accelerate-llvm-ptx, base, bytestring, criterion, fclabels, gloss-accelerate, gloss-raster-accelerate, vector
Files
- accelerate-examples.cabal +387/−310
- data/hashcat/README.md +0/−30
- examples/canny/README.md +25/−0
- examples/canny/src-acc/Canny.hs +23/−21
- examples/canny/src-acc/Main.hs +2/−3
- examples/crystal/Main.hs +8/−7
- examples/fft/src-acc/FFT.hs +11/−8
- examples/fft/src-acc/HighPass.hs +20/−14
- examples/fft/src-acc/Main.hs +8/−8
- examples/fluid/README.md +54/−0
- examples/fluid/src-acc/Config.hs +12/−9
- examples/fluid/src-acc/Event.hs +10/−7
- examples/fluid/src-acc/Fluid.hs +9/−8
- examples/fluid/src-acc/Main.hs +2/−4
- examples/fluid/src-acc/Type.hs +2/−2
- examples/fluid/src-acc/World.hs +8/−2
- examples/hashcat/Config.hs +13/−0
- examples/hashcat/MD5.hs +34/−23
- examples/hashcat/Main.hs +33/−10
- examples/hashcat/README.md +34/−0
- examples/kmeans/Kmeans.hs +19/−17
- examples/kmeans/Main.hs +5/−7
- examples/kmeans/README.md +38/−0
- examples/mandelbrot/Config.hs +13/−13
- examples/mandelbrot/Main.hs +19/−37
- examples/mandelbrot/Mandel.hs +144/−135
- examples/mandelbrot/README.md +16/−0
- examples/mandelbrot/World.hs +190/−147
- examples/n-body/Common/Body.hs +19/−22
- examples/n-body/Common/Type.hs +10/−11
- examples/n-body/Common/Util.hs +0/−76
- examples/n-body/Common/World.hs +2/−2
- examples/n-body/Gloss/Draw.hs +1/−1
- examples/n-body/Main.hs +1/−3
- examples/n-body/Random/Position.hs +5/−5
- examples/n-body/Solver/Naive1.hs +1/−2
- examples/n-body/Solver/Naive2.hs +2/−3
- examples/n-body/Test.hs +7/−7
- examples/nofib/Config.hs +3/−2
- examples/nofib/Main.hs +1/−3
- examples/nofib/QuickCheck/Arbitrary/Array.hs +70/−22
- examples/nofib/QuickCheck/Arbitrary/Shape.hs +13/−37
- examples/nofib/Test/Base.hs +10/−4
- examples/nofib/Test/FFT.hs +112/−40
- examples/nofib/Test/Foreign/CUDA.hs +13/−6
- examples/nofib/Test/IO/Ptr.hs +7/−7
- examples/nofib/Test/IO/Vector.hs +2/−2
- examples/nofib/Test/Imaginary/DotP.hs +4/−2
- examples/nofib/Test/Imaginary/SASUM.hs +4/−2
- examples/nofib/Test/Imaginary/SAXPY.hs +5/−2
- examples/nofib/Test/Issues.hs +14/−0
- examples/nofib/Test/Issues/Issue102.hs +1/−1
- examples/nofib/Test/Issues/Issue137.hs +3/−3
- examples/nofib/Test/Issues/Issue184.hs +4/−4
- examples/nofib/Test/Issues/Issue185.hs +48/−18
- examples/nofib/Test/Issues/Issue187.hs +3/−3
- examples/nofib/Test/Issues/Issue228.hs +54/−0
- examples/nofib/Test/Issues/Issue255.hs +76/−0
- examples/nofib/Test/Issues/Issue264.hs +102/−0
- examples/nofib/Test/Issues/Issue286.hs +122/−0
- examples/nofib/Test/Issues/Issue287.hs +91/−0
- examples/nofib/Test/Issues/Issue288.hs +25/−0
- examples/nofib/Test/Issues/Issue362.hs +52/−0
- examples/nofib/Test/Prelude.hs +10/−9
- examples/nofib/Test/Prelude/Backpermute.hs +153/−0
- examples/nofib/Test/Prelude/Filter.hs +39/−8
- examples/nofib/Test/Prelude/Fold.hs +314/−0
- examples/nofib/Test/Prelude/IndexSpace.hs +0/−293
- examples/nofib/Test/Prelude/Map.hs +209/−0
- examples/nofib/Test/Prelude/Mapping.hs +0/−263
- examples/nofib/Test/Prelude/Permute.hs +171/−0
- examples/nofib/Test/Prelude/PrefixSum.hs +0/−215
- examples/nofib/Test/Prelude/Reduction.hs +0/−227
- examples/nofib/Test/Prelude/Replicate.hs +3/−1
- examples/nofib/Test/Prelude/Scan.hs +358/−0
- examples/nofib/Test/Prelude/Stencil.hs +17/−15
- examples/nofib/Test/Prelude/ZipWith.hs +203/−0
- examples/nofib/Test/Sharing.hs +12/−9
- examples/nofib/Test/Spectral/BlackScholes.hs +12/−11
- examples/nofib/Test/Spectral/RadixSort.hs +11/−9
- examples/nofib/Test/Spectral/SMVM.hs +6/−4
- examples/pagerank/Config.hs +3/−0
- examples/pagerank/Load.hs +5/−4
- examples/pagerank/Main.hs +6/−9
- examples/pagerank/Page.hs +26/−25
- examples/pagerank/README.md +37/−0
- examples/pagerank/Rank.hs +65/−47
- examples/pagerank/Step.hs +49/−9
- examples/ray/Common/Type.hs +14/−0
- examples/ray/Gloss/Draw.hs +13/−10
- examples/ray/Gloss/Event.hs +3/−3
- examples/ray/Main.hs +4/−6
- examples/ray/README.md +17/−0
- examples/ray/Ray/Intersect.hs +10/−12
- examples/ray/Ray/Trace.hs +36/−34
- examples/ray/Scene/Light.hs +28/−27
- examples/ray/Scene/Object.hs +53/−60
- examples/ray/Scene/State.hs +8/−8
- examples/ray/Scene/World.hs +9/−10
- examples/ray/Vec3.hs +0/−148
- examples/smoothlife/Config.hs +2/−0
- examples/smoothlife/Gloss/Draw.hs +27/−24
- examples/smoothlife/Main.hs +1/−3
- examples/smoothlife/SmoothLife.hs +26/−25
- examples/smvm/Main.hs +26/−21
- examples/smvm/Matrix.hs +107/−81
- examples/smvm/MatrixMarket.hs +0/−135
- examples/smvm/SMVM.hs +2/−1
- examples/tunnel/Config.hs +42/−0
- examples/tunnel/Main.hs +154/−0
- lib/Data/Array/Accelerate/Examples/Internal.hs +1/−0
- lib/Data/Array/Accelerate/Examples/Internal/Backend.hs +61/−36
- lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs +5/−0
- lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs +7/−10
- lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs +8/−5
- lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs +2/−2
- lib/Data/Array/Accelerate/Examples/Internal/Similar.hs +25/−14
- lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs +9/−3
- lib/Data/Array/Accelerate/Examples/Internal/Util.hs +18/−10
accelerate-examples.cabal view
@@ -1,5 +1,5 @@ Name: accelerate-examples-Version: 0.15.1.0+Version: 1.0.0.0 Cabal-version: >=1.8 Tested-with: GHC >= 7.8 Build-type: Simple@@ -24,8 +24,15 @@ Category: Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental -Extra-source-files: data/hashcat/README.md- data/matrices/README.md+Extra-source-files:+ data/matrices/README.md+ examples/canny/README.md+ examples/fluid/README.md+ examples/hashcat/README.md+ examples/kmeans/README.md+ examples/mandelbrot/README.md+ examples/pagerank/README.md+ examples/ray/README.md -- Flags that control features of the benchmark programs --@@ -46,14 +53,14 @@ -- Flag cuda Description: Enable the CUDA parallel backend for NVIDIA GPUs- Default: True+ Default: False Flag llvm-cpu Description: Enable the LLVM backend for multicore CPUs Default: False -Flag llvm-gpu- Description: Enable the LLVM backend for NVIDIA CPUs+Flag llvm-ptx+ Description: Enable the LLVM PTX backend for NVIDIA GPUs Default: False Flag cilk@@ -74,6 +81,10 @@ Description: A visualisation of a sum of waves in a plane Default: True +Flag tunnel+ Description: The slit-scan effect creating a Doctor Who time vortex+ Default: True+ Flag canny Description: Canny edge detection benchmark Default: True@@ -120,34 +131,38 @@ Library hs-source-dirs: lib- Build-depends: accelerate == 0.15.*,- ansi-wl-pprint >= 0.6,- base >= 4.7 && < 4.9,- containers >= 0.5,- criterion >= 1.0,- directory >= 1.1,- fclabels >= 2.0,- HUnit >= 1.2,- mwc-random >= 0.8,- QuickCheck >= 2.7,- test-framework >= 0.5,- test-framework-hunit >= 0.3,- test-framework-quickcheck2 >= 0.2+ Build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , ansi-wl-pprint >= 0.6+ , containers >= 0.5+ , criterion >= 1.0+ , directory >= 1.1+ , fclabels >= 2.0+ , HUnit >= 1.2+ , linear >= 1.1+ , mwc-random >= 0.8+ , QuickCheck >= 2.7+ , test-framework >= 0.5+ , test-framework-hunit >= 0.3+ , test-framework-quickcheck2 >= 0.2 - Exposed-modules: Data.Array.Accelerate.Examples.Internal+ Exposed-modules:+ Data.Array.Accelerate.Examples.Internal - Other-modules: Data.Array.Accelerate.Examples.Internal.Backend- Data.Array.Accelerate.Examples.Internal.Criterion- Data.Array.Accelerate.Examples.Internal.Criterion.Config- Data.Array.Accelerate.Examples.Internal.Interactive- Data.Array.Accelerate.Examples.Internal.Monitoring- Data.Array.Accelerate.Examples.Internal.ParseArgs- Data.Array.Accelerate.Examples.Internal.Random.Array- Data.Array.Accelerate.Examples.Internal.Report- Data.Array.Accelerate.Examples.Internal.Similar- Data.Array.Accelerate.Examples.Internal.TestFramework- Data.Array.Accelerate.Examples.Internal.TestFramework.Config- Data.Array.Accelerate.Examples.Internal.Util+ Other-modules:+ Data.Array.Accelerate.Examples.Internal.Backend+ Data.Array.Accelerate.Examples.Internal.Criterion+ Data.Array.Accelerate.Examples.Internal.Criterion.Config+ Data.Array.Accelerate.Examples.Internal.Interactive+ Data.Array.Accelerate.Examples.Internal.Monitoring+ Data.Array.Accelerate.Examples.Internal.ParseArgs+ Data.Array.Accelerate.Examples.Internal.Random.Array+ Data.Array.Accelerate.Examples.Internal.Report+ Data.Array.Accelerate.Examples.Internal.Similar+ Data.Array.Accelerate.Examples.Internal.TestFramework+ Data.Array.Accelerate.Examples.Internal.TestFramework.Config+ Data.Array.Accelerate.Examples.Internal.Util ghc-options: -O2 -Wall ghc-prof-options: -caf-all -auto-all@@ -157,39 +172,44 @@ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*+ build-depends:+ accelerate-cuda == 0.17.* if flag(llvm-cpu) CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*+ build-depends:+ accelerate-llvm-native == 1.0.* - if flag(llvm-gpu)+ if flag(llvm-ptx) CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*+ build-depends:+ accelerate-llvm-ptx == 1.0.* if flag(cilk) CPP-options: -DACCELERATE_CILK_BACKEND- build-depends: accelerate-icc-opencl == 0.15.*+ build-depends:+ accelerate-icc-opencl == 1.0.* if flag(ekg) CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 if flag(codespeed) CPP-options: -DACCELERATE_ENABLE_CODESPEED- build-depends: aeson >= 0.8,- bytestring >= 0.10,- HTTP >= 4000.2,- http-types >= 0.8,- network >= 2.5,- process >= 1.0,- statistics >= 0.13,- template-haskell >= 2.2,- text >= 0.11,- time >= 1.4+ build-depends:+ aeson >= 0.8+ , bytestring >= 0.10+ , HTTP >= 4000.2+ , http-types >= 0.8+ , network >= 2.5+ , process >= 1.0+ , statistics >= 0.13+ , template-haskell >= 2.2+ , text >= 0.11+ , time >= 1.4 - other-modules: Data.Array.Accelerate.Examples.Internal.Codespeed- Data.Array.Accelerate.Examples.Internal.TH+ other-modules:+ Data.Array.Accelerate.Examples.Internal.Codespeed+ Data.Array.Accelerate.Examples.Internal.TH -- The main test program. This includes randomised quickcheck testing for array@@ -199,56 +219,73 @@ -- Executable accelerate-nofib Main-is: Main.hs- hs-source-dirs: examples/nofib- examples/smvm+ hs-source-dirs:+ examples/nofib+ examples/smvm - other-modules: Config- QuickCheck.Arbitrary.Array- QuickCheck.Arbitrary.Shape- Test.Base- Test.FFT- Test.Foreign- Test.IO- Test.IO.Ptr- Test.IO.Vector- Test.Imaginary- Test.Imaginary.DotP- Test.Imaginary.SASUM- Test.Imaginary.SAXPY- Test.Issues- Test.Issues.Issue93- Test.Issues.Issue102- Test.Issues.Issue114- Test.Issues.Issue119- Test.Issues.Issue123- Test.Issues.Issue137- Test.Issues.Issue168- Test.Issues.Issue184- Test.Issues.Issue185- Test.Issues.Issue187- Test.Prelude- Test.Prelude.Filter- Test.Prelude.IndexSpace- Test.Prelude.Mapping- Test.Prelude.PrefixSum- Test.Prelude.Reduction- Test.Prelude.Replicate- Test.Prelude.Stencil- Test.Sharing- Test.Spectral- Test.Spectral.BlackScholes- Test.Spectral.RadixSort- Test.Spectral.SMVM+ other-modules:+ Config+ QuickCheck.Arbitrary.Array+ QuickCheck.Arbitrary.Shape+ SMVM+ Test.Base+ Test.FFT+ Test.Foreign+ Test.Imaginary+ Test.Imaginary.DotP+ Test.Imaginary.SASUM+ Test.Imaginary.SAXPY+ Test.IO+ Test.IO.Ptr+ Test.IO.Vector+ Test.Issues+ Test.Issues.Issue93+ Test.Issues.Issue102+ Test.Issues.Issue114+ Test.Issues.Issue119+ Test.Issues.Issue123+ Test.Issues.Issue137+ Test.Issues.Issue168+ Test.Issues.Issue184+ Test.Issues.Issue185+ Test.Issues.Issue187+ Test.Issues.Issue228+ Test.Issues.Issue255+ Test.Issues.Issue264+ Test.Issues.Issue286+ Test.Issues.Issue287+ Test.Issues.Issue288+ Test.Issues.Issue362+ Test.Prelude+ Test.Prelude.Backpermute+ Test.Prelude.Filter+ Test.Prelude.Fold+ Test.Prelude.Map+ Test.Prelude.Permute+ Test.Prelude.Replicate+ Test.Prelude.Scan+ -- Test.Prelude.Sequences+ Test.Prelude.Stencil+ Test.Prelude.ZipWith+ Test.Sharing+ Test.Spectral+ Test.Spectral.BlackScholes+ Test.Spectral.RadixSort+ Test.Spectral.SMVM - ghc-options: -Wall -O2- -threaded- -fpedantic-bottoms- -fno-full-laziness- -fno-excess-precision- -eventlog- -rtsopts+ ghc-options:+ -O2+ -Wall+ -threaded+ -fpedantic-bottoms+ -fno-excess-precision+ -eventlog+ -rtsopts+ -with-rtsopts=-n2M+ -with-rtsopts=-A64M - ghc-prof-options: -auto-all+ ghc-prof-options:+ -auto-all extra-libraries: stdc++ c-sources: examples/nofib/Test/IO/fill_with_values.cpp@@ -256,44 +293,47 @@ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*- other-modules: Test.Foreign.CUDA+ build-depends:+ accelerate-cuda == 0.17.* + other-modules:+ Test.Foreign.CUDA+ if flag(ekg) ghc-options: -with-rtsopts=-T if !flag(nofib) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-fft == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- array >= 0.3,- containers >= 0.5,- fclabels >= 2.0,- HUnit >= 1.2,- QuickCheck >= 2.7,- test-framework >= 0.5,- test-framework-hunit >= 0.3,- test-framework-quickcheck2 >= 0.2,- random+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-fft == 1.0.*+ , accelerate-io == 1.0.*+ , array >= 0.3+ , containers >= 0.5+ , fclabels >= 2.0+ , HUnit >= 1.2+ , pipes >= 4.1.6+ , QuickCheck >= 2.7+ , random+ , test-framework >= 0.5+ , test-framework-hunit >= 0.3+ , test-framework-quickcheck2 >= 0.2+ , vector >= 0.7 -- Sparse matrix vector multiplication -- ----------------------------------- Executable accelerate-smvm- Main-is: Main.hs hs-source-dirs: examples/smvm- other-modules: Config- Matrix- MatrixMarket- SMVM+ Main-is: Main.hs+ other-modules: Config Matrix SMVM - ghc-options: -O2 -Wall -threaded -rtsopts -eventlog ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if impl(ghc >= 7.6) ghc-options: -fsimpl-tick-factor=130@@ -304,17 +344,17 @@ if !flag(smvm) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- base >= 4.7 && < 4.9,- attoparsec >= 0.10,- bytestring >= 0.9,- bytestring-lexing >= 0.5,- fclabels >= 2.0,- primitive >= 0.5,- mwc-random >= 0.8,- vector >= 0.7,- vector-algorithms >= 0.4+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-io == 1.0.*+ , fclabels >= 2.0+ , matrix-market-attoparsec >= 0.1+ , mwc-random >= 0.8+ , scientific >= 0.3+ , vector >= 0.7+ , vector-algorithms >= 0.4 -- A quasicrystal demo as the sum of waves in a plane@@ -325,8 +365,8 @@ Main-is: Main.hs other-modules: Config - ghc-options: -O2 -Wall -threaded -rtsopts -eventlog ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -334,32 +374,52 @@ if !flag(crystal) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 2.0,- gloss-raster-accelerate >= 1.7+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , colour-accelerate >= 0.1+ , fclabels >= 2.0+ , gloss-raster-accelerate >= 0.2 +-- The slit-scan effect creating a Doctor Who time vortex+-- ------------------------------------------------------++Executable accelerate-tunnel+ hs-source-dirs: examples/tunnel+ Main-is: Main.hs+ other-modules: Config++ ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M++ if flag(ekg)+ ghc-options: -with-rtsopts=-T++ if !flag(tunnel)+ buildable: False+ else+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , fclabels >= 2.0+ , gloss-raster-accelerate >= 0.2+ , lens-accelerate >= 0.1+ , linear-accelerate >= 0.3++ -- Image edge detection -- -------------------- Executable accelerate-canny hs-source-dirs: examples/canny/src-acc Main-is: Main.hs- other-modules: Config- Canny- Wildfire-- ghc-options: -Wall- -threaded- -Odph- -fllvm- -optlo-O3- -eventlog- -rtsopts+ other-modules: Config Canny Wildfire ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -Odph -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -367,14 +427,16 @@ if !flag(canny) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 2.0,- repa >= 3.1,- repa-io >= 3.1,- vector >= 0.7+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-io == 1.0.*+ , colour-accelerate >= 0.1+ , fclabels >= 2.0+ , repa >= 3.1+ , repa-io >= 3.1+ , vector >= 0.7 -- A simple mandelbrot generator@@ -383,12 +445,10 @@ Executable accelerate-mandelbrot hs-source-dirs: examples/mandelbrot Main-is: Main.hs- other-modules: Config- Mandel- World+ other-modules: Config Mandel World - ghc-options: -O2 -Wall -threaded -eventlog -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -396,13 +456,15 @@ if !flag(mandelbrot) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 2.0,- gloss >= 1.7,- gloss-accelerate >= 1.7+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-io == 1.0.*+ , colour-accelerate >= 0.1+ , fclabels >= 2.0+ , gloss >= 1.7+ , gloss-accelerate >= 0.2 -- A stable fluid simulation@@ -411,14 +473,10 @@ Executable accelerate-fluid Main-is: Main.hs hs-source-dirs: examples/fluid/src-acc- other-modules: Config- Event- Fluid- Type- World+ other-modules: Config Event Fluid Type World - ghc-options: -O2 -Wall -threaded -eventlog -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -426,40 +484,42 @@ if !flag(fluid) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- bmp >= 1.2,- fclabels >= 2.0,- gloss >= 1.9,- gloss-rendering >= 1.9+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-io == 1.0.*+ , bmp >= 1.2+ , colour-accelerate >= 0.1+ , fclabels >= 2.0+ , gloss >= 1.9+ , gloss-rendering >= 1.9 -- Simulation of gravitational attraction between solid particles -- -------------------------------------------------------------- Executable accelerate-nbody- Main-is: Main.hs hs-source-dirs: examples/n-body- other-modules: Common.Body- Common.Dump- Common.Tree- Common.Type- Common.Util- Common.World- Config- Gloss.Draw- Gloss.Event- Gloss.Simulate- Random.Position- Solver.BarnsHut- Solver.Naive1- Solver.Naive2- Test+ Main-is: Main.hs+ other-modules:+ Common.Body+ Common.Dump+ Common.Tree+ Common.Type+ Common.World+ Config+ Gloss.Draw+ Gloss.Event+ Gloss.Simulate+ Random.Position+ Solver.BarnsHut+ Solver.Naive1+ Solver.Naive2+ Test - ghc-options: -O2 -Wall -threaded -eventlog -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -467,33 +527,38 @@ if !flag(nbody) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 2.0,- gloss >= 1.7,- mwc-random >= 0.8+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , fclabels >= 2.0+ , gloss >= 1.7+ , lens-accelerate >= 0.1+ , linear-accelerate >= 0.3+ , mwc-random >= 0.8 -- A celular automata -- ------------------ Executable accelerate-smoothlife- Main-is: Main.hs hs-source-dirs: examples/smoothlife- other-modules: Config- Gloss.Draw- Gloss.Event- Gloss.Simulate- Random.Splat- SmoothLife+ Main-is: Main.hs+ other-modules:+ Config+ Gloss.Draw+ Gloss.Event+ Gloss.Simulate+ Random.Splat+ SmoothLife - ghc-options: -O2 -Wall -threaded -threaded -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*+ build-depends:+ accelerate-cuda == 0.17.* if flag(ekg) ghc-options: -with-rtsopts=-T@@ -501,29 +566,28 @@ if !flag(smoothlife) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-fft == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 2.0,- gloss >= 1.7,- gloss-accelerate >= 1.7,- mwc-random >= 0.8+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-fft == 1.0.*+ , colour-accelerate >= 0.1+ , fclabels >= 2.0+ , gloss >= 1.7+ , gloss-accelerate >= 0.2+ , mwc-random >= 0.8 --- A password recovery tool--- ------------------------+-- A "password recovery" tool+-- -------------------------- Executable accelerate-hashcat- Main-is: Main.hs hs-source-dirs: examples/hashcat- other-modules: Config- Digest- MD5+ Main-is: Main.hs+ other-modules: Config Digest MD5 - ghc-options: -O2 -Wall -threaded -threaded -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -531,28 +595,28 @@ if !flag(hashcat) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- base >= 4.7 && < 4.9,- bytestring >= 0.9,- bytestring-lexing >= 0.5,- cereal >= 0.3,- criterion >= 1.0,- fclabels >= 2.0,- mwc-random >= 0.8+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , bytestring >= 0.9+ , bytestring-lexing >= 0.5+ , cereal >= 0.3+ , criterion >= 1.0+ , fclabels >= 2.0+ , mwc-random >= 0.8 + -- FFT examples -- ------------ Executable accelerate-fft Main-is: Main.hs hs-source-dirs: examples/fft/src-acc- other-modules: Config- HighPass- FFT+ other-modules: Config HighPass FFT - ghc-options: -O2 -Wall -threaded -threaded -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -560,29 +624,33 @@ if !flag(fft) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-fft == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 2.0,- filepath >= 1.0+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-fft == 1.0.*+ , accelerate-io == 1.0.*+ , colour-accelerate >= 0.1+ , fclabels >= 2.0+ , filepath >= 1.0 -- PageRank -- -------- Executable accelerate-pagerank- Main-is: Main.hs hs-source-dirs: examples/pagerank- other-modules: Config- Count- Load- Page- Progress- Rank- Step+ Main-is: Main.hs+ other-modules:+ Config+ Count+ Load+ Page+ Progress+ Rank+ Step - ghc-options: -rtsopts -threaded -O2+ ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T@@ -590,86 +658,95 @@ if !flag(pagerank) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- accelerate-io == 0.15.*,- base >= 4.7 && < 4.9,- bytestring >= 0.9.2,- containers >= 0.4.2,- directory >= 1.1,- fclabels >= 1.0,- vector >= 0.9,- vector-algorithms >= 0.5.4+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , accelerate-io == 1.0.*+ , bytestring >= 0.9.2+ , containers >= 0.4.2+ , directory >= 1.1+ , fclabels >= 1.0+ , vector >= 0.9+ , vector-algorithms >= 0.5.4 -- Ray tracer -- ---------- Executable accelerate-ray- Main-is: Main.hs hs-source-dirs: examples/ray- other-modules: Config- Vec3- Gloss.Draw- Gloss.Event- Ray.Intersect- Ray.Trace- Scene.Light- Scene.Object- Scene.State- Scene.World-- if !flag(ray)- buildable: False- else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- base >= 4.7 && < 4.9,- fclabels >= 1.0,- gloss >= 1.8,- gloss-accelerate >= 1.8,- gloss-raster-accelerate >= 1.8+ Main-is: Main.hs+ other-modules:+ Common.Type+ Config+ Gloss.Draw+ Gloss.Event+ Ray.Intersect+ Ray.Trace+ Scene.Light+ Scene.Object+ Scene.State+ Scene.World - ghc-options: -Wall -O2 -threaded -threaded -rtsopts ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T + if !flag(ray)+ buildable: False+ else+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , colour-accelerate >= 0.1+ , fclabels >= 1.0+ , gloss >= 1.8+ , gloss-accelerate >= 0.2+ , gloss-raster-accelerate >= 0.2+ , lens-accelerate >= 0.1+ , linear-accelerate >= 0.3 + -- K-means -- ------- Executable accelerate-kmeans- Main-is: Main.hs hs-source-dirs: examples/kmeans- other-modules: Config- Main- Kmeans- GenSamples+ Main-is: Main.hs+ other-modules: Config Main Kmeans GenSamples - if !flag(kmeans)- buildable: False- else- build-depends: accelerate == 0.15.*,- accelerate-examples == 0.15.*,- base >= 4.7 && < 4.9,- binary >= 0.7,- directory >= 1.1,- fclabels >= 1.0,- normaldistribution,- random+ ghc-prof-options: -auto-all+ ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M if flag(ekg) ghc-options: -with-rtsopts=-T - ghc-options: -Wall -O2 -threaded -threaded -rtsopts- ghc-prof-options: -auto-all+ if !flag(kmeans)+ buildable: False+ else+ build-depends:+ base >= 4.7 && < 4.10+ , accelerate == 1.0.*+ , accelerate-examples == 1.0.*+ , binary >= 0.7+ , directory >= 1.1+ , fclabels >= 1.0+ , normaldistribution+ , random +source-repository head+ type: git+ location: https://github.com/AccelerateHS/accelerate-examples+ source-repository this type: git+ tag: 1.0.0.0 location: https://github.com/AccelerateHS/accelerate-examples- branch: release/0.15- tag: 0.15.1.0++-- vim: nospell
− data/hashcat/README.md
@@ -1,30 +0,0 @@-The `accelerate-hashcat` program attempts to recover the plain text of an MD5-hash by comparing the unknown to the hash of every entry in a given dictionary,-which contains one word per line.--Some \*nix systems ship with an MD5 implementation which can be used to generate-hashes, try one of:-- $ md5 -s password- MD5 ("password") = 5f4dcc3b5aa765d61d8327deb882cf99-- $ echo -n password | md5sum- 5f4dcc3b5aa765d61d8327deb882cf99 ---In the second example the `-n` argument to `echo` is required to omit the-trailing newline, which will change the computed hash value.--Standard dictionaries can also be found on most systems, and can be fed directly-into the program.-- $ accelerate-hashcat -s 5f4dcc3b5aa765d61d8327deb882cf99 -d /usr/share/dict/english--The program will also accept multiple unknowns to recover, either via multiple-`-s` arguments or read from file, one per line.--Of course, it is more fun if we don't know what what results to expect-beforehand, in which case a dictionary of standard words won't get us too far.-Luckily, the Internet is a playground...-- $ accelerate-hashcat -d rockyou.txt md5.txt-
+ examples/canny/README.md view
@@ -0,0 +1,25 @@+accelerate-canny+================++Implementation of the [canny edge detector][wikipedia-canny] in Accelerate. The+majority of the algorithm is data-parallel and implemented in accelerate, with+the final (sequential) phase implemented using [repa][repa]. Uses+[accelerate-io][accelerate-io] to convert between the Accelerate and Repa array+representations.++Example+-------++> accelerate-canny data/images/lena256.bmp edges.bmp++| Original image | Result |+:---------------:|:------:|+| ![lena][lena] | ![edges][edges]+++ [repa]: https://hackage.haskell.org/package/repa+ [accelerate-io]: https://hackage.haskell.org/package/accelerate-io+ [wikipedia-canny]: https://en.wikipedia.org/wiki/Canny_edge_detector+ [lena]: https://github.com/AccelerateHS/accelerate-examples/raw/master/data/images/lena256.bmp+ [edges]: https://github.com/AccelerateHS/accelerate-examples/raw/master/samples/canny.bmp+
examples/canny/src-acc/Canny.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-} -- An implementation of the Canny edge detection algorithm -- -- J. F. Canny, "A Computational Approach to Edge Detection" in _Pattern@@ -12,15 +14,16 @@ module Canny where -import Prelude as P+import qualified Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Data.Colour.RGB hiding ( clamp ) -- Canny algorithm ------------------------------------------------------------- -canny :: Float -> Float -> Acc (Image RGBA) -> (Acc (Image Float), Acc (Vector Int))+canny :: Float -> Float -> Acc (Image RGBA32) -> (Acc (Image Float), Acc (Vector Int)) canny (constant -> low) (constant -> high) = stage1 . nonMaximumSuppression low high@@ -34,7 +37,6 @@ -- Accelerate component -------------------------------------------------------- -type RGBA = Word32 type Image a = Array DIM2 a type Stencil5x1 a = (Stencil3 a, Stencil5 a, Stencil3 a)@@ -62,19 +64,19 @@ edge' :: Edge -> Exp Float edge' = constant . edge -convolve5x1 :: (Elt a, IsNum a) => [Exp a] -> Stencil5x1 a -> Exp a+convolve5x1 :: Num a => [Exp a] -> Stencil5x1 a -> Exp a convolve5x1 kernel (_, (a,b,c,d,e), _) = P.sum $ P.zipWith (*) kernel [a,b,c,d,e] -convolve1x5 :: (Elt a, IsNum a) => [Exp a] -> Stencil1x5 a -> Exp a+convolve1x5 :: Num a => [Exp a] -> Stencil1x5 a -> Exp a convolve1x5 kernel ((_,a,_), (_,b,_), (_,c,_), (_,d,_), (_,e,_)) = P.sum $ P.zipWith (*) kernel [a,b,c,d,e] -- RGB to Greyscale conversion, in the range [0,255] ---toGreyscale :: Acc (Image RGBA) -> Acc (Image Float)-toGreyscale = A.map (\rgba -> 255 * luminanceOfRGBA32 rgba)+toGreyscale :: Acc (Image RGBA32) -> Acc (Image Float)+toGreyscale = map (\rgba -> 255 * luminance (unpackRGB rgba)) -- Separable Gaussian blur in the x- and y-directions@@ -141,11 +143,11 @@ alpha = (theta - (pi/8)) * (4/pi) -- Normalise the angle to between [0..8)- norm = alpha + 8 * A.fromIntegral (boolToInt (alpha <=* 0))+ norm = alpha + 8 * fromIntegral (boolToInt (alpha <= 0)) -- Try to avoid doing explicit tests, to avoid warp divergence- undef = abs dx <=* low &&* abs dy <=* low- dir = boolToInt (A.not undef) * ((64 * (1 + A.floor norm `mod` 4)) `min` 255)+ undef = abs dx <= low && abs dy <= low+ dir = boolToInt (not undef) * ((64 * (1 + floor norm `mod` 4)) `min` 255) in lift (mag, dir) @@ -178,8 +180,8 @@ -- | -- 255 --- --- --- offsetx = dir A.>* orient' Vert ? (-1, dir A.<* orient' Vert ? (1, 0))- offsety = dir A.<* orient' Horiz ? (-1, 0)+ offsetx = dir > orient' Vert ? (-1, dir < orient' Vert ? (1, 0))+ offsety = dir < orient' Horiz ? (-1, 0) (fwd, _) = unlift $ magdir ! lift (clamp (Z :. y+offsety :. x+offsetx)) :: (Exp Float, Exp Int) (rev, _) = unlift $ magdir ! lift (clamp (Z :. y-offsety :. x-offsetx)) :: (Exp Float, Exp Int)@@ -188,10 +190,10 @@ -- Try to avoid doing explicit tests to avoid warp divergence. --- none = dir ==* orient' Undef ||* mag A.<* low ||* mag A.<* fwd ||* mag A.<* rev- strong = mag >=* high+ none = dir == orient' Undef || mag < low || mag < fwd || mag < rev+ strong = mag >= high in- A.fromIntegral (boolToInt (A.not none) * (1 + boolToInt strong)) * 0.5+ fromIntegral (boolToInt (not none) * (1 + boolToInt strong)) * 0.5 -- Extract the linear indices of the strong edges@@ -200,10 +202,10 @@ :: Acc (Image Float) -> Acc (Array DIM1 Int) selectStrong img =- let strong = A.map (\x -> boolToInt (x ==* edge' Strong)) (flatten img)- (targetIdx, len) = A.scanl' (+) 0 strong- indices = A.enumFromN (index1 $ size img) 0- zeros = A.fill (index1 $ the len) 0+ let strong = map (\x -> boolToInt (x == edge' Strong)) (flatten img)+ (targetIdx, len) = scanl' (+) 0 strong+ indices = enumFromN (index1 $ size img) 0+ zeros = fill (index1 $ the len) 0 in- A.permute const zeros (\ix -> strong!ix ==* 0 ? (ignore, index1 $ targetIdx!ix)) indices+ permute const zeros (\ix -> strong!ix == 0 ? (ignore, index1 $ targetIdx!ix)) indices
examples/canny/src-acc/Main.hs view
@@ -22,11 +22,10 @@ main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer (fileIn, fileOut) <- case rest of (i:o:_) -> return (i,o)- _ -> parseArgs options defaults header footer ("--help":argv)+ _ -> withArgs ["--help"] $ parseArgs options defaults header footer >> exitSuccess -- Read in the image file
examples/crystal/Main.hs view
@@ -12,10 +12,11 @@ import Config import Data.Label ( get )-import System.Environment -import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate as A hiding ( size, (==) ) import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.Data.Colour.RGBA+ import Graphics.Gloss.Accelerate.Raster.Field as G @@ -38,7 +39,7 @@ -- Point ---------------------------------------------------------------------- -- | Compute a single point of the visualisation.-quasicrystal :: Scale -> Degree -> Exp Time -> Exp Point -> Exp Color+quasicrystal :: Scale -> Degree -> Exp Time -> Exp Point -> Exp Colour quasicrystal scale degree time p = let -- Scale the time to be the phi value of the animation. -- The action seems to slow down at increasing phi values, so we@@ -61,6 +62,7 @@ | n == 0 = acc | otherwise = waver (n - 1) (acc + wave (A.constant (P.fromIntegral n) * th) x) + wrap :: Exp Float -> Exp Float wrap n = let n_ = A.truncate n :: Exp Int n' = n - A.fromIntegral n_@@ -83,8 +85,8 @@ scale' = A.constant scale -- | Colour ramp from red to white, convert into RGBA-rampColour :: Exp Float -> Exp Color-rampColour v = rawColor 1 (0.4 + (v * 0.6)) v 1+rampColour :: Exp Float -> Exp Colour+rampColour v = lift $ RGBA 1 (0.4 + (v * 0.6)) v 1 -- Main -----------------------------------------------------------------------@@ -92,8 +94,7 @@ main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer let size = get configSize conf zoom = get configZoom conf
examples/fft/src-acc/FFT.hs view
@@ -2,35 +2,38 @@ module FFT where -import Prelude as P+import qualified Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Data.Colour.RGBA as A import Data.Array.Accelerate.Data.Complex as A import Data.Array.Accelerate.Math.FFT as A import Data.Array.Accelerate.Math.DFT.Centre as A -imageFFT :: Int -> Int -> Int -> Acc (Array DIM2 RGBA32) -> Acc (Array DIM2 RGBA32, Array DIM2 RGBA32)-imageFFT width height cutoff img = lift (arrMag, arrPhase)+imageFFT :: DIM2 -> Int -> Acc (Array DIM2 RGBA32) -> Acc (Array DIM2 RGBA32, Array DIM2 RGBA32)+imageFFT sh cutoff img = lift (arrMag, arrPhase) where -- Load in the image luminance arrComplex :: Acc (Array DIM2 (Complex Float)) arrComplex = A.map (\r -> lift (r :+ constant 0))- $ A.map luminanceOfRGBA32 img+ $ A.map (luminance . unpackRGBA) img -- Apply the centering transform so that the output has the zero frequency -- in the middle of the image arrCentered = centre2D arrComplex -- Do the transform- arrFreq = fft2D' Forward width height arrCentered+ arrFreq = fft2D' Forward sh arrCentered -- Clip the magnitude of the transformed array clipMag = the (unit (constant (P.fromIntegral cutoff)))- clip x = x >* clipMag ? ( 1 , x / clipMag )- arrMag = A.map (rgba32OfLuminance . clip . magnitude) arrFreq+ clip x = x > clipMag ? ( 1 , x / clipMag )+ arrMag = A.map (packRGBA . grey . clip . magnitude) arrFreq -- Get the phase of the transformed array scale x = (phase x + pi) / (2 * pi)- arrPhase = A.map (rgba32OfLuminance . scale) arrFreq+ arrPhase = A.map (packRGBA . grey . scale) arrFreq++ grey x = rgba x x x 1
examples/fft/src-acc/HighPass.hs view
@@ -1,26 +1,32 @@+{-# LANGUAGE NoImplicitPrelude #-} module HighPass where -import Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Data.Colour.RGBA as A import Data.Array.Accelerate.Math.FFT as A import Data.Array.Accelerate.Math.DFT.Centre as A import Data.Array.Accelerate.Data.Complex as A -highpassFFT :: Int -> Int -> Int -> Acc (Array DIM2 RGBA32) -> Acc (Array DIM2 RGBA32)-highpassFFT width height cutoff img = A.map A.packRGBA32 (A.zip4 r' g' b' a)+highpassFFT :: DIM2 -> Int -> Acc (Array DIM2 RGBA32) -> Acc (Array DIM2 RGBA32)+highpassFFT sh cutoff img = img' where- (r,g,b,a) = A.unzip4 $ A.map unpackRGBA32 img- r' = transform width height cutoff r- g' = transform width height cutoff g- b' = transform width height cutoff b+ (r,g,b,a) = A.unzip4+ $ A.map (\c -> let RGBA x y z w = unlift c :: RGBA (Exp Word8)+ in lift (x,y,z,w) :: Exp (Word8, Word8, Word8, Word8))+ $ A.map unpackRGBA8 img+ r' = transform sh cutoff r+ g' = transform sh cutoff g+ b' = transform sh cutoff b+ --+ img' = A.zipWith4 (\x y z w -> packRGBA8 . lift $ RGBA x y z w) r' g' b' a -transform :: Int -> Int -> Int -> Acc (Array DIM2 Word8) -> Acc (Array DIM2 Word8)-transform width height cutoff' arrReal = arrResult+transform :: DIM2 -> Int -> Acc (Array DIM2 Word8) -> Acc (Array DIM2 Word8)+transform sh@(Z :. height :. width) cutoff' arrReal = arrResult where cutoff = the (unit (constant cutoff')) @@ -29,22 +35,22 @@ -- Do the 2D transform arrCentered = centre2D arrComplex- arrFreq = fft2D' Forward width height arrCentered+ arrFreq = fft2D' Forward sh arrCentered -- Zap out the low-frequency components centreX = constant (width `div` 2) centreY = constant (height `div` 2) zap ix = let (Z :. y :. x) = unlift ix- inx = x >* centreX - cutoff &&* x A.<* centreX + cutoff- iny = y >* centreY - cutoff &&* y A.<* centreY + cutoff+ inx = x > centreX - cutoff && x A.< centreX + cutoff+ iny = y > centreY - cutoff && y A.< centreY + cutoff in- inx &&* iny ? (constant (0 :+ 0), arrFreq A.! ix)+ inx && iny ? (constant (0 :+ 0), arrFreq A.! ix) arrFilt = A.generate (A.shape arrFreq) zap -- Do the inverse transform to get back to image space- arrInv = fft2D' Inverse width height arrFilt+ arrInv = fft2D' Inverse sh arrFilt -- The magnitude of the transformed array arrResult = A.map (A.truncate . magnitude) arrInv
examples/fft/src-acc/Main.hs view
@@ -22,16 +22,14 @@ main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer (fileIn, fileOut) <- case rest of (i:o:_) -> return (i,o)- _ -> parseArgs options defaults header footer ("--help":argv)+ _ -> withArgs ["--help"] $ parseArgs options defaults header footer >> exitSuccess -- Read in the image file img <- either (error . show) id `fmap` A.readImageFromBMP fileIn- let Z :. height :. width = A.arrayShape img -- Set up the operations let (file,bmp) = splitExtension fileOut@@ -43,18 +41,20 @@ clip = get configClip conf backend = get optBackend opts + sh = A.arrayShape img+ -- Write out the images to file --- highpass = run backend $ highpassFFT width height cutoff (use img)- (mag, phase) = run backend $ imageFFT width height clip (use img)+ highpass = run backend $ highpassFFT sh cutoff (use img)+ (mag, phase) = run backend $ imageFFT sh clip (use img) writeImageToBMP fileHP highpass writeImageToBMP fileMag mag writeImageToBMP filePhase phase runBenchmarks opts (P.drop 2 rest)- [ bench "highpass" $ whnf (run1 backend (highpassFFT width height cutoff)) img- , bench "fft" $ whnf (run1 backend (imageFFT width height clip)) img+ [ bench "highpass" $ whnf (run1 backend (highpassFFT sh cutoff)) img+ , bench "fft" $ whnf (run1 backend (imageFFT sh clip)) img ]
+ examples/fluid/README.md view
@@ -0,0 +1,54 @@+A Stable Fluid Simulation+=========================++This is an implementation of the fluid simulation described in the paper+_Real-time Fluid Dynamics for Games_ (Jos Stam, GDC 2003).+++Usage+-----++Running the program opens a window which displays the current state of the+simulation.++Execute with the flag `--help` to display a complete list of command-line+options and runtime controls.++To interact within the simulation window:++ * _click:_ add particles to the simulation+ * _shift-click-drag:_ introduce forces, proportional to the speed of motion+ * _r:_ reset the simulation to the initial state+ * _d:_ toggle display of the density (particle) field+ * _v:_ toggle display of velocity field lines+++Notes+-----++The animation package does not drop frames that arrive late, so if you request a+framerate that is too high, the frames will back up and the program slowly grind+to a halt. You can test the capability of your hardware, instead of running the+simulation proper, by executing with the flag `--benchmark`. Select a+`--framerate` and simulation `--width` & `--height` as appropriate.++When running in the CUDA backend, it will take several seconds before all+kernels are compiled and the simulation is ready.++It is often nice to start with some initial data, rather than a blank screen.+You can use the flags `--bmp-density` and/or `--bmp-velocity` to introduce+initial conditions by reading from a bitmap image file. Try using one of the+images located in `data/images` as an initial density source.+++Alternatives+------------++The original C implementation by Jus Stam is included in this distribution. The+paper describing the implementation can be found here:+<http://www.dgp.toronto.edu/people/stam/reality/Research/pdf/GDC03.pdf>++An implementation using Repa can be found as part of the gloss-examples package.+<http://hackage.haskell.org/package/gloss-examples>++
examples/fluid/src-acc/Config.hs view
@@ -12,8 +12,10 @@ import Data.Label import Control.Monad import Prelude as P+ import Data.Array.Accelerate as A import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Data.Colour.RGBA as A import Data.Array.Accelerate.Examples.Internal as A @@ -162,6 +164,7 @@ footer = [ "" , "Runtime usage:"+ , " ESC quit" , " click add density sources to the image" , " shift-click add velocity sources" , " r reset the image"@@ -214,11 +217,11 @@ y' = A.fromIntegral y tx = 10 * (x' - xc) / width' ty = 10 * (y' - yc) / height'- xk1 = abs tx >* 3*pi/2 ? (0 , cos tx)- yk1 = abs ty >* 3*pi/2 ? (0 , cos ty)+ xk1 = abs tx A.> 3*pi/2 ? (0 , cos tx)+ yk1 = abs ty A.> 3*pi/2 ? (0 , cos ty) d1 = xk1 * yk1 in- 0 `max` d1+ 0 `A.max` d1 in run backend $ A.generate (constant (Z:.height:.width)) checks @@ -270,10 +273,10 @@ = do arr <- either (error . show) id `fmap` readImageFromBMP filepath let Z:.h:.w = arrayShape arr - when (w /= width || h /= height)+ when (w P./= width P.|| h P./= height) $ error "accelerate-fluid: density-bmp does not match width x height" - return . run backend $ A.map luminanceOfRGBA32 (use arr)+ return . run backend $ A.map (luminance . unpackRGBA) (use arr) loadVelocity_bmp :: Backend -> FilePath -> Int -> Int -> IO VelocityField@@ -281,13 +284,13 @@ = do arr <- either (error . show) id `fmap` readImageFromBMP filepath let Z:.h:.w = arrayShape arr - when (w /= width || h /= height)+ when (w P./= width P.|| h P./= height) $ error "accelerate-fluid: velocity-bmp does not match width x height" let conv rgb =- let (r,g,_,_) = unlift (unpackRGBA32 rgb) :: (Exp Word8, Exp Word8, Exp Word8, Exp Word8)- r' = A.fromIntegral (-128 + A.fromIntegral r :: Exp Int)- g' = A.fromIntegral (-128 + A.fromIntegral g :: Exp Int)+ let RGBA r g _ _ = unlift (unpackRGBA8 rgb) :: RGBA (Exp Word8)+ r' = A.fromIntegral (-128 + A.fromIntegral r :: Exp Int)+ g' = A.fromIntegral (-128 + A.fromIntegral g :: Exp Int) in lift (r' * 0.0001, g' * 0.0001) return . run backend $ A.map conv (use arr)
examples/fluid/src-acc/Event.hs view
@@ -7,9 +7,11 @@ import Config import World+ import Data.Label-import Graphics.Gloss.Interface.Pure.Game-import Data.Array.Accelerate ( Z(..), (:.)(..) )+import System.Exit+import Graphics.Gloss.Interface.IO.Game+import Data.Array.Accelerate ( Z(..), (:.)(..) ) -- Event locations are returned as window coordinates, where the origin is in@@ -17,13 +19,14 @@ -- size is (100,100) with scale factor of 4, then the event coordinates are -- returned in the range [-200,200]. ---react :: Config -> Event -> World -> World+react :: Config -> Event -> World -> IO World react opt event world = case event of- EventKey (Char c) s m _ -> keyboard c s m- EventKey (MouseButton LeftButton) s m uv -> mouse m s (coord uv)- EventMotion uv -> motion (coord uv)- _ -> world+ EventKey (Char c) s m _ -> return $ keyboard c s m+ EventKey (MouseButton LeftButton) s m uv -> return $ mouse m s (coord uv)+ EventMotion uv -> return $ motion (coord uv)+ EventKey (SpecialKey KeyEsc) Down _ _ -> exitSuccess+ _ -> return world where -- Inject a new density source when the left button is clicked. --
examples/fluid/src-acc/Fluid.hs view
@@ -10,10 +10,11 @@ ) where import Type-import Prelude as P-import Data.Array.Accelerate as A+import Data.Array.Accelerate as A +import qualified Prelude as P + type Simulation = Acc ( DensitySource -- locations to add density sources , VelocitySource -- locations to add velocity sources@@ -59,7 +60,7 @@ where grad = A.stencil divF (A.Constant zero) vf p1 = A.stencil2 pF (A.Constant zero) grad (A.Constant zero)- p = foldl1 (.) (P.replicate steps p1) grad+ p = P.foldl1 (.) (P.replicate steps p1) grad poisson :: A.Stencil3x3 Velocity -> A.Stencil3x3 Float -> Exp Velocity poisson (_,(_,uv,_),_) ((_,t,_), (l,_,r), (_,b,_)) = uv .-. 0.5 .*. A.lift (r-l, b-t)@@ -102,7 +103,7 @@ -> Acc (Field e) inject source field = let (is, ps) = A.unlift source- in A.size ps ==* 0+ in A.size ps == 0 ?| ( field, A.permute (.+.) field (is A.!) ps ) @@ -119,8 +120,8 @@ -> Acc (Field e) -> Acc (Field e) diffuse steps dt dn df0 =- a ==* 0- ?| ( df0 , foldl1 (.) (P.replicate steps diffuse1) df0 )+ a == 0+ ?| ( df0 , P.foldl1 (.) (P.replicate steps diffuse1) df0 ) where a = A.constant dt * A.constant dn * (A.fromIntegral (A.size df0)) c = 1 + 4*a@@ -150,7 +151,7 @@ (u, v) = A.unlift (vf A.! ix) -- backtrack densities based on velocity field- clamp z = max (-0.5) . min (z + 0.5)+ clamp z = A.max (-0.5) . A.min (z + 0.5) x = width `clamp` (A.fromIntegral i - A.constant dt * width * u) y = height `clamp` (A.fromIntegral j - A.constant dt * height * v) @@ -168,7 +169,7 @@ -- read the density values surrounding the calculated advection point get ix'@(Z :. j' :. i')- = (j' A.<* 0 ||* i' A.<* 0 ||* j' >=* h ||* i' >=* w)+ = (j' A.< 0 || i' A.< 0 || j' >= h || i' >= w) ? (A.constant zero, df A.! A.lift ix') d00 = get (Z :. j0 :. i0)
examples/fluid/src-acc/Main.hs view
@@ -12,7 +12,6 @@ import Event import Data.Label import Control.Exception-import System.Environment import Graphics.Gloss.Interface.IO.Game import Prelude as P@@ -23,8 +22,7 @@ main :: IO () main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- initialiseConfig =<< parseArgs options defaults header footer argv+ (conf, opts, rest) <- initialiseConfig =<< parseArgs options defaults header footer let -- configuration parameters --@@ -79,6 +77,6 @@ fps -- display framerate initialWorld -- initial state of the simulation (render conf) -- render world state into a picture- (\e -> return . react conf e) -- handle user events+ (react conf) -- handle user events (\_ -> return . simulate) -- one step of the simulation
examples/fluid/src-acc/Type.hs view
@@ -8,7 +8,7 @@ Timestep, Viscosity, Diffusion, Index, Density, Velocity, Field, FieldElt(..), DensityField, VelocityField, DensitySource, VelocitySource, - RGBA, Image+ RGBA32, Image ) where @@ -30,7 +30,7 @@ type DensitySource = Source Density type VelocitySource = Source Velocity -type RGBA = Word32+type RGBA32 = Word32 type Image a = Array DIM2 a
examples/fluid/src-acc/World.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} --@@ -84,9 +85,14 @@ dst <- mallocBytes (n*4) fill 0 src dst fptr <- newForeignPtr finalizerFree dst- return $ bitmapOfForeignPtr w h fptr False+#if MIN_VERSION_gloss_rendering(1,10,0)+ let fmt = BitmapFormat BottomToTop PxABGR+ return $ bitmapOfForeignPtr w h fmt fptr False+#else+ return $ bitmapOfForeignPtr w h fptr False+#endif where- ((),src) = A.ptrsOfArrayData ad+ src = A.ptrsOfArrayData ad Z:.h:.w = A.arrayShape df n = h*w colour !f = let c = 0 `max` f `min` 1
examples/hashcat/Config.hs view
@@ -16,6 +16,9 @@ , _configDict :: FilePath , _configMaxWords :: Maybe Int , _configSkipWords :: Int+ -- , _configNoSeq :: Bool++ , _configHelp :: Bool } deriving Show @@ -28,6 +31,8 @@ , _configDict = [] , _configMaxWords = Nothing , _configSkipWords = 0+ -- , _configNoSeq = True+ , _configHelp = False } @@ -50,6 +55,14 @@ , Option ['n'] ["max-words"] (ReqArg (set configMaxWords . Just . read) "INT") "Use at most this many words from the list"++ -- , Option [] ["noseq"]+ -- (NoArg (set configNoSeq True))+ -- "do not use sequencing"++ , Option ['h', '?'] ["help"]+ (NoArg (set configHelp True))+ "show this help message" ]
examples/hashcat/MD5.hs view
@@ -4,7 +4,7 @@ module MD5 ( Dictionary,- hashcat, readMD5, showMD5+ hashcatWord, hashcatDict, readMD5, showMD5, md5Round ) where @@ -14,24 +14,25 @@ import Control.Applicative import Data.Maybe import Data.List ( foldl' )-import Data.Bits hiding ( rotateL ) import Data.ByteString.Lex.Integral ( readHexadecimal ) import qualified Data.Serialize as S import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Prelude as P+import Prelude as P hiding ( Eq(..), (&&) ) -import Data.Array.Accelerate as A+import Data.Array.Accelerate hiding ( Ord(..) )+import Data.Array.Accelerate.Data.Bits as A+import qualified Data.Array.Accelerate as A -- Generate an MD5 hash for every word in the dictionary, and if an entry -- matches the given unknown md5, returns the index into the dictionary of said -- match. If not found, this returns (-1). ---hashcat :: Acc Dictionary- -> Acc (Scalar MD5)- -> Acc (Scalar Int)-hashcat dict passwd+hashcatDict :: Acc Dictionary+ -> Acc (Scalar MD5)+ -> Acc (Scalar Int)+hashcatDict dict passwd = reshape (constant Z) $ permute const res (\ix -> crypt A.! ix `cmp` the passwd ? (constant (Z:.0), ignore)) (enumFromN (index1 n) 0)@@ -42,9 +43,25 @@ cmp x y = let (x1,x2,x3,x4) = unlift x (y1,y2,y3,y4) = unlift y- in x1 ==* y1 &&* x2 ==* y2 &&* x3 ==* y3 &&* x4 ==* y4+ in x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 +-- Generate an MD5 hash for a single word, and if an entry matches the+-- given unknown md5, returns the given index. If not matched, this+-- returns (-1).+--+hashcatWord :: Acc (Scalar MD5)+ -> Acc (Vector Word32)+ -> Acc (Scalar Int)+ -> Acc (Scalar Int)+hashcatWord passwd word ix+ = unit (crypt `cmp` the passwd ? (the ix, -1))+ where+ crypt = md5Round (\i -> word A.! index1 i)+ cmp x y = let (x1,x2,x3,x4) = unlift x+ (y1,y2,y3,y4) = unlift y+ in x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 + -- An MD5 round processes 512 bits of the input, as 16 x 32-bit values. We -- require that the input dictionary of words to hash is of dimension -- (Z :. 16 :. n), which will then output n MD5 hashes values.@@ -61,16 +78,12 @@ md5 dict = let n = A.snd . unindex2 $ A.shape dict in- A.generate (index1 n) (md5Round dict)-+ A.generate (index1 n) (\ (unindex1 -> ix) -> md5Round (\i -> dict A.! index2 i ix)) --- A single round of MD5. For inputs longer than 512-bits we would simply--- reapply this until we run out of input data to hash.----md5Round :: Acc Dictionary -> Exp DIM1 -> Exp MD5-md5Round word (unindex1 -> ix)+md5Round :: (Exp Int -> Exp Word32) -> Exp MD5+md5Round fetch = lift- $ foldl step (a0,b0,c0,d0) [0..64]+ $ P.foldl step (a0,b0,c0,d0) [0..64] where step (a,b,c,d) i | i < 16 = shfl ((b .&. c) .|. ((complement b) .&. d))@@ -83,10 +96,10 @@ get :: Int -> Exp Word32 get i- | i < 16 = word A.! index2 (constant i) ix- | i < 32 = word A.! index2 (constant ((5*i + 1) `rem` 16)) ix- | i < 48 = word A.! index2 (constant ((3*i + 5) `rem` 16)) ix- | otherwise = word A.! index2 (constant ((7*i) `rem` 16)) ix+ | i < 16 = fetch (constant i)+ | i < 32 = fetch (constant ((5*i + 1) `rem` 16))+ | i < 48 = fetch (constant ((3*i + 5) `rem` 16))+ | otherwise = fetch (constant ((7*i) `rem` 16)) -- Initial values. For a multi-round implementation we would initialise the -- context with these values, and then after applying the round update the@@ -134,7 +147,6 @@ , 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23 , 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 ] - -- Display the result in big endian hexadecimal format, which is consistent with -- other MD5 hash implementations. --@@ -162,4 +174,3 @@ return . P.fst $ fromMaybe (error "readHex32be: parse failure") (readHexadecimal s) in either error id . S.runGetLazy get-
examples/hashcat/Main.hs view
@@ -7,26 +7,26 @@ import Digest import MD5 +import Data.Array.Accelerate ( Z(..), (:.)(..) )+import Data.Array.Accelerate.Examples.Internal as A+import qualified Data.Array.Accelerate as A+ import Data.Label import Text.Printf import Control.Monad import Control.Applicative import Criterion.Measurement import System.IO-import System.Environment-import Data.Array.Accelerate ( Z(..), (:.)(..) )-import Data.Array.Accelerate.Examples.Internal-import qualified Data.Array.Accelerate as A import qualified Data.ByteString.Lazy.Char8 as L-import Prelude +import Prelude as P + main :: IO () main = do initializeTime beginMonitoring- argv <- getArgs- (conf, opts, files) <- parseArgs options defaults header footer argv+ (conf, opts, files) <- parseArgs options defaults header footer -- Read the plain text word lists. This creates a vector of MD5 chunks ready -- for hashing.@@ -46,9 +46,17 @@ -- let backend = get optBackend opts - recover hash =+{--+ recoverSeq hash = let abcd = readMD5 hash- idx = run1 backend (hashcat (A.use dict)) (A.fromList Z [abcd])+ idx = run1 backend l (A.fromList Z [abcd])+ l digest = A.collect+ $ A.foldSeq max (-1)+ $ A.zipWithSeq (hashcatWord digest)+ (A.toSeq (Z :. All :. Split) (A.use dict))+ (A.toSeq (Z :. Split) (iota (Sugar.size (Sugar.shape dict))))++ iota n = A.generate (A.index1 (A.constant n)) A.unindex1 -- in case idx `A.indexArray` Z of -1 -> Nothing@@ -56,7 +64,22 @@ recoverAll :: [L.ByteString] -> IO (Int,Int) recoverAll =- foldM (\(i,n) h -> maybe (return (i,n+1)) (\t -> showText h t >> return (i+1,n+1)) (recover h)) (0,0)+ if get configNoSeq conf+ then go recover+ else go recoverSeq+ where go rec = foldM (\(i,n) h -> maybe (return (i,n+1)) (\t -> showText h t >> return (i+1,n+1)) (rec h)) (0,0)+--}++ recover hash =+ let abcd = readMD5 hash+ idx = run1 backend (hashcatDict (A.use dict)) (A.fromList Z [abcd])+ --+ in case idx `A.indexArray` Z of+ -1 -> Nothing+ n -> Just (extract dict n)++ recoverAll :: [L.ByteString] -> IO (Int,Int)+ recoverAll = foldM (\(i,n) h -> maybe (return (i,n+1)) (\t -> showText h t >> return (i+1,n+1)) (recover h)) (0,0) showText hash text = do L.putStr hash >> putStr ": " >> L.putStrLn text
+ examples/hashcat/README.md view
@@ -0,0 +1,34 @@+accelerate-hashcat+==================++The `accelerate-hashcat` program attempts to recover the plain text of an MD5+hash by comparing the unknown to the hash of every entry in a given dictionary,+which contains one word per line.++Some \*nix systems ship with an MD5 implementation which can be used to generate+hashes, try one of:++ $ md5 -s password+ MD5 ("password") = 5f4dcc3b5aa765d61d8327deb882cf99++ $ echo -n password | md5sum+ 5f4dcc3b5aa765d61d8327deb882cf99 -++In the second example the `-n` argument to `echo` is required to omit the+trailing newline, which will change the computed hash value.++Standard dictionaries can also be found on most systems, and can be fed directly+into the program.++ $ accelerate-hashcat -s 5f4dcc3b5aa765d61d8327deb882cf99 -d /usr/share/dict/english++The program will also accept multiple unknowns to recover, either via multiple+`-s` arguments or read from file, one per line.++Of course, it is more fun if we don't know what what results to expect+beforehand, in which case a dictionary of standard words won't get us too far.+Luckily, the Internet is a+[playground](https://wiki.skullsecurity.org/index.php?title=Passwords)...++ $ accelerate-hashcat -d rockyou.txt md5.txt+
examples/kmeans/Kmeans.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.Kmeans -- Copyright : [2014] Trevor L. McDonell@@ -60,19 +62,19 @@ -- Get the distance (squared) between two points. Since we only compare this -- value, we elide the square root. ---distance :: (Elt a, IsNum a) => Exp (Point a) -> Exp (Point a) -> Exp a+distance :: A.Num a => Exp (Point a) -> Exp (Point a) -> Exp a distance u v = let (x1,y1) = unlift u (x2,y2) = unlift v in- (x1-x2)^(2::Int) + (y1-y2)^(2::Int)+ (x1-x2) P.^ (2::Int) + (y1-y2) P.^ (2::Int) -- For each of the given points, return the cluster Id that that that point is -- closest to. -- findClosestCluster- :: forall a. (Elt a, IsFloating a, RealFloat a)+ :: forall a. (A.RealFloat a, P.RealFloat a) => Acc (Vector (Cluster a)) -> Acc (Vector (Point a)) -> Acc (Vector Id)@@ -86,7 +88,7 @@ let d = A.snd st d' = distance p (centroidOfCluster c) in- d' A.<* d ? ( lift (idOfCluster c, d') , st )+ d' A.< d ? ( lift (idOfCluster c, d') , st ) -- Given a vector of points and a vector of clusters we, we first locate the@@ -95,7 +97,7 @@ -- locations. -- makeNewClusters- :: forall a. (Elt a, IsFloating a, RealFloat a)+ :: forall a. (A.RealFloat a, P.RealFloat a, A.FromIntegral Word32 a) => Acc (Vector (Point a)) -> Acc (Vector (Cluster a)) -> Acc (Vector (Cluster a))@@ -137,7 +139,7 @@ -- and number of points assigned to each centroid. -- makePointSum :: Acc (Vector Id) -> Acc (Vector (PointSum a))- makePointSum = A.fold1 addPointSum . pointSum+ makePointSum = A.fold1 addPointSum . compute . pointSum -- The point sum is an intermediate 2D array (it gets fused away, so does -- not exist in memory). The points are laid out along the innermost@@ -154,9 +156,9 @@ near = nearest ! index1 j yes = lift (constant 1, points ! index1 j)- no = constant (0, (0,0))+ no = constant (0, (0, 0)) in- near ==* A.fromIntegral i ? ( yes, no ))+ near A.== A.fromIntegral i ? ( yes, no )) addPointSum :: Exp (PointSum a) -> Exp (PointSum a) -> Exp (PointSum a) addPointSum x y =@@ -190,7 +192,7 @@ -- positions, until the positions converge (or some maximum iteration limit is -- reached?) ---kmeans :: forall a. (Elt a, IsFloating a, RealFloat a)+kmeans :: forall a. (A.RealFloat a, P.RealFloat a, A.FromIntegral Word32 a) => Acc (Vector (Point a)) -- the points to cluster -> Acc (Vector (Cluster a)) -- initial cluster positions (guess) -> Acc (Vector (Cluster a))@@ -209,18 +211,18 @@ $ A.zipWith (\c1 c2 -> let (x1,y1) = unlift (centroidOfCluster c1) (x2,y2) = unlift (centroidOfCluster c2) in- abs (x1-x2) >* 0.01 ||* abs (y1-y2) >* 0.01) xs ys+ abs (x1-x2) A.> 0.01 A.|| abs (y1-y2) A.> 0.01) xs ys -- The largest non-infinite floating point number ---inf :: forall a. RealFloat a => a-inf = encodeFloat m n+inf :: forall a. P.RealFloat a => a+inf = P.encodeFloat m n where a = undefined :: a- b = floatRadix a- e = floatDigits a- (_, e') = floatRange a- m = b ^ e - 1+ b = P.floatRadix a+ e = P.floatDigits a+ (_, e') = P.floatRange a+ m = b P.^ e - 1 n = e' - e
examples/kmeans/Main.hs view
@@ -16,7 +16,6 @@ import Data.Binary ( decodeFile ) import Data.Label ( get ) import System.Directory-import System.Environment import Prelude as P @@ -24,11 +23,10 @@ main = do beginMonitoring- argv <- getArgs- (_, opts, rest) <- parseArgs options defaults header footer argv+ (_, opts, rest) <- parseArgs options defaults header footer - inputs <- (&&) <$> doesFileExist "points.bin"- <*> doesFileExist "clusters"+ inputs <- (P.&&) <$> doesFileExist "points.bin"+ <*> doesFileExist "clusters" unless inputs $ do error "Run the GenSamples program first to generate random data" @@ -45,13 +43,13 @@ initial = A.fromList (Z:.nclusters) initial' points :: Vector (Point Float)- points = A.fromList (Z:.npoints) points'+ points = A.fromList (Z:.npoints) points' -- Warm up first by printing the expected results -- putStrLn $ "number of points: " P.++ show npoints putStrLn $ "final clusters:\n" P.++- unlines (P.map show . A.toList $ solve initial)+ unlines (P.map show (A.toList (solve initial))) -- Now benchmark --
+ examples/kmeans/README.md view
@@ -0,0 +1,38 @@+accelerate-kmeans+=================++Implementation of the [k-means clustering][kmeans-wiki] algorithm in Accelerate.+For simplicity of exposition this implementation is specialised to clustering+points on a two-dimensional plane.++Example+-------++### Preparing sample data++The included [`GenSamples.hs`][GenSamples.hs] program can be used to generate+some random data points to be fed into the clustering algorithm.++> runhaskell GenSamples.hs 5 100 1000 6849++The first parameter specifies the target number of clusters, the second and+third parameters specify the minimum and maximum number of points to generate,+and the fourth parameter is a seed to the random number generator.+++### Running the program++The main application requires that the sample data to analyse be available in+two files in the current directory: `points.bin` contains a list of pairs of+(x,y) coordinates as floating-point numbers, and `clusters` contains the initial+guess of the cluster locations.++Result from running with the above random data (plotted separately):++![kmeans][kmeans-img]+++ [kmeans-wiki]: https://en.wikipedia.org/wiki/K-means_clustering+ [kmeans-img]: https://github.com/AccelerateHS/accelerate-examples/raw/master/samples/k-means.png+ [GenSamples.hs]: https://github.com/AccelerateHS/accelerate-examples/blob/master/examples/kmeans/GenSamples.hs+
examples/mandelbrot/Config.hs view
@@ -10,8 +10,7 @@ { _configWidth :: Int , _configHeight :: Int- , _configLimit :: Int- , _configFramerate :: Int+ , _configFilePath :: Maybe FilePath } deriving Show @@ -21,23 +20,20 @@ defaults = Config { _configWidth = 800 , _configHeight = 600- , _configLimit = 255- , _configFramerate = 25+ , _configFilePath = Nothing } options :: [OptDescr (Config -> Config)] options = [ Option [] ["width"] (ReqArg (set configWidth . read) "INT") "visualisation width (800)" , Option [] ["height"] (ReqArg (set configHeight . read) "INT") "visualisation height (600)"- , Option [] ["limit"] (ReqArg (set configLimit . read) "INT") "iteration limit for escape (255)"- , Option [] ["framerate"] (ReqArg (set configFramerate . read) "INT") "visualisation framerate (10)"- , Option [] ["static"] (NoArg (set configFramerate 0)) "do not animate the image"+ , Option [] ["bmp"] (ReqArg (set configFilePath . Just) "FILE") "save image to file" ] header :: [String] header =- [ "accelerate-mandelbrot (c) [2011..2014] The Accelerate Team"+ [ "accelerate-mandelbrot (c) [2011..2016] The Accelerate Team" , "" , "Usage: accelerate-mandelbrot [OPTIONS]" , ""@@ -47,11 +43,15 @@ footer = [ "" , "Runtime usage:"- , " arrows translate display"- , " z ; zoom in"- , " x q zoom out"- , " f single precision calculations"- , " d double precision calculations (if supported)"+ , " ESC quit"+ , " mouse drag translate display"+ , " w/s zoom in/out"+ , " a/d iteration count"+ , " z/c escape radius"+ , " 0 .. 9 select presets"+ , " r reset display"+ , " . print current configuration"+ , " p switch between single/double precision" , "" ]
examples/mandelbrot/Main.hs view
@@ -7,55 +7,37 @@ import Config import Data.Label-import System.Environment ( getArgs ) -import Prelude as P-import Data.Array.Accelerate as A-import Data.Array.Accelerate.Examples.Internal as A-import Graphics.Gloss.Accelerate.Data.Picture as G-import qualified Graphics.Gloss as G+import Prelude as P+import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Examples.Internal as A+import qualified Graphics.Gloss.Interface.IO.Game as G -- Main ------------------------------------------------------------------------ -makePicture :: World -> G.Picture-makePicture world = bitmapOfArray (renderWorld world) False-- main :: IO () main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer - let world = initialWorld conf opts view- fps = get configFramerate conf+ let world = initialWorld conf opts+ bmp = get configFilePath conf width = get configWidth conf height = get configHeight conf - -- Centre coordinates: Re(c) = -0.7; Im(c) = 0- -- View width: 3.067- --- view = (-2.23, -1.15, 0.83, 1.15)-- force arr = indexArray arr (Z:.0:.0) `seq` arr- runBenchmarks opts rest- [ bench "mandelbrot" $ whnf (force . renderWorld) world ]-- runInteractive opts rest- $ if fps == 0- then G.display- (G.InWindow "Mandelbrot" (width, height) (10, 10))- G.black- (makePicture world)+ [ bench "mandelbrot" $ whnf renderWorld world ] - else G.play- (G.InWindow "Mandelbrot" (width, height) (10, 10))- G.black- fps- world- makePicture- (react conf opts)- (const refocus)+ case bmp of+ Just path -> writeImageToBMP path (renderWorld world)+ Nothing ->+ runInteractive opts rest $+ G.playIO (G.InWindow "Mandelbrot" (width,height) (10,10))+ G.black+ 60+ (updateWorld world)+ draw+ (react conf opts)+ advance
examples/mandelbrot/Mandel.hs view
@@ -1,161 +1,170 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}------ A Mandelbrot set generator.--- Originally submitted by Simon Marlow as part of Issue #49.----module Mandel (+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-} - -- Types- View, Render, Bitmap,+module Mandel where - -- Pretty pictures- mandelbrot, prettyRGBA,+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Complex as A+import Data.Array.Accelerate.Data.Colour.RGB as A+import Data.Array.Accelerate.Data.Colour.Names as A -) where+import Prelude ( fromInteger )+import qualified Prelude as P -import Prelude as P-import Data.Array.Accelerate as A-import Data.Array.Accelerate.IO as A-import Data.Array.Accelerate.Data.Complex --- Types -----------------------------------------------------------------------+mandelbrot+ :: forall a. (Num a, RealFloat a, FromIntegral Int a)+ => Int -- ^ image width+ -> Int -- ^ image height+ -> Acc (Scalar a) -- ^ centre x+ -> Acc (Scalar a) -- ^ centre y+ -> Acc (Scalar a) -- ^ view width+ -> Acc (Scalar Int32) -- ^ iteration limit+ -> Acc (Scalar a) -- ^ divergence radius+ -> Acc (Array DIM2 (Complex a, Int32))+mandelbrot screenX screenY (the -> x0) (the -> y0) (the -> width) (the -> limit) (the -> radius) =+ A.generate (A.constant (Z :. screenY :. screenX))+ (\ix -> let z0 = complexOfPixel ix+ zn = while (\zi -> snd zi < limit+ && dot (fst zi) < radius)+ (\zi -> step z0 zi)+ (lift (z0, constant 0))+ in+ zn)+ where+ -- Convert the given array index, representing a pixel in the final image,+ -- into the corresponding point on the complex plane.+ --+ complexOfPixel :: Exp DIM2 -> Exp (Complex a)+ complexOfPixel (unlift -> Z :. y :. x) =+ let+ height = P.fromIntegral screenY / P.fromIntegral screenX * width+ xmin = x0 - width / 2+ ymin = y0 - height / 2+ --+ re = xmin + (fromIntegral x * width) / fromIntegral (constant screenX)+ im = ymin + (fromIntegral y * height) / fromIntegral (constant screenY)+ in+ lift (re :+ im) --- Current view into the complex plane-type View a = (a, a, a, a)+ -- Divergence condition+ --+ dot :: Exp (Complex a) -> Exp a+ dot (unlift -> x :+ y) = x*x + y*y --- Image data-type Bitmap = Array DIM2 RGBA32+ -- Take a single step of the recurrence relation+ --+ step :: Exp (Complex a) -> Exp (Complex a, Int32) -> Exp (Complex a, Int32)+ step c (unlift -> (z, i)) = lift (next c z, i + constant 1) --- Action to render a frame-type Render a = Scalar (View a) -> Bitmap+ next :: Exp (Complex a) -> Exp (Complex a) -> Exp (Complex a)+ next c z = c + z * z --- Mandelbrot Set ------------------------------------------------------------------ Compute the mandelbrot as repeated application of the recurrence relation:------ Z_{n+1} = c + Z_n^2+-- Convert the iteration count on escape to a colour. ----- This returns the iteration depth 'i' at divergence.+-- Uses the method described here:+-- <http://stackoverflow.com/questions/16500656/which-color-gradient-is-used-to-color-mandelbrot-in-wikipedia> ---mandelbrot- :: forall a. (Elt a, IsFloating a)- => Int- -> Int- -> Int- -> Acc (Scalar (View a))- -> Acc (Array DIM2 Int32)-mandelbrot screenX screenY depth view =- generate (constant (Z:.screenY:.screenX))- (\ix -> let c = initial ix- in A.snd $ A.while (\zi -> A.snd zi A.<* lIMIT &&* dot (A.fst zi) A.<* 4)- (\zi -> lift1 (next c) zi)- (lift (c, constant 0)))- where- -- The view plane- (xmin,ymin,xmax,ymax) = unlift (the view)- sizex = xmax - xmin- sizey = ymax - ymin-- viewx = constant (P.fromIntegral screenX)- viewy = constant (P.fromIntegral screenY)-- -- initial conditions for a given pixel in the window, translated to the- -- corresponding point in the complex plane- initial :: Exp DIM2 -> Exp (Complex a)- initial ix = lift ( (xmin + (x * sizex) / viewx) :+ (ymin + (y * sizey) / viewy) )+escapeToColour+ :: (RealFloat a, ToFloating Int32 a)+ => Acc (Scalar Int32)+ -> Exp (Complex a, Int32)+ -> Exp Colour+escapeToColour (the -> limit) (unlift -> (z, n)) =+ if n == limit+ then black+ else ultra (toFloating ix / toFloating points) where- pr = unindex2 ix- x = A.fromIntegral (A.snd pr :: Exp Int)- y = A.fromIntegral (A.fst pr :: Exp Int)-- -- take a single step of the iteration- next :: Exp (Complex a) -> (Exp (Complex a), Exp Int32) -> (Exp (Complex a), Exp Int32)- next c (z, i) = (c + (z * z), i+1)+ mag = magnitude z+ smooth = logBase 2 (logBase 2 mag)+ ix = truncate (sqrt (toFloating n + 1 - smooth) * scale + shift) `mod` points+ --+ scale = 256+ shift = 1664+ points = 2048 :: Exp Int - dot c = let r :+ i = unlift c- in r*r + i*i+escapeToRGBA+ :: (RealFloat a, ToFloating Int32 a)+ => Acc (Scalar Int32)+ -> Acc (Vector Word32)+ -> Exp (Complex a, Int32)+ -> Exp Word32+escapeToRGBA (the -> limit) palette (unlift -> (z, n)) =+ if n == limit+ then packRGB black+ else palette ! index1 ix+ where+ mag = magnitude z+ smooth = logBase 2 (logBase 2 mag)+ ix = truncate (sqrt (toFloating n + 1 - smooth) * scale + shift) `mod` length palette+ --+ scale = 256+ shift = 1664 - lIMIT = P.fromIntegral depth+ultraPalette+ :: Int+ -> Acc (Vector Word32)+ultraPalette points+ = A.generate (A.constant (Z :. points))+ (\ix -> packRGB (ultra (A.toFloating (A.unindex1 ix) / P.fromIntegral points))) --- Rendering ---------------------------------------------------------------------prettyRGBA :: Exp Int32 -> Exp Int32 -> Exp RGBA32-prettyRGBA cmax c = c ==* cmax ? ( 0xFF000000, escapeToColour (cmax - c) )---- Directly convert the iteration count on escape to a colour. The base set--- (x,y,z) yields a dark background with light highlights.------ Note that OpenGL reads pixel data in AGBR format, rather than RGBA.+-- Pick a nice colour, given a number in the range [0,1]. ---escapeToColour :: Exp Int32 -> Exp RGBA32-escapeToColour m = constant 0xFFFFFFFF - (packRGBA32 $ lift (a,b,g,r))+ultra :: Exp Float -> Exp Colour+ultra p =+ if p <= p1 then interp (p0,p1) (c0,c1) (m0,m1) p else+ if p <= p2 then interp (p1,p2) (c1,c2) (m1,m2) p else+ if p <= p3 then interp (p2,p3) (c2,c3) (m2,m3) p else+ if p <= p4 then interp (p3,p4) (c3,c4) (m3,m4) p else+ interp (p4,p5) (c4,c5) (m4,m5) p where- r = A.fromIntegral (3 * m)- g = A.fromIntegral (5 * m)- b = A.fromIntegral (7 * m)- a = constant 0+ p0 = 0.0 ; c0 = rgb8 0 7 100 ; m0 = (0.7843138, 2.4509804, 2.52451)+ p1 = 0.16 ; c1 = rgb8 32 107 203 ; m1 = (1.93816, 2.341629, 1.6544118)+ p2 = 0.42 ; c2 = rgb8 237 255 255 ; m2 = (1.7046283, 0.0, 0.0)+ p3 = 0.6425 ; c3 = rgb8 255 170 0 ; m3 = (0.0, -2.2812111, 0.0)+ p4 = 0.8575 ; c4 = rgb8 0 2 0 ; m4 = (0.0, 0.0, 0.0)+ p5 = 1.0 ; c5 = c0 ; m5 = m0 + -- interpolate each of the RGB components+ interp (x0,x1) (y0,y1) ((mr0,mg0,mb0),(mr1,mg1,mb1)) x =+ let+ RGB r0 g0 b0 = unlift y0 :: RGB (Exp Float)+ RGB r1 g1 b1 = unlift y1 :: RGB (Exp Float)+ in+ rgb (cubic (x0,x1) (r0,r1) (mr0,mr1) x)+ (cubic (x0,x1) (g0,g1) (mg0,mg1) x)+ (cubic (x0,x1) (b0,b1) (mb0,mb1) x) -{----- A simple colour scheme----prettyRGBA :: Elt a => Exp Int -> Exp (Complex a, Int) -> Exp RGBA32-prettyRGBA lIMIT s' = r + g + b + a- where- s = A.snd s'- t = A.fromIntegral $ ((lIMIT - s) * 255) `quot` lIMIT- r = (t `rem` 128 + 64) * 0x1000000- g = (t * 2 `rem` 128 + 64) * 0x10000- b = (t * 3 `rem` 256 ) * 0x100- a = 0xFF---}-{---prettyRGBA :: forall a. (Elt a, IsFloating a) => Exp Int -> Exp (Complex a, Int) -> Exp RGBA32-prettyRGBA lIMIT s =- let cmax = A.fromIntegral lIMIT :: Exp a- c = A.fromIntegral (A.snd s)+-- cubic interpolation+cubic :: (Exp Float, Exp Float)+ -> (Exp Float, Exp Float)+ -> (Exp Float, Exp Float)+ -> Exp Float+ -> Exp Float+cubic (x0,x1) (y0,y1) (m0,m1) x =+ let+ -- basis functions for cubic hermite spine+ h_00 = (1 + 2*t) * (1 - t) ** 2+ h_10 = t * (1 - t) ** 2+ h_01 = t ** 2 * (3 - 2 * t)+ h_11 = t ** 2 * (t - 1)+ --+ h = x1 - x0+ t = (x - x0) / h in- c >* 0.98 * cmax ? ( 0xFF000000, rampColourHotToCold 0 cmax c )---- Standard Hot-to-Cold hypsometric colour ramp. Colour sequence is--- Red, Yellow, Green, Cyan, Blue----rampColourHotToCold- :: (Elt a, IsFloating a)- => Exp a -- ^ minimum value of the range- -> Exp a -- ^ maximum value of the range- -> Exp a -- ^ data value- -> Exp RGBA32-rampColourHotToCold vmin vmax vNotNorm- = let v = vmin `A.max` vNotNorm `A.min` vmax- dv = vmax - vmin- --- result = v <* vmin + 0.28 * dv- ? ( lift ( constant 0.0- , 4 * (v-vmin) / dv- , constant 1.0- , constant 1.0 )-- , v <* vmin + 0.5 * dv- ? ( lift ( constant 0.0- , constant 1.0- , 1 + 4 * (vmin + 0.25 * dv - v) / dv- , constant 1.0 )+ y0 * h_00 + h * m0 * h_10 + y1 * h_01 + h * m1 * h_11 - , v <* vmin + 0.75 * dv- ? ( lift ( 4 * (v - vmin - 0.5 * dv) / dv- , constant 1.0- , constant 0.0- , constant 1.0 )+-- linear interpolation+linear :: (Exp Float, Exp Float)+ -> (Exp Float, Exp Float)+ -> Exp Float+ -> Exp Float+linear (x0,x1) (y0,y1) x =+ y0 + (x - x0) * (y1 - y0) / (x1 - x0) - , lift ( constant 1.0- , 1 + 4 * (vmin + 0.75 * dv - v) / dv- , constant 0.0- , constant 1.0 )- )))- in- rgba32OfFloat result---}
+ examples/mandelbrot/README.md view
@@ -0,0 +1,16 @@+accelerate-mandelbrot+=====================++Implementation of the [Mandelbrot set][wiki-mandelbrot] in Accelerate. The GUI+program is interactive; use the arrow keys to pan the view port and the 'z' and+'x' keys to zoom in and out respectively.++Example+-------++![mandelbrot][mandelbrot-img]+++ [wiki-mandelbrot]: https://en.wikipedia.org/wiki/Mandelbrot_set+ [mandelbrot-img]: https://github.com/AccelerateHS/accelerate-examples/raw/master/samples/mandelbrot2.jpg+
examples/mandelbrot/World.hs view
@@ -1,204 +1,247 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module World ( - -- Types- World,-- -- Updating the World state- renderWorld, initialWorld, refocus, react+ World(..),+ updateWorld, renderWorld, initialWorld, draw, react, advance, ) where import Mandel import Config -import Prelude as P import Data.Char+import Data.Int import Data.Label-import Data.Array.Accelerate as A-import Data.Array.Accelerate.Examples.Internal as A-import Graphics.Gloss.Interface.Pure.Game hiding ( translate, scale )+import Data.Word+import Graphics.Gloss.Accelerate.Data.Picture as G+import Graphics.Gloss.Interface.Pure.Game hiding ( Vector, translate, scale )+import System.Exit+import Prelude as P +import Data.Array.Accelerate ( Arrays, Array, Scalar, Vector, DIM2, Elt, Acc, Z(..), (:.)(..) )+import Data.Array.Accelerate.Examples.Internal as A+import qualified Data.Array.Accelerate as A + -- World state -- ----------- -data Zoom = In | Out-data Move = Fwd | Rev- data Precision = Float | Double data World where- World :: (Elt a, RealFloat a)- => View a- -> Render a- -> Maybe Zoom- -> Maybe Move -- horizontal movement- -> Maybe Move -- vertical movement- -> World-+ World :: (P.RealFloat a, A.RealFloat a) =>+ { worldPicture :: !Picture+ , worldDirty :: Bool+ , worldPrecision :: Precision+ , worldPalette :: Vector Word32+ , worldRender :: (Scalar a, Scalar a, Scalar a, Scalar Int32, Scalar a) -> Array DIM2 Word32+ , worldSizeX :: !Int+ , worldSizeY :: !Int+ , worldPosX :: Scalar a+ , worldPosY :: Scalar a+ , worldWidth :: Scalar a+ , worldIters :: Scalar Int32+ , worldRadius :: Scalar a+ , worldPanning :: Maybe (Float,Float)+ , worldZooming :: Maybe Double+ }+ -> World --- Render the picture----renderWorld :: World -> Bitmap-renderWorld (World view render _ _ _) = render $ A.fromList Z [view]+initialWorld :: Config -> Options -> World+initialWorld conf opts+ = setPrecision opts Float+ $ loadPreset 0+ $ World { worldDirty = True+ , worldPrecision = Float+ , worldPicture = blank+ , worldPalette = run (get optBackend opts) (ultraPalette 2048)+ , worldSizeX = get configWidth conf+ , worldSizeY = get configHeight conf+ , worldPanning = Nothing+ , worldZooming = Nothing+ , worldPosX = unit 0 :: Scalar Float+ , worldPosY = unit 0+ , worldWidth = unit 0+ , worldRadius = unit 0+ , worldIters = unit 0+ , worldRender = \_ -> A.fromList (Z:.0:.0) []+ } +setPrecision :: Options -> Precision -> World -> World+setPrecision opts prec World{..} =+ let+ mandel :: (A.RealFloat a, A.FromIntegral Int a, A.ToFloating Int32 a)+ => Acc (Scalar a) -> Acc (Scalar a) -> Acc (Scalar a) -> Acc (Scalar Int32) -> Acc (Scalar a) -> Acc (Array DIM2 Word32)+ mandel x y w l r = A.map (escapeToRGBA l (A.use worldPalette)) $ mandelbrot worldSizeX worldSizeY x y w l r --- Initialise the World state----initialWorld :: Config -> Options -> View Float -> World-initialWorld conf opts view- = setPrecisionOfWorld Float conf opts- $ World view undefined Nothing Nothing Nothing+ uncurry5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+ => (Acc a -> Acc b -> Acc c -> Acc d -> Acc e -> Acc f)+ -> (Acc (a,b,c,d,e) -> Acc f)+ uncurry5 f x = let (a,b,c,d,e) = A.unlift x in f a b c d e + backend = get optBackend opts+ in+ case prec of+ Float -> let cvt :: (Elt a, P.Real a) => Scalar a -> Scalar Float+ cvt x = unit (P.realToFrac (the x))+ in+ World { worldPrecision = Float+ , worldPosX = cvt worldPosX+ , worldPosY = cvt worldPosY+ , worldWidth = cvt worldWidth+ , worldRadius = cvt worldRadius+ , worldRender = run1 backend (uncurry5 mandel)+ , ..+ }+ Double -> let cvt :: (Elt a, P.Real a) => Scalar a -> Scalar Double+ cvt x = unit (P.realToFrac (the x))+ in+ World { worldPrecision = Double+ , worldPosX = cvt worldPosX+ , worldPosY = cvt worldPosY+ , worldWidth = cvt worldWidth+ , worldRadius = cvt worldRadius+ , worldRender = run1 backend (uncurry5 mandel)+ , ..+ } --- Reset the rendering routines to compute with the specified precision+-- Draw the world ---setPrecisionOfWorld :: Precision -> Config -> Options -> World -> World-setPrecisionOfWorld f conf opts (World p _ z h v)- = let- width = get configWidth conf- height = get configHeight conf- limit = get configLimit conf- backend = get optBackend opts+draw :: World -> IO Picture+draw = return . worldPicture - render :: (Elt a, IsFloating a) => Render a- render = run1 backend- $ A.map (prettyRGBA (constant (P.fromIntegral limit)))- . mandelbrot width height limit+-- React to events+--+react :: Config -> Options -> Event -> World -> IO World+react conf opts event world@World{..} =+ case event of+ -- zooming+ EventKey (Char 'w') s _ _ -> toggle zooming 0.975 s world+ EventKey (Char 's') s _ _ -> toggle zooming 1.025 s world - in case f of- Float -> World (convertView p :: View Float) render z h v- Double -> World (convertView p :: View Double) render z h v+ -- panning+ EventKey (MouseButton LeftButton) s _ p -> toggle panning p s world+ EventMotion (x,y)+ | Just (x0,y0) <- worldPanning+ -> let dx = (x0-x) * P.realToFrac (the worldWidth) / P.fromIntegral worldSizeX+ dy = (y0-y) * P.realToFrac (the worldWidth) / P.fromIntegral worldSizeX+ in+ return . dirty+ $ World { worldPosX = unit (P.realToFrac dx + the worldPosX)+ , worldPosY = unit (P.realToFrac dy + the worldPosY)+ , worldPanning = Just (x,y)+ , ..+ } + -- algorithm+ EventKey (Char 'a') Down _ _ -> return . dirty+ $ World { worldIters = unit (P.truncate (P.fromIntegral (the worldIters) * 0.8 :: Double)), .. }+ EventKey (Char 'd') Down _ _ -> return . dirty+ $ World { worldIters = unit (P.truncate (P.fromIntegral (the worldIters) * 1.2 :: Double)), .. } --- Event handling--- --------------+ EventKey (Char 'z') Down _ _ -> return . dirty+ $ World { worldRadius = unit (the worldRadius * 0.5), .. }+ EventKey (Char 'c') Down _ _ -> return . dirty+ $ World { worldRadius = unit (the worldRadius * 2.0), .. } --- Refocus the viewport by adjusting the limits of the x- and y- range of the--- display, based on the current key state.----refocus :: World -> World-refocus = move . zoom- where- -- translate the display- --- move :: World -> World- move world@(World viewport r z h v)- = World (translate (dy,dx) viewport) r z h v- where- dx = case get horizontal world of- Nothing -> 0- Just Fwd -> 0.025- Just Rev -> -0.025+ EventKey (Char 'p') Down _ _ -> return . dirty+ $ case worldPrecision of+ Float -> setPrecision opts Double world -- could fail if no hardware support+ Double -> setPrecision opts Float world - dy = case get vertical world of- Nothing -> 0- Just Fwd -> 0.025- Just Rev -> -0.025+ -- presets+ EventKey (Char d) Down _ _ | isDigit d -> return . dirty $ loadPreset (read [d]) world - translate (j,i) (x,y,x',y') =- let sizex = x' - x- sizey = y' - y- in (x+i*sizex, y+j*sizey, x'+i*sizex, y'+j*sizey)+ -- misc+ EventKey (Char 'r') Down _ _ -> return . dirty $ initialWorld conf opts+ EventKey (Char '.') Down _ _ -> putStrLn (showWorld world) >> return world+ EventKey (SpecialKey KeyEsc) Down _ _ -> exitSuccess - -- zoom the display in or out- --- zoom :: World -> World- zoom world@(World viewport r z h v)- = World (scale s viewport) r z h v- where- s = case get zooming world of- Nothing -> 1- Just In -> 0.975- Just Out -> 1.025+ _ -> return world+ where+ toggle f x Down = return . dirty . set f (Just x)+ toggle f _ Up = return . set f Nothing - scale alpha (x,y,x',y') =- let dx = sizex * alpha / 2- dy = sizey * alpha / 2- sizex = x' - x- sizey = y' - y- midx = x + sizex / 2- midy = y + sizey / 2- in (midx - dx, midy - dy, midx + dx, midy + dy)+ dirty w = w { worldDirty = True } --- Event locations are returned as window coordinates, where the origin is in--- the centre of the window and increases to the right and up. If the simulation--- size is (100,100) with scale factor of 4, then the event coordinates are--- returned in the range [-200,200].+-- Move and zoom the display based on the key state. ---react :: Config -> Options -> Event -> World -> World-react conf opts event world- = case event of- EventKey (Char c) s _ _ -> char (toLower c) s world- EventKey (SpecialKey c) s _ _ -> special c s world- _ -> world- where- char ';' = toggle zooming In- char 'z' = toggle zooming In- char 'q' = toggle zooming Out- char 'x' = toggle zooming Out- char 'd' = precision Double- char 'f' = precision Float- char n | isDigit n = preset n- char _ = const id-- special KeyUp = toggle vertical Fwd- special KeyDown = toggle vertical Rev- special KeyRight = toggle horizontal Fwd- special KeyLeft = toggle horizontal Rev- special _ = const id-- toggle f x Down = set f (Just x)- toggle f _ Up = set f Nothing+advance :: Float -> World -> IO World+advance _ world@World{..}+ | Just f <- worldZooming = return $ updateWorld $ World { worldDirty = False, worldWidth = A.fromList Z [ P.realToFrac f * the worldWidth ], .. }+ | worldDirty = return $ updateWorld $ World { worldDirty = False, .. }+ | otherwise = return world - precision f Down = setPrecisionOfWorld f conf opts- precision _ _ = id+-- Update the picture+--+updateWorld :: World -> World+updateWorld world =+ world { worldPicture = bitmapOfArray (renderWorld world) True } - preset n Down = loadPreset (read [n])- preset _ Up = id+renderWorld :: World -> Array DIM2 Word32+renderWorld World{..} =+ worldRender (worldPosX, worldPosY, worldWidth, worldIters, worldRadius) -- Miscellaneous -- ------------- -zooming :: World :-> Maybe Zoom-zooming = lens (\(World _ _ z _ _) -> z) (\f (World p r z h v) -> World p r (f z) h v)+zooming :: World :-> Maybe Double+zooming = lens worldZooming (\f World{..} -> World { worldZooming = f worldZooming, .. }) -horizontal :: World :-> Maybe Move-horizontal = lens (\(World _ _ _ h _) -> h) (\f (World p r z h v) -> World p r z (f h) v)+panning :: World :-> Maybe (Float,Float)+panning = lens worldPanning (\f World{..} -> World { worldPanning = f worldPanning, .. }) -vertical :: World :-> Maybe Move-vertical = lens (\(World _ _ _ _ v) -> v) (\f (World p r z h v) -> World p r z h (f v))+the :: Elt a => Scalar a -> a+the a = a `A.indexArray` Z -convertView :: (Real a, Fractional b) => View a -> View b-convertView (x,y,x',y') = (realToFrac x, realToFrac y, realToFrac x', realToFrac y')+unit :: Elt a => a -> Scalar a+unit a = A.fromList Z [a] -- Presets -- ------- +showWorld :: World -> String+showWorld World{..} =+ show ( the worldPosX+ , the worldPosY+ , the worldWidth+ , the worldIters+ , the worldRadius+ )++loadWorld :: (Double,Double,Double,Double,Double) -> World -> World+loadWorld (posX, posY, width, iters, radius) World{..}+ = World { worldPosX = unit (P.realToFrac posX) `asTypeOf` worldPosX+ , worldPosY = unit (P.realToFrac posY)+ , worldWidth = unit (P.realToFrac width)+ , worldIters = unit (P.truncate iters)+ , worldRadius = unit (P.realToFrac radius)+ , ..+ }+ loadPreset :: Int -> World -> World-loadPreset n (World _ r z h v) = load (table P.!! n)- where- load (posX, posY, zoom, _iters :: Double, _radius :: Double) -- type signature only to suppress a warning- = let x' = zoom / 2- y' = x' * 0.75- in World (posX-x', posY-y', posX+x', posY+y') r z h v+loadPreset n = loadWorld (presets P.!! n) - table =- [ (-0.7, 0, 3.067, 100.0, 2.0)- , (0.20508818500545423, 0.9014915666351141 * 900/1440, 6.375321937544527e-6, 629.3354966759534, 16.0)- , (0.4510757067879078, 0.6144133202705898 * 900/1440, 7.632248223018773e-5, 253.61352386150395, 2.0)- , (0.3469337523117071, 0.6866350870407725 * 900/1440, 3.508380713647269e-5, 168.61054759193718, 1024.0)- , (-0.7902001921590814, 0.24910667566731381 * 900/1440, 5.071115028132377e-4, 1176.757810813391, 3.4359738368e10)- , (2.3127178455019423e-2, -1.301205470975472 * 900/1440, 3.6349313304610088e-9, 343.0390372557315, 2.0)- , (2.3127176148480418e-2, -1.3012054707668765 * 900/1440, 2.71444790387451e-10, 604.1620768089155, 2.0)- , (2.3127176156746785e-2, -1.301205470242045 * 900/1440, 4.49615119202067e-12, 1731.8575629678642, 2.0)- , (0.2550376327692795, 8.962363618058007e-4 * 900/1440, 7.351698819132829e-5, 1412.1093729760698, 16.0)- , (0.25498593633806477, 8.726424280526077e-4 * 900/1440, 1.6858526052251987e-10, 10492.090844482025, 2.0)- ]+presets :: [(Double,Double,Double,Double,Double)]+presets =+ [ (-0.7, 0, 3.067, 100.0, 16.0)+ , (0.20508818500545423, 0.9014915666351141 * 900/1440, 6.375321937544527e-6, 629.0, 256.0)+ , (0.4510757067879078, 0.6144133202705898 * 900/1440, 7.632248223018773e-5, 399.0, 4.0)+ , (0.3469337523117071, 0.6866350870407725 * 900/1440, 3.508380713647269e-5, 505.0, 1048576.0)+ , (-0.7902001921590814, 0.24910667566731381 * 900/1440, 5.071115028132377e-4, 1176.0, 3.4359738368e10)+ , (2.3127178455019423e-2, -1.301205470975472 * 900/1440, 3.6349313304610088e-9, 566.0, 4.0)+ , (2.3127176148480418e-2, -1.3012054707668765 * 900/1440, 2.71444790387451e-10, 604.0, 4.0)+ , (2.3127176156746785e-2, -1.301205470242045 * 900/1440, 4.49615119202067e-12, 2000.0, 4.0)+ , (0.2550376327692795, 8.962363618058007e-4 * 900/1440, 7.351698819132829e-5, 1412.0, 256.0)+ , (0.25498593633806477, 8.726424280526077e-4 * 900/1440, 1.6858526052251987e-10, 10492.0, 4.0)+ ]
examples/n-body/Common/Body.hs view
@@ -20,9 +20,11 @@ ) where import Common.Type-import Common.Util -import Data.Array.Accelerate as A+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Linear.Metric+import Data.Array.Accelerate.Linear.Vector+import Data.Array.Accelerate.Control.Lens -- Acceleration ----------------------------------------------------------------@@ -67,11 +69,11 @@ -> Exp PointMass -- ^ Neighbouring point -> Exp Accel -accel epsilon pmi pmj = s *. r+accel epsilon pmi pmj = s *^ r where mj = massOfPointMass pmj - r = positionOfPointMass pmj .-. positionOfPointMass pmi+ r = positionOfPointMass pmj - positionOfPointMass pmi rsqr = dot r r + epsilon * epsilon invr = 1 / sqrt rsqr invr3 = invr * invr * invr@@ -84,34 +86,29 @@ -- | Make a stationary Body of unit mass ---unitBody :: Exp (Vec R) -> Exp Body-unitBody pos = lift (pointmass, vec 0, vec 0)+unitBody :: Exp (V3 R) -> Exp Body+unitBody pos = body where- pointmass = lift (pos, constant 1) :: Exp PointMass+ pointmass = lift (pos, constant 1) :: Exp PointMass+ body = lift (pointmass, constant 0, constant 0) :: Exp Body -- | Take the Velocity of a Body -- velocityOfBody :: Exp Body -> Exp Velocity-velocityOfBody body = vel- where- (_, vel, _) = unlift body :: (Exp PointMass, Exp Velocity, Exp Accel)+velocityOfBody = view _2 -- | Take the Acceleration of a Body -- accelOfBody :: Exp Body -> Exp Accel-accelOfBody body = acc- where- (_, _, acc) = unlift body :: (Exp PointMass, Exp Velocity, Exp Accel)+accelOfBody = view _3 -- | Take the PointMass of a Body -- pointMassOfBody :: Exp Body -> Exp PointMass-pointMassOfBody body = mp- where- (mp, _, _) = unlift body :: (Exp PointMass, Exp Velocity, Exp Accel)+pointMassOfBody = view _1 -- | Take the position or mass of a PointMass@@ -154,11 +151,11 @@ acc = accelOfBody body pos = positionOfPointMass pm - pos' = normalise pos- vel' = lift (y', -x', z')- vel'' = (sqrt (magnitude pos) * startVel) *. vel'+ pos' = normalize pos+ vel' = lift (V3 y' (-x') z')+ vel'' = (sqrt (norm pos) * startVel) *^ vel' - (x',y',z') = unlift pos' :: Vec (Exp R)+ V3 x' y' z' = unlift pos' :: V3 (Exp R) -- | Advance a body forwards in time.@@ -173,6 +170,6 @@ mass = massOfPointMass pm pm' = lift (pos', mass) :: Exp PointMass- pos' = pos .+. time *. vel- vel' = vel .+. time *. acc+ pos' = pos + time *^ vel+ vel' = vel + time *^ acc
examples/n-body/Common/Type.hs view
@@ -1,35 +1,34 @@ -module Common.Type where+module Common.Type ( + V3(..),+ module Common.Type, --- Types -------------------------------------------------------------------------- We're using tuples instead of ADTs and defining Elt instances---+) where +import Data.Array.Accelerate.Linear.V3++ -- | Not all compute devices support double precision -- type R = Float --- | A data point in space----type Vec a = (a, a, a)- -- | Units of time -- type Time = R -- | The velocity of a point. ---type Velocity = Vec R+type Velocity = V3 R -- | The acceleration of a point. ---type Accel = Vec R+type Accel = V3 R -- | A point in 2D space with its mass. -- type Mass = R-type Position = Vec R+type Position = V3 R type PointMass = (Position, Mass) -- | Bodies consist of a Position and Mass, but also carry their velocity and
− examples/n-body/Common/Util.hs
@@ -1,76 +0,0 @@--module Common.Util (-- magnitude, dot, normalise, vec,-- (.+.), (.-.), (.*.), (+.), (-.), (*.),--) where--import Common.Type-import Data.Array.Accelerate as A---- | The magnitude of a vector.----magnitude :: (Elt a, IsFloating a) => Exp (Vec a) -> Exp a-magnitude v = sqrt (dot v v)----- | Dot product of a vector----dot :: (Elt a, IsNum a) => Exp (Vec a) -> Exp (Vec a) -> Exp a-dot v1 v2- = let (x1,y1,z1) = unlift v1- (x2,y2,z2) = unlift v2- in- x1 * x2 + y1 * y2 + z1 * z2----- | Normalise a vector, so it has a magnitude of 1.----normalise :: (Elt a, IsFloating a) => Exp (Vec a) -> Exp (Vec a)-normalise v = (1 / magnitude v) *. v---- | Replicate a value into a vector----vec :: Elt a => Exp a -> Exp (Vec a)-vec x = lift (x,x,x)---- | Basic arithmetic component-wise----infixl 7 .*.-infixl 6 .+.-infixl 6 .-.--(.+.), (.-.), (.*.) :: (Elt a, IsNum a) => Exp (Vec a) -> Exp (Vec a) -> Exp (Vec a)-(.+.) = vzipWith (+)-(.-.) = vzipWith (-)-(.*.) = vzipWith (*)---- | Apply a scalar value component-wise to each element of the vector----infixl 7 *.-infixl 6 +.-infixl 6 -.--(+.), (-.), (*.) :: (Elt a, IsNum a) => Exp a -> Exp (Vec a) -> Exp (Vec a)-(+.) c = vmap (c+)-(-.) c = vmap (c-)-(*.) c = vmap (c*)---- | Arithmetic lifted to our vector type. As far as possible, want to gloss--- over whether we are calculating in 2D or 3D.----vmap :: (Elt a, Elt b) => (Exp a -> Exp b) -> Exp (Vec a) -> Exp (Vec b)-vmap f v- = let (x1,y1,z1) = unlift v- in- lift (f x1, f y1, f z1)--vzipWith :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> Exp (Vec a) -> Exp (Vec b) -> Exp (Vec c)-vzipWith f v1 v2- = let (x1,y1,z1) = unlift v1- (x2,y2,z2) = unlift v2- in- lift (f x1 x2, f y1 y2, f z1 z2)-
examples/n-body/Common/World.hs view
@@ -6,10 +6,10 @@ ) where import Common.Type-import Common.Util import Common.Body import Data.Array.Accelerate as A+import Data.Array.Accelerate.Linear.Vector data World@@ -36,7 +36,7 @@ -- Apply the accelerations to the bodies and advance them advance b a = let m = massOfPointMass (pointMassOfBody b)- a' = m *. a+ a' = m *^ a in advanceBody (the timeStep) (setAccelOfBody a' b) in A.zipWith advance bodies accels
examples/n-body/Gloss/Draw.hs view
@@ -107,7 +107,7 @@ -- | Draw a point using a filled circle. -- drawPoint :: Position -> R -> Picture-drawPoint (x, y, _) size+drawPoint (V3 x y _) size = Translate (realToFrac x) (realToFrac y) $ ThickCircle (size / 2) size
examples/n-body/Main.hs view
@@ -21,15 +21,13 @@ -- system import Prelude as P import Data.Label-import System.Environment import Graphics.Gloss.Interface.Pure.Game main :: IO () main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer let solver = case get configSolver conf of Naive1 -> Naive1.calcAccels
examples/n-body/Random/Position.hs view
@@ -17,14 +17,14 @@ -- | Points distributed as a disc -- disc :: Position -> R -> sh :~> Position-disc (originX, originY, originZ) radiusMax _ix gen+disc (V3 originX originY originZ) radiusMax _ix gen = do radius <- uniformR (0,radiusMax) gen theta <- uniformR (0, pi) gen phi <- uniformR (0, 2*pi) gen - return ( originX + radius * sin theta * cos phi- , originY + radius * sin theta * sin phi- , originZ + radius * cos theta )+ return $ V3 (originX + radius * sin theta * cos phi)+ (originY + radius * sin theta * sin phi)+ (originZ + radius * cos theta) -- | A point cloud with areas of high and low density@@ -33,7 +33,7 @@ cloud (fromIntegral -> sizeX, fromIntegral -> sizeY) radiusMax ix gen = let blob (sx,sy,sz) r- = disc (sx * sizeX, sy * sizeY, sz * (sizeX `min` sizeY))+ = disc (V3 (sx * sizeX) (sy * sizeY) (sz * (sizeX `min` sizeY))) (radiusMax * r) in case A.size ix `mod` 5 of
examples/n-body/Solver/Naive1.hs view
@@ -4,7 +4,6 @@ import Common.Type import Common.Body-import Common.Util import Data.Array.Accelerate as A @@ -26,5 +25,5 @@ rows = A.replicate (lift $ Z :. All :. n) bodies in- A.fold (.+.) (vec 0) $ A.zipWith (accel epsilon) rows cols+ A.fold (+) 0 $ A.zipWith (accel epsilon) rows cols
examples/n-body/Solver/Naive2.hs view
@@ -4,7 +4,6 @@ import Common.Type import Common.Body-import Common.Util import Data.Array.Accelerate as A @@ -16,8 +15,8 @@ -- calcAccels :: Exp R -> Acc (Vector PointMass) -> Acc (Vector Accel) calcAccels epsilon bodies- = let move body = A.sfoldl (\acc next -> acc .+. accel epsilon body next)- (vec 0)+ = let move body = A.sfoldl (\acc next -> acc + accel epsilon body next)+ 0 (constant Z) bodies in
examples/n-body/Test.hs view
@@ -32,7 +32,7 @@ -- Input data -- bodies :: Vector Body-bodies = fromList (Z :. 32) [(((49.934765,48.864784,49.504097),3.456227),(10.561408,-10.792668,10.699586),(0.0,0.0,0.0)),(((-19.72055,21.0447,21.976465),63.459526),(6.989762,6.5499606,7.2992377),(0.0,0.0,0.0)),(((-8.485103,70.43111,-66.07767),74.34554),(14.306272,1.7235309,-13.421982),(0.0,0.0,0.0)),(((-40.529545,-23.411388,-23.874193),8.434827),(-6.4595428,11.182692,-6.5872374),(0.0,0.0,0.0)),(((36.915504,-13.378705,22.885813),16.776989),(-3.9690585,-10.951718,6.7895308),(0.0,0.0,0.0)),(((58.12199,47.11681,49.27831),21.63172),(9.955754,-12.281143,10.4124775),(0.0,0.0,0.0)),(((-18.56515,19.121122,19.856537),69.831604),(6.6335444,6.440665,6.8886757),(0.0,0.0,0.0)),(((-16.319696,68.65275,-70.91549),66.98223),(13.727621,3.263243,-14.180073),(0.0,0.0,0.0)),(((-35.320797,-9.581309,-15.5530615),23.477612),(-3.0388143,11.202367,-4.932819),(0.0,0.0,0.0)),(((35.467846,-31.458008,57.63878),4.5274367),(-7.2828484,-8.211167,13.343963),(0.0,0.0,0.0)),(((22.741138,16.762173,47.443493),45.534313),(4.5114946,-6.1207175,12.769291),(0.0,0.0,0.0)),(((-19.066488,32.53443,19.284454),37.293446),(9.998227,5.859364,5.926348),(0.0,0.0,0.0)),(((-4.6187997,54.83043,-69.1615),52.771004),(11.664729,0.9826122,-14.713549),(0.0,0.0,0.0)),(((-37.741123,-23.498236,-29.302645),83.92678),(-6.4404936,10.344243,-8.03139),(0.0,0.0,0.0)),(((36.013374,-17.063395,32.41684),13.032608),(-4.7614217,-10.049282,9.045693),(0.0,0.0,0.0)),(((49.562435,83.03267,83.920395),18.12446),(14.676114,-8.760214,14.83302),(0.0,0.0,0.0)),(((-9.462863,25.536043,36.41799),53.132633),(7.573575,2.8065314,10.800983),(0.0,0.0,0.0)),(((-10.790539,66.63314,-67.998985),94.62536),(13.614646,2.204749,-13.893719),(0.0,0.0,0.0)),(((-40.558056,-29.971233,-24.474981),6.5728045),(-8.00616,10.834197,-6.5379558),(0.0,0.0,0.0)),(((29.8883,-20.165321,45.04451),53.180336),(-5.309554,-7.869626,11.860275),(0.0,0.0,0.0)),(((32.482105,30.910307,49.05143),91.3407),(7.583363,-7.9689794,12.034005),(0.0,0.0,0.0)),(((-20.018032,19.918154,27.472118),87.52959),(6.346644,6.378469,8.753611),(0.0,0.0,0.0)),(((-12.006343,50.781525,-48.374542),75.542244),(12.0401945,2.8466792,-11.469504),(0.0,0.0,0.0)),(((-36.06932,-13.634953,-28.24347),35.689384),(-3.9444003,10.434348,-8.17044),(0.0,0.0,0.0)),(((36.564384,-22.889074,41.142605),77.35545),(-5.9291406,-9.471566,10.6575),(0.0,0.0,0.0)),(((72.98635,36.489113,44.127728),34.4798),(7.5769863,-15.15566,9.163149),(0.0,0.0,0.0)),(((-6.637457,11.754714,14.4537),20.805649),(5.286392,2.9850323,6.5001945),(0.0,0.0,0.0)),(((-5.4672456,71.23518,-59.5781),58.3743),(14.7713995,1.1336936,-12.354176),(0.0,0.0,0.0)),(((-43.633926,-22.012821,-7.0467205),20.659788),(-6.265288,12.4190855,-2.0056372),(0.0,0.0,0.0)),(((54.48485,-44.066643,29.847332),82.26547),(-10.098527,-12.486015,6.8399606),(0.0,0.0,0.0)),(((50.216465,50.00622,49.413647),86.262726),(10.759963,-10.805201,10.632457),(0.0,0.0,0.0)),(((-24.18221,1.1176014,18.39111),52.37195),(0.40538555,8.771569,6.670974),(0.0,0.0,0.0))]+bodies = fromList (Z :. 32) [((V3 49.934765 48.864784 49.504097,3.456227),V3 10.561408 (-10.792668) 10.699586,V3 0.0 0.0 0.0),((V3 (-19.72055) 21.0447 21.976465,63.459526),V3 6.989762 6.5499606 7.2992377,V3 0.0 0.0 0.0),((V3 (-8.485103) 70.43111 (-66.07767),74.34554),V3 14.306272 1.7235309 (-13.421982),V3 0.0 0.0 0.0),((V3 (-40.529545) (-23.411388) (-23.874193),8.434827),V3 (-6.4595428) 11.182692 (-6.5872374),V3 0.0 0.0 0.0),((V3 36.915504 (-13.378705) 22.885813,16.776989),V3 (-3.9690585) (-10.951718) 6.7895308,V3 0.0 0.0 0.0),((V3 58.12199 47.11681 49.27831,21.63172),V3 9.955754 (-12.281143) 10.4124775,V3 0.0 0.0 0.0),((V3 (-18.56515) 19.121122 19.856537,69.831604),V3 6.6335444 6.440665 6.8886757,V3 0.0 0.0 0.0),((V3 (-16.319696) 68.65275 (-70.91549),66.98223),V3 13.727621 3.263243 (-14.180073),V3 0.0 0.0 0.0),((V3 (-35.320797) (-9.581309) (-15.5530615),23.477612),V3 (-3.0388143) 11.202367 (-4.932819),V3 0.0 0.0 0.0),((V3 35.467846 (-31.458008) 57.63878,4.5274367),V3 (-7.2828484) (-8.211167) 13.343963,V3 0.0 0.0 0.0),((V3 22.741138 16.762173 47.443493,45.534313),V3 4.5114946 (-6.1207175) 12.769291,V3 0.0 0.0 0.0),((V3 (-19.066488) 32.53443 19.284454,37.293446),V3 9.998227 5.859364 5.926348,V3 0.0 0.0 0.0),((V3 (-4.6187997) 54.83043 (-69.1615),52.771004),V3 11.664729 0.9826122 (-14.713549),V3 0.0 0.0 0.0),((V3 (-37.741123) (-23.498236) (-29.302645),83.92678),V3 (-6.4404936) 10.344243 (-8.03139),V3 0.0 0.0 0.0),((V3 36.013374 (-17.063395) 32.41684,13.032608),V3 (-4.7614217) (-10.049282) 9.045693,V3 0.0 0.0 0.0),((V3 49.562435 83.03267 83.920395,18.12446),V3 14.676114 (-8.760214) 14.83302,V3 0.0 0.0 0.0),((V3 (-9.462863) 25.536043 36.41799,53.132633),V3 7.573575 2.8065314 10.800983,V3 0.0 0.0 0.0),((V3 (-10.790539) 66.63314 (-67.998985),94.62536),V3 13.614646 2.204749 (-13.893719),V3 0.0 0.0 0.0),((V3 (-40.558056) (-29.971233) (-24.474981),6.5728045),V3 (-8.00616) 10.834197 (-6.5379558),V3 0.0 0.0 0.0),((V3 29.8883 (-20.165321) 45.04451,53.180336),V3 (-5.309554) (-7.869626) 11.860275,V3 0.0 0.0 0.0),((V3 32.482105 30.910307 49.05143,91.3407),V3 7.583363 (-7.9689794) 12.034005,V3 0.0 0.0 0.0),((V3 (-20.018032) 19.918154 27.472118,87.52959),V3 6.346644 6.378469 8.753611,V3 0.0 0.0 0.0),((V3 (-12.006343) 50.781525 (-48.374542),75.542244),V3 12.0401945 2.8466792 (-11.469504),V3 0.0 0.0 0.0),((V3 (-36.06932) (-13.634953) (-28.24347),35.689384),V3 (-3.9444003) 10.434348 (-8.17044),V3 0.0 0.0 0.0),((V3 36.564384 (-22.889074) 41.142605,77.35545),V3 (-5.9291406) (-9.471566) 10.6575,V3 0.0 0.0 0.0),((V3 72.98635 36.489113 44.127728,34.4798),V3 7.5769863 (-15.15566) 9.163149,V3 0.0 0.0 0.0),((V3 (-6.637457) 11.754714 14.4537,20.805649),V3 5.286392 2.9850323 6.5001945,V3 0.0 0.0 0.0),((V3 (-5.4672456) 71.23518 (-59.5781),58.3743),V3 14.7713995 1.1336936 (-12.354176),V3 0.0 0.0 0.0),((V3 (-43.633926) (-22.012821) (-7.0467205),20.659788),V3 (-6.265288) 12.4190855 (-2.0056372),V3 0.0 0.0 0.0),((V3 54.48485 (-44.066643) 29.847332,82.26547),V3 (-10.098527) (-12.486015) 6.8399606,V3 0.0 0.0 0.0),((V3 50.216465 50.00622 49.413647,86.262726),V3 10.759963 (-10.805201) 10.632457,V3 0.0 0.0 0.0),((V3 (-24.18221) 1.1176014 18.39111,52.37195),V3 0.40538555 8.771569 6.670974,V3 0.0 0.0 0.0)] dt :: Scalar Time dt = fromList Z [0.1]@@ -40,10 +40,10 @@ -- Take a number of steps in 0.1 second increments -- t0, t10, t20, t30, t40, t50 :: Vector Body-t0 = fromList (Z :. 32) [(((49.934765,48.864784,49.504097),3.456227),(10.561408,-10.792668,10.699586),(-0.2020692,-0.18428235,-0.13120669)),(((-19.72055,21.0447,21.976465),63.459526),(6.989762,6.5499606,7.2992377),(3.0261776,-0.7999116,-1.3126944)),(((-8.485103,70.43111,-66.07767),74.34554),(14.306272,1.7235309,-13.421982),(-0.1371406,-3.710925,3.796874)),(((-40.529545,-23.411388,-23.874193),8.434827),(-6.4595428,11.182692,-6.5872374),(0.42419815,0.5393226,0.31401542)),(((36.915504,-13.378705,22.885813),16.776989),(-3.9690585,-10.951718,6.7895308),(-0.9118709,0.8006712,0.2444)),(((58.12199,47.11681,49.27831),21.63172),(9.955754,-12.281143,10.4124775),(-1.5379857,-0.9758822,-0.7344652)),(((-18.56515,19.121122,19.856537),69.831604),(6.6335444,6.440665,6.8886757),(2.988307,-0.41186926,-0.9475892)),(((-16.319696,68.65275,-70.91549),66.98223),(13.727621,3.263243,-14.180073),(1.625271,-2.7936146,4.267117)),(((-35.320797,-9.581309,-15.5530615),23.477612),(-3.0388143,11.202367,-4.932819),(1.208595,1.1207385,0.7841558)),(((35.467846,-31.458008,57.63878),4.5274367),(-7.2828484,-8.211167,13.343963),(-0.12642522,0.3105037,-0.2921983)),(((22.741138,16.762173,47.443493),45.534313),(4.5114946,-6.1207175,12.769291),(-1.232773,2.6571987e-2,-2.692973)),(((-19.066488,32.53443,19.284454),37.293446),(9.998227,5.859364,5.926348),(1.6313204,-1.8151838,-0.52129644)),(((-4.6187997,54.83043,-69.1615),52.771004),(11.664729,0.9826122,-14.713549),(-0.81280035,-0.112044565,3.5451076)),(((-37.741123,-23.498236,-29.302645),83.92678),(-6.4404936,10.344243,-8.03139),(3.5243607,5.315734,3.9011729)),(((36.013374,-17.063395,32.41684),13.032608),(-4.7614217,-10.049282,9.045693),(-0.61353976,0.70832497,-0.11806177)),(((49.562435,83.03267,83.920395),18.12446),(14.676114,-8.760214,14.83302),(-0.4695076,-1.0319139,-1.0167954)),(((-9.462863,25.536043,36.41799),53.132633),(7.573575,2.8065314,10.800983),(1.3853245,-1.4187478,-3.0760522)),(((-10.790539,66.63314,-67.998985),94.62536),(13.614646,2.204749,-13.893719),(0.56374645,-3.55292,5.51218)),(((-40.558056,-29.971233,-24.474981),6.5728045),(-8.00616,10.834197,-6.5379558),(0.30523086,0.47446692,0.23335022)),(((29.8883,-20.165321,45.04451),53.180336),(-5.309554,-7.869626,11.860275),(-1.4631323,3.3048942,-2.3880641)),(((32.482105,30.910307,49.05143),91.3407),(7.583363,-7.9689794,12.034005),(-3.6304643,-2.5821278,-4.8232713)),(((-20.018032,19.918154,27.472118),87.52959),(6.346644,6.378469,8.753611),(4.4817963,-0.7540304,-3.3089616)),(((-12.006343,50.781525,-48.374542),75.542244),(12.0401945,2.8466792,-11.469504),(0.74818593,-0.64892244,1.946604)),(((-36.06932,-13.634953,-28.24347),35.689384),(-3.9444003,10.434348,-8.17044),(1.5595063,1.77316,1.7561425)),(((36.564384,-22.889074,41.142605),77.35545),(-5.9291406,-9.471566,10.6575),(-3.1575167,4.8282127,-2.4603796)),(((72.98635,36.489113,44.127728),34.4798),(7.5769863,-15.15566,9.163149),(-3.1058714,-0.73178864,-0.6773815)),(((-6.637457,11.754714,14.4537),20.805649),(5.286392,2.9850323,6.5001945),(6.1454386e-2,0.3914103,0.19268043)),(((-5.4672456,71.23518,-59.5781),58.3743),(14.7713995,1.1336936,-12.354176),(-0.6793159,-3.241285,1.9731628)),(((-43.633926,-22.012821,-7.0467205),20.659788),(-6.265288,12.4190855,-2.0056372),(1.3458371,1.3664191,0.22117926)),(((54.48485,-44.066643,29.847332),82.26547),(-10.098527,-12.486015,6.8399606),(-4.644851,6.0297318,-0.19813985)),(((50.216465,50.00622,49.413647),86.262726),(10.759963,-10.805201,10.632457),(-5.0198126,-4.7489667,-3.2173421)),(((-24.18221,1.1176014,18.39111),52.37195),(0.40538555,8.771569,6.670974),(2.865766,2.5242555,-0.771268))]-t10 = fromList (Z :. 32) [(((60.402256,37.99447,60.14521),3.456227),(10.347675,-10.957504,10.569622),(-0.22668193,-0.14637746,-0.13127826)),(((-11.430504,27.125307,28.753597),63.459526),(9.780841,5.350463,6.240201),(2.5433345,-1.5698189,-0.8167556)),(((5.672099,70.57071,-77.842896),74.34554),(13.856287,-1.666952,-9.809946),(-0.7218549,-3.07428,3.454369)),(((-46.79211,-12.007825,-30.323624),8.434827),(-6.012946,11.642888,-6.2869954),(0.46778414,0.38886592,0.2849534)),(((32.574455,-23.946268,29.79417),16.776989),(-4.7382054,-10.062807,7.0655513),(-0.6296934,0.97357625,0.30322555)),(((67.3728,34.43472,59.36437),21.63172),(8.367946,-13.115515,9.689009),(-1.6421701,-0.6976927,-0.72507)),(((-10.644274,25.257013,26.39887),69.831604),(9.401735,5.590103,6.2358103),(2.5346236,-1.2643027,-0.3754633)),(((-1.9366095,70.68937,-83.21151),66.98223),(15.068537,0.5764816,-10.042387),(1.0556761,-2.6000845,4.0255356)),(((-37.81175,2.0563722,-20.14278),23.477612),(-1.817153,12.071388,-4.190213),(1.2293873,0.63759214,0.687956)),(((28.138607,-39.52876,70.849945),4.5274367),(-7.370752,-7.898251,13.046776),(-5.1867843e-2,0.31481925,-0.30228883)),(((26.732052,10.697684,58.990242),45.534313),(3.4046803,-5.9327974,10.0338125),(-0.98696345,0.33534586,-2.785121)),(((-8.415286,37.529408,25.032337),37.293446),(11.330664,3.876094,5.60827),(1.0490761,-2.1232,-0.13574754)),(((6.675616,55.826862,-82.31381),52.771004),(10.847925,1.0917499,-11.286869),(-0.7843886,0.27396658,3.3349295)),(((-42.53744,-10.963094,-35.619644),83.92678),(-2.7064044,14.917309,-4.294997),(3.9198356,3.8610702,3.5435603)),(((31.007177,-26.778881,41.412075),13.032608),(-5.2589273,-9.285036,8.936092),(-0.38566536,0.8186842,-0.10571819)),(((64.01576,73.82858,98.300285),18.12446),(14.1636095,-9.714817,13.833233),(-0.55458456,-0.8758056,-0.98143333)),(((-1.29756,27.675724,45.853508),53.132633),(8.84061,1.2858781,7.796603),(1.1496811,-1.6105593,-2.9288754)),(((2.984476,67.32786,-79.47979),94.62536),(13.839526,-1.0205598,-8.638148),(-8.429852e-2,-2.9109285,4.988788)),(((-48.420025,-18.939562,-30.91017),6.5728045),(-7.6758323,11.250289,-6.3134418),(0.35382912,0.36280265,0.21467017)),(((24.05571,-26.526985,55.817623),53.180336),(-6.2717843,-4.4937367,9.426997),(-0.48020265,3.4272532,-2.4739354)),(((38.412075,21.907555,58.91943),91.3407),(3.8768096,-10.066701,7.232523),(-3.7875612,-1.6009333,-4.7642846)),(((-11.713844,25.808075,34.806118),87.52959),(10.581014,5.0761976,5.7207565),(3.913912,-1.8188158,-2.7121327)),(((0.29591668,53.392735,-59.070557),75.542244),(12.523133,2.3962336,-9.897869),(0.258676,-0.2904919,1.2244126)),(((-39.304882,-2.4880366,-35.646812),35.689384),(-2.3586354,11.898649,-6.5040054),(1.6116967,1.186789,1.5703841)),(((29.410185,-30.127684,50.689945),77.35545),(-8.353604,-4.429852,8.189255),(-1.6932052,5.2191257,-2.4670205)),(((79.16618,21.078148,52.9975),34.4798),(4.4726243,-15.612979,8.523445),(-3.1038995,-0.19130452,-0.6173794)),(((-1.3194776,14.902553,21.06105),20.805649),(5.366333,3.3273313,6.76692),(0.10942383,0.29500887,0.33297652)),(((8.919601,70.99377,-71.09529),58.3743),(13.811482,-1.798587,-10.556653),(-1.1980586,-2.6337848,1.6664244)),(((-49.27589,-9.043354,-8.953376),20.659788),(-4.8574266,13.547301,-1.7893666),(1.4573994,0.90100104,0.20331861)),(((42.495594,-53.756332,36.63188),82.26547),(-13.994319,-6.1497493,6.7633076),(-3.1410325,6.6301613,3.0234138e-2)),(((58.644115,37.20186,58.620056),86.262726),(5.4610834,-15.029127,7.486924),(-5.588184,-3.6724644,-3.101759)),(((-22.410553,10.888989,24.760492),52.37195),(3.5517094,10.775686,6.068233),(3.405976,1.4547812,-0.44147408))]-t20 = fromList (Z :. 32) [(((70.64258,26.97726,70.65352),3.456227),(10.103177,-11.083501,10.430128),(-0.25878596,-0.1096651,-0.14805585)),(((-0.60530925,31.649681,34.703568),63.459526),(11.983897,3.3875232,5.6731596),(1.9059213,-2.2702324,-0.38499674)),(((19.129223,67.63949,-86.13814),74.34554),(12.898823,-4.338295,-6.4802012),(-1.11779,-2.3244681,3.2478783)),(((-52.587482,-0.21061647,-36.487682),8.434827),(-5.521948,11.965574,-6.018765),(0.5088869,0.27565396,0.25721252)),(((27.600586,-33.542427,37.002804),16.776989),(-5.2118816,-8.994746,7.3886538),(-0.35461906,1.1443055,0.33297035)),(((74.98001,21.052492,68.71739),21.63172),(6.6536603,-13.656725,8.92714),(-1.7712361,-0.41551957,-0.8035278)),(((-0.1968162,30.138866,32.549713),69.831604),(11.614001,3.864655,6.1276393),(1.9305562,-2.0955043,7.4945375e-2)),(((13.495451,70.11945,-91.47385),66.98223),(15.745442,-1.9447142,-6.1191072),(0.34707648,-2.4542372,3.844818)),(((-39.07626,14.344181,-24.048937),23.477612),(-0.5911909,12.481703,-3.5879762),(1.2193754,0.2451571,0.5313611)),(((20.755718,-47.285156,83.758934),4.5274367),(-7.3864875,-7.5831957,12.738908),(1.0477281e-2,0.3141431,-0.31150085)),(((29.731346,4.957616,67.74644),45.534313),(2.542373,-5.4659686,7.1639175),(-0.773719,0.55258787,-2.949255)),(((3.2952871,40.414585,30.630938),37.293446),(12.0785885,1.6407151,5.635318),(0.5175421,-2.311788,0.13688904)),(((17.204876,57.061028,-92.11485),52.771004),(10.187838,1.4056993,-7.992482),(-0.5327076,0.28180283,3.2848911)),(((-43.428978,5.4403176,-38.405262),83.92678),(1.3721125,17.93844,-1.0416794),(4.1768746,2.3258047,2.9994802)),(((25.61177,-35.67625,50.29802),13.032608),(-5.5239754,-8.40189,8.819078),(-0.17469631,0.9371397,-0.13386086)),(((77.91648,63.749935,111.700096),18.12446),(13.566664,-10.48896,12.8802395),(-0.6257403,-0.68909454,-0.9268724)),(((8.015066,28.20771,52.363438),53.132633),(9.834624,-0.42201662,4.975245),(0.8522565,-1.7886617,-2.724254)),(((16.687307,65.11167,-85.9828),94.62536),(13.431137,-3.5456862,-4.025685),(-0.6603307,-2.1941738,4.275058)),(((-55.929226,-7.5420556,-37.130413),6.5728045),(-7.2981763,11.561206,-6.1095667),(0.39473253,0.27254176,0.196624)),(((17.732718,-29.473835,64.11756),53.180336),(-6.2080007,-1.0590713,6.9066863),(0.49391943,3.4189227,-2.5597522)),(((40.55933,11.31991,64.03876),91.3407),(1.478368e-2,-10.987337,2.5858128),(-3.8935337,-0.3199196,-4.506024)),(((0.45339978,29.896873,39.454823),87.52959),(13.876055,2.7052927,3.5193348),(2.690946,-2.7923274,-1.7411938)),(((12.880193,55.68854,-68.52059),75.542244),(12.610873,2.1888132,-9.000532),(-1.7048633e-2,-0.18977338,0.6773345)),(((-40.928196,9.86234,-41.4781),35.689384),(-0.7128805,12.819815,-5.0434055),(1.6750612,0.72688335,1.3807626)),(((20.569416,-32.173176,57.774376),77.35545),(-9.122361,0.8884996,5.742017),(1.2530923e-2,5.3429766,-2.4258206)),(((82.24203,5.4715424,61.2392),34.4798),(1.3694282,-15.498303,7.885867),(-3.0998273,0.35917798,-0.67349565)),(((4.1159596,18.343342,27.995344),20.805649),(5.547433,3.5543864,7.153706),(0.2545224,0.16027838,0.41772422)),(((22.132597,68.11572,-80.91648),58.3743),(12.430078,-4.07933,-8.919203),(-1.4921408,-1.9892223,1.665496)),(((-53.46823,4.8355,-10.660793),20.659788),(-3.3736873,14.207917,-1.6194743),(1.4933307,0.48024258,0.13877386)),(((27.381256,-56.825172,43.436813),82.26547),(-16.138443,0.79542387,6.8798237),(-1.272959,7.1740904,0.16700138)),(((61.48199,20.758127,64.70831),86.262726),(-0.48431414,-17.875822,4.367215),(-6.221025,-2.0769675,-3.1554008)),(((-17.251387,22.09256,30.678736),52.37195),(7.1905856,11.458972,5.7806373),(3.7821503,9.846892e-3,-0.18520965))]-t30 = fromList (Z :. 32) [(((80.62529,15.850722,81.01362),3.456227),(9.832466,-11.171636,10.271142),(-0.27626523,-6.907271e-2,-0.16648479)),(((12.109674,33.908443,40.254055),63.459526),(13.452332,0.7633101,5.4452367),(1.0651537,-2.9039454,-0.13198845)),(((31.485191,62.397385,-91.180084),74.34554),(11.659424,-6.17881,-3.3099105),(-1.3080394,-1.4175643,3.1050818)),(((-57.875084,11.86496,-42.392822),8.434827),(-4.9964967,12.19545,-5.7677174),(0.53527856,0.19483553,0.24825694)),(((22.266294,-41.991844,44.539543),16.776989),(-5.4461217,-7.745878,7.7115583),(-0.14457354,1.3438723,0.30253243)),(((80.82082,7.255052,77.26334),21.63172),(4.8354826,-13.9168,8.057859),(-1.8398229,-0.1291134,-0.92295176)),(((12.16488,32.92552,38.752),69.831604),(13.12455,1.3194892,6.3205833),(1.1184452,-2.9104452,0.23775212)),(((29.262188,67.1042,-95.894775),66.98223),(15.635218,-4.276028,-2.3869843),(-0.5043809,-2.201609,3.6215343)),(((-39.12235,26.887955,-27.421051),23.477612),(0.6162337,12.572925,-3.130873),(1.1982962,-1.6151225e-2,0.4058443)),(((13.381501,-54.72822,96.35743),4.5274367),(-7.351956,-7.273869,12.427602),(5.11916e-2,0.3034085,-0.3084455)),(((31.944645,-0.24181631,73.54906),45.534313),(1.8208045,-4.8607187,4.099617),(-0.7120765,0.6306646,-3.160519)),(((15.529402,40.993393,36.353447),37.293446),(12.340105,-0.740232,5.8483925),(5.584805e-2,-2.4297142,0.2502288)),(((27.210176,58.54192,-98.62292),52.771004),(9.847976,1.4936708,-4.6850176),(-0.17808737,-0.12827606,3.3288074)),(((-40.165707,24.159132,-38.19885),83.92678),(5.569859,19.36941,1.6151043),(4.1652684,0.6796782,2.36701)),(((20.0366,-43.634075,59.045513),13.032608),(-5.610209,-7.3880525,8.644443),(-2.1231862e-2,1.0824242,-0.2157843)),(((91.1954,52.98254,124.174416),18.12446),(12.923086,-11.0728035,11.991299),(-0.65076464,-0.49877062,-0.85619026)),(((18.163801,26.950344,56.156433),53.132633),(10.439416,-2.310497,2.4027362),(0.35562944,-1.9632834,-2.4307075)),(((29.736702,60.715374,-88.231476),94.62536),(12.49499,-5.2733855,-0.25494644),(-1.143601,-1.3175715,3.3169105)),(((-63.04561,4.129257,-43.15318),6.5728045),(-6.891207,11.792309,-5.9181933),(0.41236284,0.19797336,0.18787487)),(((11.896064,-29.014198,69.856224),53.180336),(-5.2224894,2.284795,4.2921305),(1.3726617,3.257218,-2.6621897)),(((38.84494,0.44165504,64.68979),91.3407),(-3.7706373,-10.44458,-1.5761747),(-3.6047552,1.2989374,-3.7820122)),(((15.253961,31.213158,42.37834),87.52959),(15.57238,-0.5108675,2.4073062),(0.77382207,-3.5107894,-0.5931102)),(((25.462185,57.7606,-77.258286),75.542244),(12.529613,1.8682239,-8.432913),(-0.11828619,-0.50076365,0.56394)),(((-40.875896,22.949284,-45.92175),35.689384),(1.0001571,13.351651,-3.730043),(1.7436737,0.38464665,1.2702756)),(((11.7580805,-28.916342,62.435238),77.35545),(-8.081674,6.077168,3.352129),(1.9076473,4.964432,-2.3579834)),(((82.2225,-9.7786255,68.797226),34.4798),(-1.7052021,-14.852521,7.1237183),(-3.0383008,0.8755246,-0.85059637)),(((9.812528,21.933826,35.338314),20.805649),(5.919625,3.5853083,7.5684195),(0.47318155,-0.10099702,0.39165217)),(((33.87477,63.25305,-89.045364),58.3743),(10.897609,-5.691883,-7.101499),(-1.5258808,-1.2934843,1.9847765)),(((-56.17241,19.20363,-12.229358),20.659788),(-1.8913364,14.507622,-1.5179769),(1.4663916,0.16752706,7.473919e-2)),(((11.038544,-52.75113,50.393963),82.26547),(-16.147457,8.103466,7.0406375),(1.1229347,7.317746,0.116557844)),(((58.12866,2.3073416,67.638176),86.262726),(-6.899946,-18.700304,1.1591533),(-6.4619718,0.34747308,-3.231288)),(((-8.346832,33.286644,36.39714),52.37195),(10.981637,10.563141,5.655627),(3.7102525,-1.6548095,-0.10352421))]-t40 = fromList (Z :. 32) [(((90.3346,4.655861,91.20859),3.456227),(9.561887,-11.214318,10.101466),(-0.26128083,-2.0770896e-2,-0.16977718)),(((25.855879,33.27752,45.650112),63.459526),(13.874311,-2.4134786,5.3301144),(-0.17173003,-3.3428502,-0.14888263)),(((42.55104,55.74881,-93.12408),74.34554),(10.346969,-7.033272,-0.31666315),(-1.2832952,-0.39005303,2.8811932)),(((-62.630367,24.135597,-48.04935),8.434827),(-4.4623313,12.3485365,-5.5214076),(0.5272145,0.11860251,0.24403755)),(((16.786787,-49.09336,52.37048),16.776989),(-5.482549,-6.270866,7.9521694),(6.0247123e-2,1.5767819,0.17346881)),(((84.83455,-6.668477,84.889885),21.63172),(3.0254977,-13.872956,7.0852513),(-1.7604394,0.1894979,-1.002964)),(((25.607107,32.814,45.158234),69.831604),(13.595416,-1.9758472,6.462585),(-0.13727047,-3.549432,-3.7056354e-3)),(((44.518757,61.90863,-96.71034),66.98223),(14.625989,-6.22489,1.0272641),(-1.417286,-1.7000344,3.2084227)),(((-37.96874,39.424587,-30.38036),23.477612),(1.8094404,12.464852,-2.7568665),(1.1918833,-0.17094232,0.36163473)),(((6.057052,-61.869263,108.64919),4.5274367),(-7.286687,-6.983825,12.130093),(7.459494e-2,0.27627227,-0.28570133)),(((33.423145,-4.8133616,76.19642),45.534313),(1.0209748,-4.2072473,0.8476473),(-0.9101132,0.69006634,-3.3002555)),(((27.816963,39.14842,42.311176),37.293446),(12.133267,-3.2016866,6.077291),(-0.43277112,-2.4690394,0.1829573)),(((37.032055,59.871284,-101.80806),52.771004),(9.842458,1.0014532,-1.3576142),(0.113305725,-0.80959976,3.3034868)),(((-32.768158,43.553585,-35.62678),83.92678),(9.558228,19.116442,3.6231754),(3.785976,-1.0030328,1.7205341)),(((14.439234,-50.508904,67.57433),13.032608),(-5.5554476,-6.2216606,8.366025),(0.12124021,1.2241457,-0.33175266)),(((103.82722,41.714848,135.79294),18.12446),(12.279673,-11.474536,11.176818),(-0.631969,-0.3265566,-0.78048927)),(((28.635696,23.74509,57.530754),53.132633),(10.348517,-4.291683,0.19939163),(-0.5118455,-1.936669,-1.9911488)),(((41.658382,55.011665,-87.18198),94.62536),(11.169736,-6.0489197,2.4283314),(-1.4343514,-0.3365628,2.1519272)),(((-69.752426,15.998649,-48.988125),6.5728045),(-6.48451,11.950421,-5.7348514),(0.39747268,0.12604822,0.17903966)),(((7.421006,-25.314278,72.93206),53.180336),(-3.4275875,5.3594904,1.5695516),(2.1104321,2.8862293,-2.7693553)),(((33.593594,-9.123072,61.628304),91.3407),(-6.853316,-8.163884,-4.585922),(-2.5169895,3.068793,-2.2420175)),(((30.775204,29.06608,44.69013),87.52959),(14.991441,-4.1634536,2.3604884),(-1.743295,-3.6350572,0.3263754)),(((37.925953,59.291317,-85.37278),75.542244),(12.364148,0.97157943,-7.610811),(-0.22051588,-1.2753534,1.148759)),(((-39.081818,36.42463,-49.090176),35.689384),(2.7722025,13.572521,-2.4910996),(1.7876816,8.852193e-2,1.2181025)),(((4.854909,-20.765474,64.73786),77.35545),(-5.121062,10.451305,1.0317328),(3.773904,3.7349844,-2.2926235)),(((79.178535,-24.155758,75.49906),34.4798),(-4.636625,-13.707212,6.141575),(-2.8098998,1.3618014,-1.0914961)),(((15.977711,25.408234,43.059597),20.805649),(6.4937973,3.2579877,7.8726983),(0.63328594,-0.5327105,0.20720817)),(((44.112415,57.10134,-95.17267),58.3743),(9.473635,-6.577284,-4.840429),(-1.3064284,-0.55162036,2.500792)),(((-57.413094,33.74672,-13.71971),20.659788),(-0.45732188,14.546219,-1.4605455),(1.4030969,-5.6085628e-2,5.0729703e-2)),(((-4.132298,-41.444485,57.4354),82.26547),(-13.4335,15.047902,6.9562955),(4.059167,6.4290543,-0.3307359)),(((48.41738,-15.724357,67.36842),86.262726),(-12.948876,-16.616163,-1.95434),(-5.4540496,3.5695972,-2.9190702)),(((4.210882,42.83211,41.997192),52.37195),(14.340451,8.013545,5.5130305),(2.9640288,-3.234027,-0.19869432))]-t50 = fromList (Z :. 32) [(((99.78429,-6.5603447,101.23478),3.456227),(9.319103,-11.210923,9.935835),(-0.22626747,2.1161372e-2,-0.1612093)),(((39.403965,29.356451,50.871735),63.459526),(12.86763,-5.723307,5.028878),(-1.6957306,-3.1606607,-0.4616191)),(((52.3492,48.69863,-92.19782),74.34554),(9.166924,-6.910074,2.3809798),(-1.0765165,0.49746767,2.5362353)),(((-66.8613,36.525005,-53.462444),8.434827),(-3.9560394,12.425948,-5.2827253),(0.48558196,4.514877e-2,0.23342745)),(((11.3726,-54.63127,60.366547),16.776989),(-5.284395,-4.62866,8.007034),(0.309564,1.6607597,-5.4514244e-2)),(((87.09958,-20.402815,91.51911),21.63172),(1.3766433,-13.507609,6.0697675),(-1.5429239,0.502993,-1.0176795)),(((38.87964,29.213264,51.52705),69.831604),(12.579766,-5.5654917,6.13499),(-1.747105,-3.477748,-0.63458973)),(((58.371513,55.032394,-94.33609),66.98223),(12.771849,-7.537657,3.9042752),(-2.1691554,-0.976144,2.5849755)),(((-35.62298,51.793858,-32.97171),23.477612),(3.000215,12.232307,-2.3830836),(1.1863849,-0.2821353,0.39073357)),(((-1.1938903,-68.73547,120.656364),4.5274367),(-7.2055235,-6.73064,11.863677),(8.4682934e-2,0.2324943,-0.24955781)),(((33.98479,-8.668965,75.568375),45.534313),(-4.586573e-2,-3.3565376,-2.4003098),(-1.161805,1.0472943,-3.1469493)),(((39.66494,34.850323,48.43695),37.293446),(11.395371,-5.6083426,6.138593),(-0.99539036,-2.3176267,-6.147321e-2)),(((46.950523,60.39374,-101.70575),52.771004),(10.027083,-0.18237326,1.846281),(0.21004155,-1.4657336,3.093771)),(((-21.612383,61.96557,-31.32596),83.92678),(12.976039,17.290213,5.0295744),(3.0800977,-2.4412982,1.1717454)),(((8.96526,-56.172928,75.77116),13.032608),(-5.345359,-4.985807,7.967873),(0.27868465,1.2160217,-0.45238936)),(((115.829254,30.117777,146.63062),18.12446),(11.671261,-11.721733,10.436247),(-0.5865162,-0.18780562,-0.70882756)),(((38.582184,18.651218,56.93042),53.132633),(9.270124,-5.9622445,-1.4593434),(-1.5178046,-1.3589051,-1.3558631)),(((52.169697,48.95184,-83.96839),94.62536),(9.706987,-5.938324,3.989206),(-1.4470835,0.41542193,1.1349429)),(((-76.06361,27.99487,-54.644337),6.5728045),(-6.106245,12.040813,-5.5623775),(0.36062056,6.338345e-2,0.1667967)),(((5.031253,-18.753942,73.24428),53.180336),(-1.0452096,7.9019423,-1.2293646),(2.5434313,2.215863,-2.8002636)),(((25.895203,-15.654797,56.379826),91.3407),(-8.374308,-4.2960773,-5.6613545),(-0.61054236,4.410234,-0.105147086)),(((44.56931,23.377563,47.275223),87.52959),(11.912463,-7.3660054,2.9104905),(-4.0473733,-2.6802368,0.6384738)),(((50.153812,59.54019,-92.28699),75.542244),(12.008861,-0.7881906,-5.8424706),(-0.4955644,-2.1168833,2.3230572)),(((-35.506397,49.987667,-51.03989),35.689384),(4.5507164,13.495833,-1.2958468),(1.7571652,-0.21390966,1.1755395)),(((1.6586281,-8.966029,64.74854),77.35545),(-0.6585472,13.033994,-1.2206159),(4.837213,1.534798,-2.2026932)),(((73.34591,-37.17399,81.11334),34.4798),(-7.204541,-12.09446,4.9343133),(-2.3330922,1.8091398,-1.2886307)),(((22.757414,28.347914,50.975887),20.805649),(7.116842,2.4678946,7.908502),(0.5789135,-0.98542297,-0.11901239)),(((53.056896,50.391014,-98.801895),58.3743),(8.367776,-6.7536325,-2.0602012),(-0.93099135,0.10514579,2.9887574)),(((-57.253033,48.23814,-15.15559),20.659788),(0.8975221,14.393842,-1.4017532),(1.3112133,-0.22530983,7.0312925e-2)),(((-15.272543,-23.845793,64.09268),82.26547),(-7.877729,20.243881,6.091751),(6.59736,3.9433155,-1.3863378)),(((33.405663,-30.212833,64.24376),86.262726),(-17.00329,-11.36592,-4.358442),(-2.6607215,6.4482036,-1.8884766)),(((19.681992,49.188995,47.388447),52.37195),(16.6021,4.146414,5.202059),(1.6236293,-4.2790256,-0.41353542))]+t0 = fromList (Z :. 32) [((V3 49.934765 48.864784 49.504097,3.456227),V3 10.561408 (-10.792668) 10.699586,V3 (-0.2020692) (-0.18428235) (-0.13120669)),((V3 (-19.72055) 21.0447 21.976465,63.459526),V3 6.989762 6.5499606 7.2992377,V3 3.0261776 (-0.7999116) (-1.3126944)),((V3 (-8.485103) 70.43111 (-66.07767),74.34554),V3 14.306272 1.7235309 (-13.421982),V3 (-0.1371406) (-3.710925) 3.796874),((V3 (-40.529545) (-23.411388) (-23.874193),8.434827),V3 (-6.4595428) 11.182692 (-6.5872374),V3 0.42419815 0.5393226 0.31401542),((V3 36.915504 (-13.378705) 22.885813,16.776989),V3 (-3.9690585) (-10.951718) 6.7895308,V3 (-0.9118709) 0.8006712 0.2444),((V3 58.12199 47.11681 49.27831,21.63172),V3 9.955754 (-12.281143) 10.4124775,V3 (-1.5379857) (-0.9758822) (-0.7344652)),((V3 (-18.56515) 19.121122 19.856537,69.831604),V3 6.6335444 6.440665 6.8886757,V3 2.988307 (-0.41186926) (-0.9475892)),((V3 (-16.319696) 68.65275 (-70.91549),66.98223),V3 13.727621 3.263243 (-14.180073),V3 1.625271 (-2.7936146) 4.267117),((V3 (-35.320797) (-9.581309) (-15.5530615),23.477612),V3 (-3.0388143) 11.202367 (-4.932819),V3 1.208595 1.1207385 0.7841558),((V3 35.467846 (-31.458008) 57.63878,4.5274367),V3 (-7.2828484) (-8.211167) 13.343963,V3 (-0.12642522) 0.3105037 (-0.2921983)),((V3 22.741138 16.762173 47.443493,45.534313),V3 4.5114946 (-6.1207175) 12.769291,V3 (-1.232773) 2.6571987e-2 (-2.692973)),((V3 (-19.066488) 32.53443 19.284454,37.293446),V3 9.998227 5.859364 5.926348,V3 1.6313204 (-1.8151838) (-0.52129644)),((V3 (-4.6187997) 54.83043 (-69.1615),52.771004),V3 11.664729 0.9826122 (-14.713549),V3 (-0.81280035) (-0.112044565) 3.5451076),((V3 (-37.741123) (-23.498236) (-29.302645),83.92678),V3 (-6.4404936) 10.344243 (-8.03139),V3 3.5243607 5.315734 3.9011729),((V3 36.013374 (-17.063395) 32.41684,13.032608),V3 (-4.7614217) (-10.049282) 9.045693,V3 (-0.61353976) 0.70832497 (-0.11806177)),((V3 49.562435 83.03267 83.920395,18.12446),V3 14.676114 (-8.760214) 14.83302,V3 (-0.4695076) (-1.0319139) (-1.0167954)),((V3 (-9.462863) 25.536043 36.41799,53.132633),V3 7.573575 2.8065314 10.800983,V3 1.3853245 (-1.4187478) (-3.0760522)),((V3 (-10.790539) 66.63314 (-67.998985),94.62536),V3 13.614646 2.204749 (-13.893719),V3 0.56374645 (-3.55292) 5.51218),((V3 (-40.558056) (-29.971233) (-24.474981),6.5728045),V3 (-8.00616) 10.834197 (-6.5379558),V3 0.30523086 0.47446692 0.23335022),((V3 29.8883 (-20.165321) 45.04451,53.180336),V3 (-5.309554) (-7.869626) 11.860275,V3 (-1.4631323) 3.3048942 (-2.3880641)),((V3 32.482105 30.910307 49.05143,91.3407),V3 7.583363 (-7.9689794) 12.034005,V3 (-3.6304643) (-2.5821278) (-4.8232713)),((V3 (-20.018032) 19.918154 27.472118,87.52959),V3 6.346644 6.378469 8.753611,V3 4.4817963 (-0.7540304) (-3.3089616)),((V3 (-12.006343) 50.781525 (-48.374542),75.542244),V3 12.0401945 2.8466792 (-11.469504),V3 0.74818593 (-0.64892244) 1.946604),((V3 (-36.06932) (-13.634953) (-28.24347),35.689384),V3 (-3.9444003) 10.434348 (-8.17044),V3 1.5595063 1.77316 1.7561425),((V3 36.564384 (-22.889074) 41.142605,77.35545),V3 (-5.9291406) (-9.471566) 10.6575,V3 (-3.1575167) 4.8282127 (-2.4603796)),((V3 72.98635 36.489113 44.127728,34.4798),V3 7.5769863 (-15.15566) 9.163149,V3 (-3.1058714) (-0.73178864) (-0.6773815)),((V3 (-6.637457) 11.754714 14.4537,20.805649),V3 5.286392 2.9850323 6.5001945,V3 6.1454386e-2 0.3914103 0.19268043),((V3 (-5.4672456) 71.23518 (-59.5781),58.3743),V3 14.7713995 1.1336936 (-12.354176),V3 (-0.6793159) (-3.241285) 1.9731628),((V3 (-43.633926) (-22.012821) (-7.0467205),20.659788),V3 (-6.265288) 12.4190855 (-2.0056372),V3 1.3458371 1.3664191 0.22117926),((V3 54.48485 (-44.066643) 29.847332,82.26547),V3 (-10.098527) (-12.486015) 6.8399606,V3 (-4.644851) 6.0297318 (-0.19813985)),((V3 50.216465 50.00622 49.413647,86.262726),V3 10.759963 (-10.805201) 10.632457,V3 (-5.0198126) (-4.7489667) (-3.2173421)),((V3 (-24.18221) 1.1176014 18.39111,52.37195),V3 0.40538555 8.771569 6.670974,V3 2.865766 2.5242555 (-0.771268))]+t10 = fromList (Z :. 32) [((V3 60.402256 37.99447 60.14521,3.456227),V3 10.347675 (-10.957504) 10.569622,V3 (-0.22668193) (-0.14637746) (-0.13127826)),((V3 (-11.430504) 27.125307 28.753597,63.459526),V3 9.780841 5.350463 6.240201,V3 2.5433345 (-1.5698189) (-0.8167556)),((V3 5.672099 70.57071 (-77.842896),74.34554),V3 13.856287 (-1.666952) (-9.809946),V3 (-0.7218549) (-3.07428) 3.454369),((V3 (-46.79211) (-12.007825) (-30.323624),8.434827),V3 (-6.012946) 11.642888 (-6.2869954),V3 0.46778414 0.38886592 0.2849534),((V3 32.574455 (-23.946268) 29.79417,16.776989),V3 (-4.7382054) (-10.062807) 7.0655513,V3 (-0.6296934) 0.97357625 0.30322555),((V3 67.3728 34.43472 59.36437,21.63172),V3 8.367946 (-13.115515) 9.689009,V3 (-1.6421701) (-0.6976927) (-0.72507)),((V3 (-10.644274) 25.257013 26.39887,69.831604),V3 9.401735 5.590103 6.2358103,V3 2.5346236 (-1.2643027) (-0.3754633)),((V3 (-1.9366095) 70.68937 (-83.21151),66.98223),V3 15.068537 0.5764816 (-10.042387),V3 1.0556761 (-2.6000845) 4.0255356),((V3 (-37.81175) 2.0563722 (-20.14278),23.477612),V3 (-1.817153) 12.071388 (-4.190213),V3 1.2293873 0.63759214 0.687956),((V3 28.138607 (-39.52876) 70.849945,4.5274367),V3 (-7.370752) (-7.898251) 13.046776,V3 (-5.1867843e-2) 0.31481925 (-0.30228883)),((V3 26.732052 10.697684 58.990242,45.534313),V3 3.4046803 (-5.9327974) 10.0338125,V3 (-0.98696345) 0.33534586 (-2.785121)),((V3 (-8.415286) 37.529408 25.032337,37.293446),V3 11.330664 3.876094 5.60827,V3 1.0490761 (-2.1232) (-0.13574754)),((V3 6.675616 55.826862 (-82.31381),52.771004),V3 10.847925 1.0917499 (-11.286869),V3 (-0.7843886) 0.27396658 3.3349295),((V3 (-42.53744) (-10.963094) (-35.619644),83.92678),V3 (-2.7064044) 14.917309 (-4.294997),V3 3.9198356 3.8610702 3.5435603),((V3 31.007177 (-26.778881) 41.412075,13.032608),V3 (-5.2589273) (-9.285036) 8.936092,V3 (-0.38566536) 0.8186842 (-0.10571819)),((V3 64.01576 73.82858 98.300285,18.12446),V3 14.1636095 (-9.714817) 13.833233,V3 (-0.55458456) (-0.8758056) (-0.98143333)),((V3 (-1.29756) 27.675724 45.853508,53.132633),V3 8.84061 1.2858781 7.796603,V3 1.1496811 (-1.6105593) (-2.9288754)),((V3 2.984476 67.32786 (-79.47979),94.62536),V3 13.839526 (-1.0205598) (-8.638148),V3 (-8.429852e-2) (-2.9109285) 4.988788),((V3 (-48.420025) (-18.939562) (-30.91017),6.5728045),V3 (-7.6758323) 11.250289 (-6.3134418),V3 0.35382912 0.36280265 0.21467017),((V3 24.05571 (-26.526985) 55.817623,53.180336),V3 (-6.2717843) (-4.4937367) 9.426997,V3 (-0.48020265) 3.4272532 (-2.4739354)),((V3 38.412075 21.907555 58.91943,91.3407),V3 3.8768096 (-10.066701) 7.232523,V3 (-3.7875612) (-1.6009333) (-4.7642846)),((V3 (-11.713844) 25.808075 34.806118,87.52959),V3 10.581014 5.0761976 5.7207565,V3 3.913912 (-1.8188158) (-2.7121327)),((V3 0.29591668 53.392735 (-59.070557),75.542244),V3 12.523133 2.3962336 (-9.897869),V3 0.258676 (-0.2904919) 1.2244126),((V3 (-39.304882) (-2.4880366) (-35.646812),35.689384),V3 (-2.3586354) 11.898649 (-6.5040054),V3 1.6116967 1.186789 1.5703841),((V3 29.410185 (-30.127684) 50.689945,77.35545),V3 (-8.353604) (-4.429852) 8.189255,V3 (-1.6932052) 5.2191257 (-2.4670205)),((V3 79.16618 21.078148 52.9975,34.4798),V3 4.4726243 (-15.612979) 8.523445,V3 (-3.1038995) (-0.19130452) (-0.6173794)),((V3 (-1.3194776) 14.902553 21.06105,20.805649),V3 5.366333 3.3273313 6.76692,V3 0.10942383 0.29500887 0.33297652),((V3 8.919601 70.99377 (-71.09529),58.3743),V3 13.811482 (-1.798587) (-10.556653),V3 (-1.1980586) (-2.6337848) 1.6664244),((V3 (-49.27589) (-9.043354) (-8.953376),20.659788),V3 (-4.8574266) 13.547301 (-1.7893666),V3 1.4573994 0.90100104 0.20331861),((V3 42.495594 (-53.756332) 36.63188,82.26547),V3 (-13.994319) (-6.1497493) 6.7633076,V3 (-3.1410325) 6.6301613 3.0234138e-2),((V3 58.644115 37.20186 58.620056,86.262726),V3 5.4610834 (-15.029127) 7.486924,V3 (-5.588184) (-3.6724644) (-3.101759)),((V3 (-22.410553) 10.888989 24.760492,52.37195),V3 3.5517094 10.775686 6.068233,V3 3.405976 1.4547812 (-0.44147408))]+t20 = fromList (Z :. 32) [((V3 70.64258 26.97726 70.65352,3.456227),V3 10.103177 (-11.083501) 10.430128,V3 (-0.25878596) (-0.1096651) (-0.14805585)),((V3 (-0.60530925) 31.649681 34.703568,63.459526),V3 11.983897 3.3875232 5.6731596,V3 1.9059213 (-2.2702324) (-0.38499674)),((V3 19.129223 67.63949 (-86.13814),74.34554),V3 12.898823 (-4.338295) (-6.4802012),V3 (-1.11779) (-2.3244681) 3.2478783),((V3 (-52.587482) (-0.21061647) (-36.487682),8.434827),V3 (-5.521948) 11.965574 (-6.018765),V3 0.5088869 0.27565396 0.25721252),((V3 27.600586 (-33.542427) 37.002804,16.776989),V3 (-5.2118816) (-8.994746) 7.3886538,V3 (-0.35461906) 1.1443055 0.33297035),((V3 74.98001 21.052492 68.71739,21.63172),V3 6.6536603 (-13.656725) 8.92714,V3 (-1.7712361) (-0.41551957) (-0.8035278)),((V3 (-0.1968162) 30.138866 32.549713,69.831604),V3 11.614001 3.864655 6.1276393,V3 1.9305562 (-2.0955043) 7.4945375e-2),((V3 13.495451 70.11945 (-91.47385),66.98223),V3 15.745442 (-1.9447142) (-6.1191072),V3 0.34707648 (-2.4542372) 3.844818),((V3 (-39.07626) 14.344181 (-24.048937),23.477612),V3 (-0.5911909) 12.481703 (-3.5879762),V3 1.2193754 0.2451571 0.5313611),((V3 20.755718 (-47.285156) 83.758934,4.5274367),V3 (-7.3864875) (-7.5831957) 12.738908,V3 1.0477281e-2 0.3141431 (-0.31150085)),((V3 29.731346 4.957616 67.74644,45.534313),V3 2.542373 (-5.4659686) 7.1639175,V3 (-0.773719) 0.55258787 (-2.949255)),((V3 3.2952871 40.414585 30.630938,37.293446),V3 12.0785885 1.6407151 5.635318,V3 0.5175421 (-2.311788) 0.13688904),((V3 17.204876 57.061028 (-92.11485),52.771004),V3 10.187838 1.4056993 (-7.992482),V3 (-0.5327076) 0.28180283 3.2848911),((V3 (-43.428978) 5.4403176 (-38.405262),83.92678),V3 1.3721125 17.93844 (-1.0416794),V3 4.1768746 2.3258047 2.9994802),((V3 25.61177 (-35.67625) 50.29802,13.032608),V3 (-5.5239754) (-8.40189) 8.819078,V3 (-0.17469631) 0.9371397 (-0.13386086)),((V3 77.91648 63.749935 111.700096,18.12446),V3 13.566664 (-10.48896) 12.8802395,V3 (-0.6257403) (-0.68909454) (-0.9268724)),((V3 8.015066 28.20771 52.363438,53.132633),V3 9.834624 (-0.42201662) 4.975245,V3 0.8522565 (-1.7886617) (-2.724254)),((V3 16.687307 65.11167 (-85.9828),94.62536),V3 13.431137 (-3.5456862) (-4.025685),V3 (-0.6603307) (-2.1941738) 4.275058),((V3 (-55.929226) (-7.5420556) (-37.130413),6.5728045),V3 (-7.2981763) 11.561206 (-6.1095667),V3 0.39473253 0.27254176 0.196624),((V3 17.732718 (-29.473835) 64.11756,53.180336),V3 (-6.2080007) (-1.0590713) 6.9066863,V3 0.49391943 3.4189227 (-2.5597522)),((V3 40.55933 11.31991 64.03876,91.3407),V3 1.478368e-2 (-10.987337) 2.5858128,V3 (-3.8935337) (-0.3199196) (-4.506024)),((V3 0.45339978 29.896873 39.454823,87.52959),V3 13.876055 2.7052927 3.5193348,V3 2.690946 (-2.7923274) (-1.7411938)),((V3 12.880193 55.68854 (-68.52059),75.542244),V3 12.610873 2.1888132 (-9.000532),V3 (-1.7048633e-2) (-0.18977338) 0.6773345),((V3 (-40.928196) 9.86234 (-41.4781),35.689384),V3 (-0.7128805) 12.819815 (-5.0434055),V3 1.6750612 0.72688335 1.3807626),((V3 20.569416 (-32.173176) 57.774376,77.35545),V3 (-9.122361) 0.8884996 5.742017,V3 1.2530923e-2 5.3429766 (-2.4258206)),((V3 82.24203 5.4715424 61.2392,34.4798),V3 1.3694282 (-15.498303) 7.885867,V3 (-3.0998273) 0.35917798 (-0.67349565)),((V3 4.1159596 18.343342 27.995344,20.805649),V3 5.547433 3.5543864 7.153706,V3 0.2545224 0.16027838 0.41772422),((V3 22.132597 68.11572 (-80.91648),58.3743),V3 12.430078 (-4.07933) (-8.919203),V3 (-1.4921408) (-1.9892223) 1.665496),((V3 (-53.46823) 4.8355 (-10.660793),20.659788),V3 (-3.3736873) 14.207917 (-1.6194743),V3 1.4933307 0.48024258 0.13877386),((V3 27.381256 (-56.825172) 43.436813,82.26547),V3 (-16.138443) 0.79542387 6.8798237,V3 (-1.272959) 7.1740904 0.16700138),((V3 61.48199 20.758127 64.70831,86.262726),V3 (-0.48431414) (-17.875822) 4.367215,V3 (-6.221025) (-2.0769675) (-3.1554008)),((V3 (-17.251387) 22.09256 30.678736,52.37195),V3 7.1905856 11.458972 5.7806373,V3 3.7821503 9.846892e-3 (-0.18520965))]+t30 = fromList (Z :. 32) [((V3 80.62529 15.850722 81.01362,3.456227),V3 9.832466 (-11.171636) 10.271142,V3 (-0.27626523) (-6.907271e-2) (-0.16648479)),((V3 12.109674 33.908443 40.254055,63.459526),V3 13.452332 0.7633101 5.4452367,V3 1.0651537 (-2.9039454) (-0.13198845)),((V3 31.485191 62.397385 (-91.180084),74.34554),V3 11.659424 (-6.17881) (-3.3099105),V3 (-1.3080394) (-1.4175643) 3.1050818),((V3 (-57.875084) 11.86496 (-42.392822),8.434827),V3 (-4.9964967) 12.19545 (-5.7677174),V3 0.53527856 0.19483553 0.24825694),((V3 22.266294 (-41.991844) 44.539543,16.776989),V3 (-5.4461217) (-7.745878) 7.7115583,V3 (-0.14457354) 1.3438723 0.30253243),((V3 80.82082 7.255052 77.26334,21.63172),V3 4.8354826 (-13.9168) 8.057859,V3 (-1.8398229) (-0.1291134) (-0.92295176)),((V3 12.16488 32.92552 38.752,69.831604),V3 13.12455 1.3194892 6.3205833,V3 1.1184452 (-2.9104452) 0.23775212),((V3 29.262188 67.1042 (-95.894775),66.98223),V3 15.635218 (-4.276028) (-2.3869843),V3 (-0.5043809) (-2.201609) 3.6215343),((V3 (-39.12235) 26.887955 (-27.421051),23.477612),V3 0.6162337 12.572925 (-3.130873),V3 1.1982962 (-1.6151225e-2) 0.4058443),((V3 13.381501 (-54.72822) 96.35743,4.5274367),V3 (-7.351956) (-7.273869) 12.427602,V3 5.11916e-2 0.3034085 (-0.3084455)),((V3 31.944645 (-0.24181631) 73.54906,45.534313),V3 1.8208045 (-4.8607187) 4.099617,V3 (-0.7120765) 0.6306646 (-3.160519)),((V3 15.529402 40.993393 36.353447,37.293446),V3 12.340105 (-0.740232) 5.8483925,V3 5.584805e-2 (-2.4297142) 0.2502288),((V3 27.210176 58.54192 (-98.62292),52.771004),V3 9.847976 1.4936708 (-4.6850176),V3 (-0.17808737) (-0.12827606) 3.3288074),((V3 (-40.165707) 24.159132 (-38.19885),83.92678),V3 5.569859 19.36941 1.6151043,V3 4.1652684 0.6796782 2.36701),((V3 20.0366 (-43.634075) 59.045513,13.032608),V3 (-5.610209) (-7.3880525) 8.644443,V3 (-2.1231862e-2) 1.0824242 (-0.2157843)),((V3 91.1954 52.98254 124.174416,18.12446),V3 12.923086 (-11.0728035) 11.991299,V3 (-0.65076464) (-0.49877062) (-0.85619026)),((V3 18.163801 26.950344 56.156433,53.132633),V3 10.439416 (-2.310497) 2.4027362,V3 0.35562944 (-1.9632834) (-2.4307075)),((V3 29.736702 60.715374 (-88.231476),94.62536),V3 12.49499 (-5.2733855) (-0.25494644),V3 (-1.143601) (-1.3175715) 3.3169105),((V3 (-63.04561) 4.129257 (-43.15318),6.5728045),V3 (-6.891207) 11.792309 (-5.9181933),V3 0.41236284 0.19797336 0.18787487),((V3 11.896064 (-29.014198) 69.856224,53.180336),V3 (-5.2224894) 2.284795 4.2921305,V3 1.3726617 3.257218 (-2.6621897)),((V3 38.84494 0.44165504 64.68979,91.3407),V3 (-3.7706373) (-10.44458) (-1.5761747),V3 (-3.6047552) 1.2989374 (-3.7820122)),((V3 15.253961 31.213158 42.37834,87.52959),V3 15.57238 (-0.5108675) 2.4073062,V3 0.77382207 (-3.5107894) (-0.5931102)),((V3 25.462185 57.7606 (-77.258286),75.542244),V3 12.529613 1.8682239 (-8.432913),V3 (-0.11828619) (-0.50076365) 0.56394),((V3 (-40.875896) 22.949284 (-45.92175),35.689384),V3 1.0001571 13.351651 (-3.730043),V3 1.7436737 0.38464665 1.2702756),((V3 11.7580805 (-28.916342) 62.435238,77.35545),V3 (-8.081674) 6.077168 3.352129,V3 1.9076473 4.964432 (-2.3579834)),((V3 82.2225 (-9.7786255) 68.797226,34.4798),V3 (-1.7052021) (-14.852521) 7.1237183,V3 (-3.0383008) 0.8755246 (-0.85059637)),((V3 9.812528 21.933826 35.338314,20.805649),V3 5.919625 3.5853083 7.5684195,V3 0.47318155 (-0.10099702) 0.39165217),((V3 33.87477 63.25305 (-89.045364),58.3743),V3 10.897609 (-5.691883) (-7.101499),V3 (-1.5258808) (-1.2934843) 1.9847765),((V3 (-56.17241) 19.20363 (-12.229358),20.659788),V3 (-1.8913364) 14.507622 (-1.5179769),V3 1.4663916 0.16752706 7.473919e-2),((V3 11.038544 (-52.75113) 50.393963,82.26547),V3 (-16.147457) 8.103466 7.0406375,V3 1.1229347 7.317746 0.116557844),((V3 58.12866 2.3073416 67.638176,86.262726),V3 (-6.899946) (-18.700304) 1.1591533,V3 (-6.4619718) 0.34747308 (-3.231288)),((V3 (-8.346832) 33.286644 36.39714,52.37195),V3 10.981637 10.563141 5.655627,V3 3.7102525 (-1.6548095) (-0.10352421))]+t40 = fromList (Z :. 32) [((V3 90.3346 4.655861 91.20859,3.456227),V3 9.561887 (-11.214318) 10.101466,V3 (-0.26128083) (-2.0770896e-2) (-0.16977718)),((V3 25.855879 33.27752 45.650112,63.459526),V3 13.874311 (-2.4134786) 5.3301144,V3 (-0.17173003) (-3.3428502) (-0.14888263)),((V3 42.55104 55.74881 (-93.12408),74.34554),V3 10.346969 (-7.033272) (-0.31666315),V3 (-1.2832952) (-0.39005303) 2.8811932),((V3 (-62.630367) 24.135597 (-48.04935),8.434827),V3 (-4.4623313) 12.3485365 (-5.5214076),V3 0.5272145 0.11860251 0.24403755),((V3 16.786787 (-49.09336) 52.37048,16.776989),V3 (-5.482549) (-6.270866) 7.9521694,V3 6.0247123e-2 1.5767819 0.17346881),((V3 84.83455 (-6.668477) 84.889885,21.63172),V3 3.0254977 (-13.872956) 7.0852513,V3 (-1.7604394) 0.1894979 (-1.002964)),((V3 25.607107 32.814 45.158234,69.831604),V3 13.595416 (-1.9758472) 6.462585,V3 (-0.13727047) (-3.549432) (-3.7056354e-3)),((V3 44.518757 61.90863 (-96.71034),66.98223),V3 14.625989 (-6.22489) 1.0272641,V3 (-1.417286) (-1.7000344) 3.2084227),((V3 (-37.96874) 39.424587 (-30.38036),23.477612),V3 1.8094404 12.464852 (-2.7568665),V3 1.1918833 (-0.17094232) 0.36163473),((V3 6.057052 (-61.869263) 108.64919,4.5274367),V3 (-7.286687) (-6.983825) 12.130093,V3 7.459494e-2 0.27627227 (-0.28570133)),((V3 33.423145 (-4.8133616) 76.19642,45.534313),V3 1.0209748 (-4.2072473) 0.8476473,V3 (-0.9101132) 0.69006634 (-3.3002555)),((V3 27.816963 39.14842 42.311176,37.293446),V3 12.133267 (-3.2016866) 6.077291,V3 (-0.43277112) (-2.4690394) 0.1829573),((V3 37.032055 59.871284 (-101.80806),52.771004),V3 9.842458 1.0014532 (-1.3576142),V3 0.113305725 (-0.80959976) 3.3034868),((V3 (-32.768158) 43.553585 (-35.62678),83.92678),V3 9.558228 19.116442 3.6231754,V3 3.785976 (-1.0030328) 1.7205341),((V3 14.439234 (-50.508904) 67.57433,13.032608),V3 (-5.5554476) (-6.2216606) 8.366025,V3 0.12124021 1.2241457 (-0.33175266)),((V3 103.82722 41.714848 135.79294,18.12446),V3 12.279673 (-11.474536) 11.176818,V3 (-0.631969) (-0.3265566) (-0.78048927)),((V3 28.635696 23.74509 57.530754,53.132633),V3 10.348517 (-4.291683) 0.19939163,V3 (-0.5118455) (-1.936669) (-1.9911488)),((V3 41.658382 55.011665 (-87.18198),94.62536),V3 11.169736 (-6.0489197) 2.4283314,V3 (-1.4343514) (-0.3365628) 2.1519272),((V3 (-69.752426) 15.998649 (-48.988125),6.5728045),V3 (-6.48451) 11.950421 (-5.7348514),V3 0.39747268 0.12604822 0.17903966),((V3 7.421006 (-25.314278) 72.93206,53.180336),V3 (-3.4275875) 5.3594904 1.5695516,V3 2.1104321 2.8862293 (-2.7693553)),((V3 33.593594 (-9.123072) 61.628304,91.3407),V3 (-6.853316) (-8.163884) (-4.585922),V3 (-2.5169895) 3.068793 (-2.2420175)),((V3 30.775204 29.06608 44.69013,87.52959),V3 14.991441 (-4.1634536) 2.3604884,V3 (-1.743295) (-3.6350572) 0.3263754),((V3 37.925953 59.291317 (-85.37278),75.542244),V3 12.364148 0.97157943 (-7.610811),V3 (-0.22051588) (-1.2753534) 1.148759),((V3 (-39.081818) 36.42463 (-49.090176),35.689384),V3 2.7722025 13.572521 (-2.4910996),V3 1.7876816 8.852193e-2 1.2181025),((V3 4.854909 (-20.765474) 64.73786,77.35545),V3 (-5.121062) 10.451305 1.0317328,V3 3.773904 3.7349844 (-2.2926235)),((V3 79.178535 (-24.155758) 75.49906,34.4798),V3 (-4.636625) (-13.707212) 6.141575,V3 (-2.8098998) 1.3618014 (-1.0914961)),((V3 15.977711 25.408234 43.059597,20.805649),V3 6.4937973 3.2579877 7.8726983,V3 0.63328594 (-0.5327105) 0.20720817),((V3 44.112415 57.10134 (-95.17267),58.3743),V3 9.473635 (-6.577284) (-4.840429),V3 (-1.3064284) (-0.55162036) 2.500792),((V3 (-57.413094) 33.74672 (-13.71971),20.659788),V3 (-0.45732188) 14.546219 (-1.4605455),V3 1.4030969 (-5.6085628e-2) 5.0729703e-2),((V3 (-4.132298) (-41.444485) 57.4354,82.26547),V3 (-13.4335) 15.047902 6.9562955,V3 4.059167 6.4290543 (-0.3307359)),((V3 48.41738 (-15.724357) 67.36842,86.262726),V3 (-12.948876) (-16.616163) (-1.95434),V3 (-5.4540496) 3.5695972 (-2.9190702)),((V3 4.210882 42.83211 41.997192,52.37195),V3 14.340451 8.013545 5.5130305,V3 2.9640288 (-3.234027) (-0.19869432))]+t50 = fromList (Z :. 32) [((V3 99.78429 (-6.5603447) 101.23478,3.456227),V3 9.319103 (-11.210923) 9.935835,V3 (-0.22626747) 2.1161372e-2 (-0.1612093)),((V3 39.403965 29.356451 50.871735,63.459526),V3 12.86763 (-5.723307) 5.028878,V3 (-1.6957306) (-3.1606607) (-0.4616191)),((V3 52.3492 48.69863 (-92.19782),74.34554),V3 9.166924 (-6.910074) 2.3809798,V3 (-1.0765165) 0.49746767 2.5362353),((V3 (-66.8613) 36.525005 (-53.462444),8.434827),V3 (-3.9560394) 12.425948 (-5.2827253),V3 0.48558196 4.514877e-2 0.23342745),((V3 11.3726 (-54.63127) 60.366547,16.776989),V3 (-5.284395) (-4.62866) 8.007034,V3 0.309564 1.6607597 (-5.4514244e-2)),((V3 87.09958 (-20.402815) 91.51911,21.63172),V3 1.3766433 (-13.507609) 6.0697675,V3 (-1.5429239) 0.502993 (-1.0176795)),((V3 38.87964 29.213264 51.52705,69.831604),V3 12.579766 (-5.5654917) 6.13499,V3 (-1.747105) (-3.477748) (-0.63458973)),((V3 58.371513 55.032394 (-94.33609),66.98223),V3 12.771849 (-7.537657) 3.9042752,V3 (-2.1691554) (-0.976144) 2.5849755),((V3 (-35.62298) 51.793858 (-32.97171),23.477612),V3 3.000215 12.232307 (-2.3830836),V3 1.1863849 (-0.2821353) 0.39073357),((V3 (-1.1938903) (-68.73547) 120.656364,4.5274367),V3 (-7.2055235) (-6.73064) 11.863677,V3 8.4682934e-2 0.2324943 (-0.24955781)),((V3 33.98479 (-8.668965) 75.568375,45.534313),V3 (-4.586573e-2) (-3.3565376) (-2.4003098),V3 (-1.161805) 1.0472943 (-3.1469493)),((V3 39.66494 34.850323 48.43695,37.293446),V3 11.395371 (-5.6083426) 6.138593,V3 (-0.99539036) (-2.3176267) (-6.147321e-2)),((V3 46.950523 60.39374 (-101.70575),52.771004),V3 10.027083 (-0.18237326) 1.846281,V3 0.21004155 (-1.4657336) 3.093771),((V3 (-21.612383) 61.96557 (-31.32596),83.92678),V3 12.976039 17.290213 5.0295744,V3 3.0800977 (-2.4412982) 1.1717454),((V3 8.96526 (-56.172928) 75.77116,13.032608),V3 (-5.345359) (-4.985807) 7.967873,V3 0.27868465 1.2160217 (-0.45238936)),((V3 115.829254 30.117777 146.63062,18.12446),V3 11.671261 (-11.721733) 10.436247,V3 (-0.5865162) (-0.18780562) (-0.70882756)),((V3 38.582184 18.651218 56.93042,53.132633),V3 9.270124 (-5.9622445) (-1.4593434),V3 (-1.5178046) (-1.3589051) (-1.3558631)),((V3 52.169697 48.95184 (-83.96839),94.62536),V3 9.706987 (-5.938324) 3.989206,V3 (-1.4470835) 0.41542193 1.1349429),((V3 (-76.06361) 27.99487 (-54.644337),6.5728045),V3 (-6.106245) 12.040813 (-5.5623775),V3 0.36062056 6.338345e-2 0.1667967),((V3 5.031253 (-18.753942) 73.24428,53.180336),V3 (-1.0452096) 7.9019423 (-1.2293646),V3 2.5434313 2.215863 (-2.8002636)),((V3 25.895203 (-15.654797) 56.379826,91.3407),V3 (-8.374308) (-4.2960773) (-5.6613545),V3 (-0.61054236) 4.410234 (-0.105147086)),((V3 44.56931 23.377563 47.275223,87.52959),V3 11.912463 (-7.3660054) 2.9104905,V3 (-4.0473733) (-2.6802368) 0.6384738),((V3 50.153812 59.54019 (-92.28699),75.542244),V3 12.008861 (-0.7881906) (-5.8424706),V3 (-0.4955644) (-2.1168833) 2.3230572),((V3 (-35.506397) 49.987667 (-51.03989),35.689384),V3 4.5507164 13.495833 (-1.2958468),V3 1.7571652 (-0.21390966) 1.1755395),((V3 1.6586281 (-8.966029) 64.74854,77.35545),V3 (-0.6585472) 13.033994 (-1.2206159),V3 4.837213 1.534798 (-2.2026932)),((V3 73.34591 (-37.17399) 81.11334,34.4798),V3 (-7.204541) (-12.09446) 4.9343133,V3 (-2.3330922) 1.8091398 (-1.2886307)),((V3 22.757414 28.347914 50.975887,20.805649),V3 7.116842 2.4678946 7.908502,V3 0.5789135 (-0.98542297) (-0.11901239)),((V3 53.056896 50.391014 (-98.801895),58.3743),V3 8.367776 (-6.7536325) (-2.0602012),V3 (-0.93099135) 0.10514579 2.9887574),((V3 (-57.253033) 48.23814 (-15.15559),20.659788),V3 0.8975221 14.393842 (-1.4017532),V3 1.3112133 (-0.22530983) 7.0312925e-2),((V3 (-15.272543) (-23.845793) 64.09268,82.26547),V3 (-7.877729) 20.243881 6.091751,V3 6.59736 3.9433155 (-1.3863378)),((V3 33.405663 (-30.212833) 64.24376,86.262726),V3 (-17.00329) (-11.36592) (-4.358442),V3 (-2.6607215) 6.4482036 (-1.8884766)),((V3 19.681992 49.188995 47.388447,52.37195),V3 16.6021 4.146414 5.202059,V3 1.6236293 (-4.2790256) (-0.41353542))]
examples/nofib/Config.hs view
@@ -9,6 +9,7 @@ import Data.Label import Data.Maybe+import Data.Bits import System.Console.GetOpt @@ -36,8 +37,8 @@ { _configDouble = True , _configFloat = False- , _configInt64 = False- , _configInt32 = True+ , _configInt64 = $( [e| finiteBitSize (undefined::Int) == 64 |] )+ , _configInt32 = $( [e| finiteBitSize (undefined::Int) == 32 |] ) , _configInt16 = False , _configInt8 = False , _configWord64 = False
examples/nofib/Main.hs view
@@ -2,7 +2,6 @@ module Main where import Data.Label-import System.Environment import Config import Test.FFT@@ -27,8 +26,7 @@ -- process command line args, and print a brief usage message --- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer let backend = get optBackend opts -- Run tests, executing the simplest first. More complex operations, such as
examples/nofib/QuickCheck/Arbitrary/Array.hs view
@@ -7,40 +7,48 @@ import QuickCheck.Arbitrary.Shape -import Data.List import Test.QuickCheck import System.Random ( Random )-import Data.Array.Accelerate.Array.Sugar ( Array, Segments, Shape, Elt, Z(..), (:.)(..), (!), DIM0, DIM1, DIM2 )+import Data.Array.Accelerate.Array.Sugar ( Array(..), Segments, Shape, Elt, Z(..), (:.)(..), (!), DIM1, DIM2 ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Set as Set -instance (Elt e, Arbitrary e) => Arbitrary (Array DIM0 e) where+instance (Elt e, Arbitrary e) => Arbitrary (Array Z e) where arbitrary = arbitraryArray Z shrink arr = [ Sugar.fromList Z [x] | x <- shrink (arr ! Z) ] - instance (Elt e, Arbitrary e) => Arbitrary (Array DIM1 e) where- arbitrary = arbitraryArray =<< sized arbitraryShape- shrink arr =- let (Z :. n) = Sugar.shape arr- indices = [ map (Z:.) (nub sz) | sz <- shrink [0 .. n-1] ]- in- [ Sugar.fromList (Z :. length sl) (map (arr!) sl) | sl <- indices ]-+ arbitrary = arbitraryArray =<< arbitrary+ shrink arr = [ Sugar.fromList (Z :. length sl) sl | sl <- shrink (Sugar.toList arr) ] instance (Elt e, Arbitrary e) => Arbitrary (Array DIM2 e) where- arbitrary = arbitraryArray =<< sized arbitraryShape+ arbitrary = arbitraryArray =<< arbitrary shrink arr =- let (Z :. width :. height) = Sugar.shape arr+ let+ xs = Sugar.toList arr+ sh@(Z:.h:.w) = Sugar.shape arr in- [ Sugar.fromList (Z :. length slx :. length sly) [ arr ! (Z:.x:.y) | x <- slx, y <- sly ]- | slx <- map nub $ shrink [0 .. width - 1]- , sly <- map nub $ shrink [0 .. height - 1]- ]+ [ q | Z:.m:.n <- shrink sh, m > 0, n > 0+ , q <- [ Sugar.fromFunction (Z :. m :. n) (\ix -> arr Sugar.! ix) -- top-left+ , Sugar.fromFunction (Z :. m :. w-n) (\(Z:.u:.v) -> arr Sugar.! (Z:.u :.(n+v))) -- top-right+ , Sugar.fromFunction (Z :. h-m :. n) (\(Z:.u:.v) -> arr Sugar.! (Z:.(m+u):.v)) -- bottom-left+ , Sugar.fromFunction (Z :. h-m :. w-n) (\(Z:.u:.v) -> arr Sugar.! (Z:.(m+u):.(n+v))) -- bottom-right+ ]] +++ [ Sugar.fromList sh sl | sl <- shrinkOne xs ] +instance (Shape sh, Elt e, Arbitrary sh, Arbitrary e) => Arbitrary (Array (sh:.Int:.Int:.Int) e) where+ arbitrary = arbitraryArray =<< arbitrary+ shrink arr@(Array _ adata) =+ let+ sh = Sugar.shape arr+ xs = Sugar.toList arr+ in+ [ Array (Sugar.fromElt sh') adata | sh' <- shrink sh ] +++ [ Sugar.fromList sh sl | sl <- shrinkOne xs ] + -- Generate an arbitrary array of the given shape using the default element -- generator --@@ -50,7 +58,7 @@ -- Generate an array of the given shape using the supplied element generator -- function. ---arbitraryArrayOf :: (Shape sh, Elt e, Arbitrary e) => sh -> Gen e -> Gen (Array sh e)+arbitraryArrayOf :: (Shape sh, Elt e) => sh -> Gen e -> Gen (Array sh e) arbitraryArrayOf sh gen = Sugar.fromList sh `fmap` vectorOf (Sugar.size sh) gen {--@@ -88,29 +96,60 @@ sh <- sized $ \n -> arbitraryShape (n `div` 2) arbitraryArray (sh :. sz) +shrinkSegmentedArray+ :: (Shape sh, Elt e, Arbitrary sh, Arbitrary e)+ => Array (sh :. Int) e+ -> [Array (sh :. Int) e]+shrinkSegmentedArray arr@(Array _ adata) =+ let+ sh@(sz :. n) = Sugar.shape arr+ in+ [ Array (Sugar.fromElt sz',n) adata | sz' <- shrink sz ] +++ [ Sugar.fromList sh sl | sl <- shrinkOne (Sugar.toList arr) ] + -- Generate a segment descriptor. Both the array and individual segments might -- be empty. ---arbitrarySegments :: (Elt i, Integral i, Arbitrary i, Random i) => Gen (Segments i)+arbitrarySegments :: (Elt i, Integral i, Random i) => Gen (Segments i) arbitrarySegments = sized $ \n -> do k <- choose (0,n) arbitraryArrayOf (Z:.k) (choose (0, fromIntegral n)) +shrinkSegments :: (Elt i, Integral i, Arbitrary i) => Segments i -> [Segments i]+shrinkSegments arr =+ let+ shrinkSeg (x:y:zs) = [ xy:zs | xy <- (x+y) : shrink (x+y), xy >= 0 ]+ ++ [ x:yzs' | yzs' <- shrinkSeg (y:zs) ]+ shrinkSeg _ = []+ in+ [ Sugar.fromList (Z :. length sl) sl | sl <- shrinkSeg (Sugar.toList arr) ] +++ [ Sugar.fromList (Z :. length sl) sl | sl <- shrinkList (\x -> [ s | s <- shrink x, s >= 0]) (Sugar.toList arr) ]+ -- Generate a possibly empty segment descriptor, where each segment is non-empty ---arbitrarySegments1 :: (Elt i, Integral i, Arbitrary i, Random i) => Gen (Segments i)+arbitrarySegments1 :: (Elt i, Integral i, Random i) => Gen (Segments i) arbitrarySegments1 = sized $ \n -> do k <- choose (0,n) arbitraryArrayOf (Z:.k) (choose (1, 1 `max` fromIntegral n)) +shrinkSegments1 :: (Elt i, Integral i, Arbitrary i) => Segments i -> [Segments i]+shrinkSegments1 arr =+ let+ shrinkSeg (x:y:zs) = [ xy:zs | xy <- (x+y) : shrink (x+y), xy >= 1 ]+ ++ [ x:yzs' | yzs' <- shrinkSeg (y:zs) ]+ shrinkSeg _ = []+ in+ [ Sugar.fromList (Z :. length sl) sl | sl <- shrinkSeg (Sugar.toList arr) ] +++ [ Sugar.fromList (Z :. length sl) sl | sl <- shrinkList (\x -> [ s | s <- shrink x, s >= 1]) (Sugar.toList arr) ] + -- Generate an vector where every element in the array is unique. The maximum -- size is based on the current 'sized' parameter. ---arbitraryUniqueVectorOf :: (Elt e, Arbitrary e, Ord e) => Gen e -> Gen (Array DIM1 e)+arbitraryUniqueVectorOf :: (Elt e, Ord e) => Gen e -> Gen (Array DIM1 e) arbitraryUniqueVectorOf gen = sized $ \n -> do set <- fmap Set.fromList (vectorOf n gen)@@ -125,7 +164,7 @@ -- The matrix size is based on the current `sized` parameter. -- arbitraryCSRMatrix- :: (Elt i, Integral i, Arbitrary i, Random i, Elt e, Arbitrary e)+ :: (Elt i, Integral i, Random i, Elt e, Arbitrary e) => Gen ( Array DIM1 i, Array DIM1 (i,e), Int ) arbitraryCSRMatrix = sized $ \cols -> do@@ -136,4 +175,13 @@ ind <- choose (0, fromIntegral cols - 1) return (ind, val) return (segd, smat, cols)+++-- Helpers+-- -------++shrinkOne :: Arbitrary a => [a] -> [[a]]+shrinkOne [] = []+shrinkOne (x:xs) = [ x':xs | x' <- shrink x ]+ ++ [ x:xs' | xs' <- shrinkOne xs ]
examples/nofib/QuickCheck/Arbitrary/Shape.hs view
@@ -6,47 +6,23 @@ module QuickCheck.Arbitrary.Shape where import Test.QuickCheck-import Data.Array.Accelerate ( Shape, Z(..), (:.)(..), DIM0, DIM1, DIM2, DIM3, DIM4 )+import Data.Array.Accelerate ( Shape, Z(..), (:.)(..) ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar -instance Arbitrary DIM0 where+instance Arbitrary Z where arbitrary = return Z- shrink = return--instance Arbitrary DIM1 where- arbitrary = do- n <- sized $ \n -> choose (0, 2*n)- return (Z :. n)-- shrink (Z :. n) = [ Z :. n' | n' <- shrink n ]--instance Arbitrary DIM2 where- arbitrary = sized $ \n -> do- w <- choose (0, n)- h <- choose (0, n)- return (Z :. h :. w)-- shrink (Z :. h :. w) = [ Z :. h' :. w' | h' <- shrink h, w' <- shrink w ]--instance Arbitrary DIM3 where- arbitrary = sized $ \n -> do- w <- choose (0, n)- h <- choose (0, n)- d <- choose (0, n)- return (Z :. h :. w :. d)-- shrink (Z :. h :. w :. d) = [ Z :. h' :. w' :. d' | h' <- shrink h, w' <- shrink w, d' <- shrink d ]--instance Arbitrary DIM4 where- arbitrary = sized $ \n -> do- w <- choose (0, n)- h <- choose (0, n)- d <- choose (0, n)- t <- choose (0, n)- return (Z :. h :. w :. d :. t)+ shrink _ = [] - shrink (Z :. h :. w :. d :. t) = [ Z :. h' :. w' :. d' :. t' | h' <- shrink h, w' <- shrink w, d' <- shrink d, t' <- shrink t ]+instance Arbitrary sh => Arbitrary (sh :. Int) where+ arbitrary = do+ sh <- arbitrary+ NonNegative sz <- arbitrary+ return (sh :. sz)+ --+ shrink (sh :. sz) =+ [ sh :. sz' | sz' <- shrink sz, sz' >= 0 ] +++ [ sh' :. sz | sh' <- shrink sh ] -- Generate an arbitrary shape with approximately this many elements in each@@ -63,7 +39,7 @@ arbitraryShape size = let eps = 0.1 :: Double- dim = Sugar.dim (undefined :: sh)+ dim = Sugar.rank (undefined :: sh) target | dim == 0 = 1 | otherwise = size * dim
examples/nofib/Test/Base.hs view
@@ -9,14 +9,14 @@ -- Miscellaneous ---indexHead :: Shape sh => (sh:.Int) -> Int+indexHead :: sh:.Int -> Int indexHead (_ :. sz) = sz -indexTail :: Shape sh => (sh:.Int) -> sh+indexTail :: sh:.Int -> sh indexTail (sh :. _) = sh isEmptyArray :: Shape sh => Array sh e -> Bool-isEmptyArray arr = arraySize (arrayShape arr) == 0+isEmptyArray arr = arraySize (arrayShape arr) P.== 0 mkDim :: Shape sh => Int -> sh mkDim n = listToShape (P.replicate n 0)@@ -30,13 +30,19 @@ dim2 :: DIM2 dim2 = mkDim 2 +dim3 :: DIM3+dim3 = mkDim 3++dim4 :: DIM4+dim4 = mkDim 4+ splitEvery :: Int -> [a] -> [[a]] splitEvery _ [] = cycle [[]] splitEvery n xs = let (h,t) = splitAt n xs in h : splitEvery n t -splitPlaces :: Integral i => [i] -> [a] -> [[a]]+splitPlaces :: P.Integral i => [i] -> [a] -> [[a]] splitPlaces [] _ = [] splitPlaces (i:is) vs = let (h,t) = splitAt (P.fromIntegral i) vs
examples/nofib/Test/FFT.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+ module Test.FFT ( test_fft@@ -10,67 +13,136 @@ import Config -import Control.Applicative-import Data.Label-import Data.Maybe-import Data.Typeable--import Prelude as P- import Test.QuickCheck hiding ( (.&.) ) import Test.Framework import Test.Framework.Providers.QuickCheck2 import QuickCheck.Arbitrary.Array -import Data.Array.Accelerate.Math.FFT as FFT-import Data.Array.Accelerate as A hiding ( (!) )+import Data.Array.Accelerate.Math.DFT+import Data.Array.Accelerate.Math.FFT++import Data.Array.Accelerate as A hiding ( (!), Ord(..), Eq(..) ) import Data.Array.Accelerate.Examples.Internal as A-import Data.Array.Accelerate.Array.Sugar ( (!) ) import Data.Array.Accelerate.Data.Complex +import Data.Bits+import Data.Label+import Data.Maybe+import Data.Typeable+import Prelude as P -newtype PowerOf2Array a = PowerOf2Array (Array DIM2 a) deriving Show -instance (Arbitrary a, Elt a) => Arbitrary (PowerOf2Array a) where- arbitrary =- do- Z:.y:.x <- arbitrary- PowerOf2Array <$> arbitraryArray (Z:.ceil2n y:.ceil2n x)- where- ceil2n :: Int -> Int- ceil2n = (2^) . (P.floor :: Float -> Int) . P.logBase 2 . (+1) . (P.fromIntegral :: Int -> Float)- shrink (PowerOf2Array a)- = let Z:.h:.w = arrayShape a- in if h > 0 && w >0- then [ PowerOf2Array . fromList (Z:.(h `div` 2):.w) $ [a ! (Z:.y:.x) | y <- [0..h `div` 2], x <- [0..w - 1]]- , PowerOf2Array . fromList (Z:.h:.(w `div` 2)) $ [a ! (Z:.y:.x) | y <- [0..h - 1], x <- [0..w `div` 2]] ]- else []+newtype PowerOf2Array sh e = PowerOf2Array (Array sh e)+ deriving Show +instance (Arbitrary e, Elt e) => Arbitrary (PowerOf2Array DIM1 e) where+ arbitrary = do+ Z :. n <- arbitrary+ arr <- arbitraryArray (Z :. ceilPow2 n)+ return $ PowerOf2Array arr++ shrink (PowerOf2Array arr) =+ [ PowerOf2Array arr' | arr' <- shrink arr+ , let Z :. n = arrayShape arr' in isPow2 n ]++instance (Arbitrary e, Elt e) => Arbitrary (PowerOf2Array DIM2 e) where+ arbitrary = do+ Z :. h :. w <- arbitrary+ arr <- arbitraryArray (Z :. ceilPow2 h :. ceilPow2 w)+ return $ PowerOf2Array arr+ --+ shrink (PowerOf2Array arr) =+ [ PowerOf2Array arr' | arr' <- shrink arr+ , let Z :. h :. w = arrayShape arr' in isPow2 h P.&& isPow2 w ]++instance (Arbitrary e, Elt e) => Arbitrary (PowerOf2Array DIM3 e) where+ arbitrary = do+ Z :. d :. h :. w <- arbitrary+ arr <- arbitraryArray (Z :. ceilPow2 d :. ceilPow2 h :. ceilPow2 w)+ return $ PowerOf2Array arr+ --+ shrink (PowerOf2Array arr) =+ [ PowerOf2Array arr' | arr' <- shrink arr+ , let Z :. d :. h :. w = arrayShape arr' in isPow2 d P.&& isPow2 h P.&& isPow2 w ]+++isPow2 :: Int -> Bool+isPow2 0 = True+isPow2 1 = False+isPow2 n = n .&. (n - 1) == 0++ceilPow2 :: Int -> Int+ceilPow2 n+ | isPow2 n = n+ | otherwise =+ let x = P.logBase 2 (P.fromIntegral n) :: Double+ y = P.floor x + 1+ in+ 1 `shiftL` y++ test_fft :: Backend -> Config -> Test test_fft backend opt = testGroup "fft" $ catMaybes [ testElt configFloat (undefined::Float) , testElt configDouble (undefined::Double) ] where- testElt :: forall a. (Elt a, Similar a, Arbitrary a, IsFloating a, RealFloat a)+ testElt :: forall a. (Similar a, Arbitrary a, P.RealFloat a, A.RealFloat a, A.IsFloating a, A.FromIntegral Int a) => (Config :-> Bool) -> a -> Maybe Test testElt ok _- | P.not (get ok opt) = Nothing+ | P.not (get ok opt) = Nothing | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))- [ testProperty "size" (test_size :: PowerOf2Array (Complex a) -> Property)- , testProperty "trans" (test_trans :: PowerOf2Array (Complex a) -> Property) ]+ [ testDIM1+ , testDIM2+ , testDIM3+ ]+ where+ testDIM1 :: Test+ testDIM1 =+ testGroup "DIM1"+ [ testProperty "ifft.fft" (test_fft_ifft :: PowerOf2Array DIM1 (Complex a) -> Property)+ , testProperty "fft==dft" (test_fft_dft :: PowerOf2Array DIM1 (Complex a) -> Property)+ ]+ where+ test_fft_ifft (PowerOf2Array xs) =+ let sh = arrayShape xs+ in arraySize sh > 0 ==>+ run backend (fft1D' Inverse sh . fft1D' Forward sh $ use xs) ~?= xs - test_trans :: (Elt a, RealFloat a, IsFloating a, Similar a) => PowerOf2Array (Complex a) -> Property- test_trans (PowerOf2Array xs)- = let Z:.h:.w = arrayShape xs- in run1 backend (transpose . fft2D' Forward w h) xs- ~?= run1 backend (fft2D' Forward h w . transpose) xs+ test_fft_dft (PowerOf2Array xs) =+ let sh = (arrayShape xs)+ in arraySize sh > 0 ==>+ run backend (fft1D' Forward sh $ use xs) ~?= run1 backend dft xs - test_size :: (Elt a, IsFloating a, RealFloat a, Similar a) => PowerOf2Array (Complex a) -> Property- test_size (PowerOf2Array xs)- = let Z:.h:.w = arrayShape xs- in arrayShape xs- ~?= arrayShape (run1 backend (fft2D' Forward w h) xs)+ testDIM2 :: Test+ testDIM2 =+ testGroup "DIM2"+ [ testProperty "ifft.fft" (test_fft_ifft :: PowerOf2Array DIM2 (Complex a) -> Property)+ , testProperty "transpose" (test_trans :: PowerOf2Array DIM2 (Complex a) -> Property)+ ]+ where+ test_trans (PowerOf2Array xs) =+ let sh@(Z:.h:.w) = arrayShape xs+ sh' = Z :. w :. h+ in arraySize sh > 0 ==>+ run backend (A.transpose . fft2D' Forward sh $ use xs)+ ~?= run backend (fft2D' Forward sh' . A.transpose $ use xs)++ test_fft_ifft (PowerOf2Array xs) =+ let sh = arrayShape xs+ in arraySize (arrayShape xs) > 0 ==>+ run backend (fft2D' Inverse sh . fft2D' Forward sh $ use xs) ~?= xs++ testDIM3 :: Test+ testDIM3 =+ testGroup "DIM3"+ [ testProperty "ifft.fft" (test_fft_ifft :: PowerOf2Array DIM3 (Complex a) -> Property)+ ]+ where+ test_fft_ifft (PowerOf2Array xs) =+ let sh = arrayShape xs+ in arraySize (arrayShape xs) > 0 ==>+ run backend (fft3D' Inverse sh . fft3D' Forward sh $ use xs) ~?= xs
examples/nofib/Test/Foreign/CUDA.hs view
@@ -4,7 +4,7 @@ where import Config-import Test.Prelude.Mapping+import QuickCheck.Arbitrary.Array () import Prelude as P import Data.Array.Accelerate as A@@ -14,23 +14,30 @@ test_cuda :: Backend -> Config -> Test test_cuda backend _conf = testGroup "CUDA"- $ if backend == CUDA- then [ testExpf, testFmaf ]- else [ ]+ $ case backend of+ CUDA -> [ testExpf, testFmaf ]+ _ -> [ ] where testExpf :: Test testExpf = testProperty "expf" test_expf where test_expf :: Array DIM1 Float -> Property- test_expf xs = run backend (A.map (A.foreignExp (A.CUDAForeignExp [] "__expf") exp) (A.use xs))+ test_expf xs = run1 backend (A.map (A.foreignExp (A.CUDAForeignExp [] "__expf") exp)) xs ~?= mapRef exp xs testFmaf :: Test testFmaf = testProperty "fmaf" test_fmaf where test_fmaf :: Array DIM1 (Float, Float, Float) -> Property- test_fmaf xs = run backend (A.map (A.foreignExp (A.CUDAForeignExp [] "__fmaf_rz") fmaf) (A.use xs))+ test_fmaf xs = run1 backend (A.map (A.foreignExp (A.CUDAForeignExp [] "__fmaf_rz") fmaf)) xs ~?= mapRef (\(x,y,z) -> x * y + z) xs where fmaf v = let (x,y,z) = unlift v in x * y + z+++mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b+mapRef f xs+ = fromList (arrayShape xs)+ $ P.map f+ $ toList xs
examples/nofib/Test/IO/Ptr.hs view
@@ -36,14 +36,14 @@ -- Unit tests ------------------------------------------------------------------ ---intToBool :: Integral a => a -> Bool+intToBool :: P.Integral a => a -> Bool intToBool 0 = False intToBool _ = True fromPtrInt32 :: Assertion fromPtrInt32 = do ptr <- oneToTen- arr <- fromPtr (Z :. 10) ((), ptr) :: IO (Vector Int32)+ arr <- fromPtr (Z :. 10) ptr :: IO (Vector Int32) toList arr @?= [1..10] fromPtrIntDouble :: Assertion@@ -61,7 +61,7 @@ arr = fromList (Z:.n) [2 * P.fromIntegral x | x <- [0..n-1]] -- ohi <- nInt16s (P.fromIntegral n)- toPtr arr ((), ohi)+ toPtr arr ohi b <- isFilledWithEvens16 ohi (P.fromIntegral n) intToBool b @?= True @@ -72,7 +72,7 @@ arr = fromList (Z:.10:.10) [2 * P.fromIntegral x | x <- [0..n-1]] -- ohi <- nInt32s n- toPtr arr ((), ohi)+ toPtr arr ohi b <- isFilledWithEvens32 ohi n intToBool b @?= True @@ -83,19 +83,19 @@ arr = fromList (Z:.n) [2 * P.fromIntegral x | x <- [0..n-1]] -- ohi <- nInt64s (P.fromIntegral n)- toPtr arr ((), ohi)+ toPtr arr ohi b <- isFilledWithEvens64 ohi (P.fromIntegral n) intToBool b @?= True fromArrayInt32 :: IO () fromArrayInt32 = do- let n = 5^(3::Int)+ let n = 5 P.^ (3::Int) arr :: Array DIM3 Int32 arr = fromList (Z:.5:.5:.5) [2*x | x <- [0..n-1]] -- ohi <- nInt32s (P.fromIntegral n)- fromArray arr ((), memcpy ohi)+ fromArray arr (memcpy ohi) b <- isFilledWithEvens32 ohi (P.fromIntegral n) intToBool b @?= True
examples/nofib/Test/IO/Vector.hs view
@@ -45,8 +45,8 @@ , testDim dim2 ] where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test- testDim sh = testProperty ("DIM" P.++ show (dim sh)) (roundtrip :: Array sh a -> Property)+ testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary (Array sh a)) => sh -> Test+ testDim sh = testProperty ("DIM" P.++ show (rank sh)) (roundtrip :: Array sh a -> Property) roundtrip arr = let sh = arrayShape arr
examples/nofib/Test/Imaginary/DotP.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -35,7 +37,7 @@ , testElt configDouble (undefined :: Double) ] where- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a)+ testElt :: forall a. (P.Num a, A.Num a, Similar a, Arbitrary a) => (Config :-> Bool) -> a -> Maybe Test@@ -52,7 +54,7 @@ -- Accelerate implementation --------------------------------------------------- -dotp :: (Elt e, IsNum e)+dotp :: A.Num e => Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e)
examples/nofib/Test/Imaginary/SASUM.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -34,7 +36,7 @@ , testElt configDouble (undefined :: Double) ] where- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a)+ testElt :: forall a. (P.Num a, A.Num a, Similar a, Arbitrary a) => (Config :-> Bool) -> a -> Maybe Test@@ -51,6 +53,6 @@ -- Accelerate implementation --------------------------------------------------- -sasum :: (Elt e, IsNum e) => Acc (Vector e) -> Acc (Scalar e)+sasum :: A.Num e => Acc (Vector e) -> Acc (Scalar e) sasum = A.fold (+) 0 . A.map abs
examples/nofib/Test/Imaginary/SAXPY.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -35,7 +38,7 @@ , testElt configDouble (undefined :: Double) ] where- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a)+ testElt :: forall a. (P.Num a, A.Num a, Similar a, Arbitrary a) => (Config :-> Bool) -> a -> Maybe Test@@ -52,7 +55,7 @@ -- Accelerate implementation --------------------------------------------------- -saxpy :: (Elt e, IsNum e)+saxpy :: A.Num e => Exp e -> Acc (Vector e) -> Acc (Vector e)
examples/nofib/Test/Issues.hs view
@@ -18,6 +18,13 @@ import Test.Issues.Issue184 import Test.Issues.Issue185 import Test.Issues.Issue187+import Test.Issues.Issue228+import Test.Issues.Issue255+import Test.Issues.Issue264+import Test.Issues.Issue286+import Test.Issues.Issue287+import Test.Issues.Issue288+import Test.Issues.Issue362 import Data.Array.Accelerate.Examples.Internal @@ -36,5 +43,12 @@ , test_issue184 be conf , test_issue185 be conf , test_issue187 be conf+ , test_issue228 be conf+ , test_issue255 be conf+ , test_issue264 be conf+ , test_issue286 be conf+ , test_issue287 be conf+ , test_issue288 be conf+ , test_issue362 be conf ]
examples/nofib/Test/Issues/Issue102.hs view
@@ -36,7 +36,7 @@ --embed into a vector of length p y = generate (constant (Z :. lts :. p :. rts)) (\ix -> let (Z :. l :. i :. r) = unlift ix :: Z :. Exp Int :. Exp Int :. Exp Int- in i ==* 0 ? (0, x' ! (lift $ Z :. l :. i-1 :. r)))+ in i A.== 0 ? (0, x' ! (lift $ Z :. l :. i-1 :. r))) -- do a DFT_p y' = reshape (constant (Z :. lts :. p :. rts)) (flatten y)
examples/nofib/Test/Issues/Issue137.hs view
@@ -33,9 +33,9 @@ in A.permute (\a12 b12 -> let (a1,a2) = unlift a12 (b1,b2) = unlift b12- in (a1 <=* b1)- ? ( lift (a1, min a2 b1)- , lift (b1, min b2 a1)+ in (a1 A.<= b1)+ ? ( lift (a1, A.min a2 b1)+ , lift (b1, A.min b2 a1) )) infsA (\ix -> index1 (msA A.! ix))
examples/nofib/Test/Issues/Issue184.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} module Test.Issues.Issue184 (test_issue184) where@@ -6,7 +7,6 @@ import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.Examples.Internal as A @@ -25,7 +25,7 @@ test1 :: Acc (Vector Int) test1 = let v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)- f x = x A.<* 5 ? (let y = v A.!! x in y*y, 0)+ f x = x < 5 ? (let y = v !! x in y*y, 0) in generate (index1 1000) (f . unindex1) @@ -36,7 +36,7 @@ test2 = let x = constant 1 :: Exp Int v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)- y = (x ==* 1 ||* v A.!! (-1) ==* 1)+ y = (x == 1 || v !! (-1) == 1) in unit y @@ -47,6 +47,6 @@ test3 = let x = constant 1 :: Exp Int v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)- y = (x /=* 1 &&* v A.!! (-1) ==* 1)+ y = (x /= 1 && v !! (-1) == 1) in unit y
examples/nofib/Test/Issues/Issue185.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -25,10 +27,10 @@ ] -ref1 :: (Elt a, Num a) => Vector a+ref1 :: (Elt a, P.Num a) => Vector a ref1 = fromList (Z :. 9) [0,1,4,9,0,4,0,6,2] -acc1 :: (Elt a, IsNum a) => Acc (Vector a)+acc1 :: (Elt a, P.Num a) => Acc (Vector a) acc1 = A.scatter to over xs where over = use [0, 0, 0, 0, 0, 0, 0, 0, 0]@@ -36,10 +38,10 @@ to = use [1, 3, 7, 2, 5, 8] -ref2 :: (Elt a, Num a) => Vector a+ref2 :: (Elt a, P.Num a) => Vector a ref2 = fromList (Z :. 9) [0,1,0,9,0,0,0,6,0] -acc2 :: (Elt a, IsNum a) => Acc (Vector a)+acc2 :: (Elt a, P.Num a) => Acc (Vector a) acc2 = A.scatter to over xs where over = use [0, 0, 0, 0, 0, 0, 0, 0, 0]@@ -47,11 +49,11 @@ to = use [1, 3, 7, 2, 5, 8] -ref3 :: (Elt a, Num a) => Vector a+ref3 :: (Elt a, P.Num a) => Vector a ref3 = fromList (Z :. 9) [0,0,0,0,0,4,0,6,2] -acc3 :: (Elt a, IsNum a) => Acc (Vector a)-acc3 = A.scatterIf to mask p over xs+acc3 :: (Elt a, P.Num a) => Acc (Vector a)+acc3 = scatterIf to mask p over xs where over = use [0, 0, 0, 0, 0, 0, 0, 0, 0] to = use [1, 3, 7, 2, 5, 8]@@ -59,14 +61,14 @@ mask :: Acc (Vector Int32) mask = use [3, 4, 9, 2, 7, 5]- p = (>* 4)+ p = (A.> 4) -ref4 :: (Elt a, Num a) => Vector a+ref4 :: (Elt a, P.Num a) => Vector a ref4 = fromList (Z :. 9) [0,0,0,0,0,0,0,6,0] -acc4 :: (Elt a, IsNum a) => Acc (Vector a)-acc4 = A.scatterIf to mask p over xs+acc4 :: (Elt a, P.Num a) => Acc (Vector a)+acc4 = scatterIf to mask p over xs where over = use [0, 0, 0, 0, 0, 0, 0, 0, 0] to = use [1, 3, 7, 2, 5, 8]@@ -74,24 +76,24 @@ mask :: Acc (Vector Int32) mask = use [3, 4, 9, 2, 7, 5]- p = (>* 4)+ p = (A.> 4) -ref5 :: (Elt a, Num a) => Vector a+ref5 :: (Elt a, P.Num a) => Vector a ref5 = fromList (Z :. 6) [9,4,1,6,2,4] -acc5 :: (Elt a, IsNum a) => Acc (Vector a)+acc5 :: (Elt a, P.Num a) => Acc (Vector a) acc5 = A.gather from xs where from = use [1, 3, 7, 2, 5, 3] xs = use [1, 9, 6, 4, 4, 2, 0, 1, 2] -ref6 :: (Elt a, Num a) => Vector a+ref6 :: (Elt a, P.Num a) => Vector a ref6 = fromList (Z :. 6) [6,6,1,6,2,4] -acc6 :: (Elt a, IsNum a) => Acc (Vector a)-acc6 = A.gatherIf from mask p over xs+acc6 :: (Elt a, P.Num a) => Acc (Vector a)+acc6 = gatherIf from mask p over xs where over = use [6, 6, 6, 6, 6, 6] from = use [1, 3, 7, 2, 5, 3]@@ -99,5 +101,33 @@ mask :: Acc (Vector Int32) mask = use [3, 4, 9, 2, 7, 5]- p = (>* 4)+ p = (A.> 4)+++gatherIf+ :: (Elt a, Elt b)+ => Acc (Vector Int) -- ^ source indices to gather from+ -> Acc (Vector a) -- ^ mask vector+ -> (Exp a -> Exp Bool) -- ^ predicate function+ -> Acc (Vector b) -- ^ default values+ -> Acc (Vector b) -- ^ source values+ -> Acc (Vector b)+gatherIf from maskV p def input = A.zipWith zf pf gatheredV+ where+ zf ok g = ok ? (unlift g)+ gatheredV = A.zip (gather from input) def+ pf = A.map p maskV++scatterIf+ :: (Elt e, Elt e')+ => Acc (Vector Int) -- ^ destination indices to scatter into+ -> Acc (Vector e) -- ^ mask vector+ -> (Exp e -> Exp Bool) -- ^ predicate function+ -> Acc (Vector e') -- ^ default values+ -> Acc (Vector e') -- ^ source values+ -> Acc (Vector e')+scatterIf to maskV p def input = permute const def pf input'+ where+ pf ix = p (maskV ! ix) ? ( index1 (to ! ix), ignore )+ input' = backpermute (shape to `intersect` shape input) id input
examples/nofib/Test/Issues/Issue187.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} module Test.Issues.Issue187 (test_issue187) where@@ -6,7 +7,6 @@ import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.Examples.Internal as A @@ -25,7 +25,7 @@ test1 = let x = constant 1 :: Exp Int v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)- y = (x ==* 1 ||* v A.!! (-1) ==* 1)+ y = (x == 1 || v A.!! (-1) == 1) in generate (constant Z) (const y) @@ -37,6 +37,6 @@ let x = constant 1 :: Exp Int x' = unit x v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)- y = (x ==* the x' ||* let y' = v A.!! (-1) in y'*y' ==* 1)+ y = (x == the x' || let y' = v A.!! (-1) in y'*y' == 1) in generate (constant Z) (const y)
+ examples/nofib/Test/Issues/Issue228.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+-- https://github.com/AccelerateHS/accelerate/issues/228+--++module Test.Issues.Issue228 (test_issue228)+ where++import Config+import Test.Framework+import Test.Framework.Providers.HUnit++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+++test_issue228 :: Backend -> Config -> Test+test_issue228 backend _conf =+ testGroup "228"+ [ testCase "A" (assertEqual ref1 $ run backend (A.fold mergeExp z1 (use test1)))+ , testCase "B" (assertEqual ref1 $ run backend (A.fold1 mergeExp (use test1)))+ ]++test1 :: Vector (Int,Int)+test1 = fromList (Z:.3) [(1,1),(0,0),(1,1)]++z1 :: Exp (Int,Int)+z1 = constant (1,0)++ref1 :: Scalar (Int,Int)+ref1 = fromList Z [(0,1)]++{--+testAssociativity =+ quickCheck $ \(x, y, z) -> mergeB x (mergeB y z) == mergeB (mergeB x y) z++mergeB :: (Bool,Int) -> (Bool,Int) -> (Bool,Int)+mergeB (b1,l1) (b2,l2) = (toEnum v3,l3)+ where+ (v3,l3) = merge (fromEnum b1,l1) (fromEnum b2,l2)+--}++merge :: P.Num a => (a,a) -> (a,a) -> (a,a)+merge (onL, lenL) (onR, lenR) = (onL * onR, onL * lenR + lenL)++mergeExp :: Exp (Int,Int) -> Exp (Int,Int) -> Exp (Int,Int)+mergeExp e1 e2 =+ let+ v1 = unlift e1 :: (Exp Int,Exp Int)+ v2 = unlift e2 :: (Exp Int,Exp Int)+ in+ lift $ merge v1 v2+
+ examples/nofib/Test/Issues/Issue255.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- https://github.com/AccelerateHS/accelerate/issues/255+--++module Test.Issues.Issue255 (test_issue255)+ where++import Config+import Test.HUnit ( assertFailure )+import Test.Framework+import Test.Framework.Providers.HUnit++import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A++import Control.Exception+import System.Timeout+import Data.List as P+import Prelude as P+++test_issue255 :: Backend -> Config -> Test+test_issue255 backend _conf =+ testGroup "255"+ [ testCase "0" (within lIMIT $ total (as P.!! 0))+ , testCase "2" (within lIMIT $ total (as P.!! 2))+ , testCase "4" (within lIMIT $ total (as P.!! 4))+ , testCase "20" (within lIMIT $ total (as P.!! 20))+ , testCase "100" (within lIMIT $ total (as P.!! 100))+ -- , testCase "200" (within lIMIT $ total (as P.!! 200))+ -- , testCase "300" (within lIMIT $ total (as P.!! 300))+ ]+ where+ lIMIT = 30 * 1000 * 1000 -- microseconds+ n = 20 * 1024 * 1024 -- 160 * MiB (8 bytes per Double)++ as :: [A.Vector Double]+ as = sums (A.fromList (Z:.n) (repeat 0)) (A.fromList (Z:.n) (repeat 1))++ sums :: A.Vector Double -> A.Vector Double -> [A.Vector Double]+ sums a0 b+ = a0+ : ( P.snd+ $ P.mapAccumL+ (\a' i -> let a = run1 backend step (a', b, scalar i)+ in (a, a))+ a0+ [0 .. 500]+ )++ step :: Acc (A.Vector Double, A.Vector Double, A.Scalar Int) -> Acc (A.Vector Double)+ step (unlift -> (a, b, A.the -> _i::Exp Int)) = A.zipWith (+) a b++ total :: A.Vector Double -> A.Scalar Double+ total a =+ run backend $ A.sum $ A.map id $ A.use a++ -- print $ total $ as P.!! 0+ -- print $ total $ as P.!! 2+ -- print $ total $ as P.!! 4+ -- print $ total $ as P.!! 20+ -- print $ total $ as P.!! 100+ -- print $ total $ as P.!! 200+ -- print $ total $ as P.!! 300+++within :: Int -> Scalar Double -> Assertion+within n arr = do+ r <- timeout n $ evaluate (indexArray arr Z `seq` ())+ case r of+ Nothing -> assertFailure "timeout: backend is too slow or memory manager stuck?"+ Just () -> return ()+
+ examples/nofib/Test/Issues/Issue264.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+-- https://github.com/AccelerateHS/accelerate/issues/264+--++module Test.Issues.Issue264 (test_issue264)+ where++import Config+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck hiding ( (.&.) )+import QuickCheck.Arbitrary.Array ()++import Prelude as P+import Data.Bits as P+import Data.Label+import Data.Maybe+import Data.Typeable+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Bits as A+import Data.Array.Accelerate.Examples.Internal as A++import qualified Data.Array.Accelerate.Array.Sugar as S+import qualified Data.Array.Accelerate.Array.Representation as R+++test_issue264 :: Backend -> Config -> Test+test_issue264 backend opt+ = testGroup "264"+ $ catMaybes+ [ testBool+ , 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+ testBool :: Maybe Test+ testBool = Just $ testGroup "Bool"+ [ testProperty "not.not" (test_notnot :: Vector Bool -> Property)+ , testProperty "not(x&&y)" (test_andnot :: Vector Bool -> Vector Bool -> Property)+ , testProperty "not(x||y)" (test_ornot :: Vector Bool -> Vector Bool -> Property)+ , testProperty "not(not(x&&y))" (test_andnotnot :: Vector Bool -> Vector Bool -> Property)+ , testProperty "not(not(x||y))" (test_ornotnot :: Vector Bool -> Vector Bool -> Property)+ ]++ testIntegralElt :: forall a. (P.Integral a, P.Bits a, A.Integral a, A.Bits a, Arbitrary a, Similar a, A.FromIntegral a Float) => (Config :-> Bool) -> a -> Maybe Test+ testIntegralElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))+ [ testProperty "neg.neg" (test_negneg :: Vector a -> Property)+ ]++ testFloatingElt :: forall a. (P.Floating a, P.RealFloat a, A.Floating a, A.RealFloat a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testFloatingElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))+ [ testProperty "neg.neg" (test_negneg :: Vector a -> Property)+ ]++ test_negneg xs = run1 backend (A.map negate . A.map negate) xs ~?= mapRef (negate . negate) xs+ test_notnot xs = run1 backend (A.map A.not . A.map A.not) xs ~?= mapRef (P.not . P.not) xs++ test_andnot xs ys = run2 backend (A.zipWith (\x y -> A.not (x A.&& y))) xs ys+ ~?=+ zipWithRef (\x y -> P.not (x P.&& y)) xs ys++ test_ornot xs ys = run2 backend (A.zipWith (\x y -> A.not (x A.|| y))) xs ys+ ~?=+ zipWithRef (\x y -> P.not (x P.|| y)) xs ys++ test_andnotnot xs ys = run2 backend (A.zipWith (\x y -> A.not (A.not (x A.&& y)))) xs ys+ ~?=+ zipWithRef (\x y -> P.not (P.not (x P.&& y))) xs ys++ test_ornotnot xs ys = run2 backend (A.zipWith (\x y -> A.not (A.not (x A.|| y)))) xs ys+ ~?=+ zipWithRef (\x y -> P.not (P.not (x P.|| y))) xs ys++mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b+mapRef f xs+ = fromList (arrayShape xs)+ $ P.map f+ $ toList xs++zipWithRef :: (Shape sh, Elt c) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c+zipWithRef f xs ys =+ let shx = S.fromElt (S.shape xs)+ shy = S.fromElt (S.shape ys)+ sh = S.toElt (R.intersect shx shy)+ in+ fromFunction sh (\ix -> f (xs S.! ix) (ys S.! ix))+
+ examples/nofib/Test/Issues/Issue286.hs view
@@ -0,0 +1,122 @@+-- https://github.com/AccelerateHS/accelerate/issues/286+--++module Test.Issues.Issue286 (test_issue286)+ where++import Config+import Test.Framework+import Test.Framework.Providers.HUnit++import Prelude as P+import Data.Array.Accelerate as A hiding ( (>->), (==) )+import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Examples.Internal as A++import Pipes+import Data.Vector.Storable as S+++test_issue286 :: Backend -> Config -> Test+test_issue286 backend _conf =+ testGroup "286 (run with +RTS -M4M -RTS or check heap profile in EKG or similar)"+ [+ testCase "hs.hs" (void $ runEffect $ hs_producer sh >-> hs_consume_sv)+ , testCase "hs.acc" (void $ runEffect $ hs_producer sh >-> acc_consume_sv sh backend)+ , testCase "acc.hs" (void $ runEffect $ acc_producer sh >-> hs_consume_acc)+ , testCase "acc.acc" (void $ runEffect $ acc_producer sh >-> acc_consume_acc backend)+ ]+ where+ sh :: DIM2+ sh = Z :. 120 :. 659++hs_producer :: DIM2 -> Producer (S.Vector Word8) IO ()+hs_producer sh = producer' 0+ where+ producer' :: Int -> Producer (S.Vector Word8) IO ()+ producer' i = do+ yield $ S.replicate (arraySize sh) 1+ if i == 5+ then producer' 0+ else producer' (i+1)++hs_consume_sv :: Consumer (S.Vector Word8) IO ()+hs_consume_sv = consumer' 0 0+ where+ consumer' :: Int -> Float -> Consumer (S.Vector Word8) IO ()+ consumer' n acc = do+ v <- await+ let+ i = S.sum $ S.map P.fromIntegral v+ i' = i + acc+ n' = n + 1+ if i' `seq` n' `seq` (n == lIMIT)+ then acc `seq` return ()+ else consumer' n' i'++hs_consume_acc :: Consumer (Array DIM2 Word8) IO ()+hs_consume_acc = consumer' 0 0+ where+ consumer' :: Int -> Float -> Consumer (Array DIM2 Word8) IO ()+ consumer' n acc = do+ v <- await+ let+ a = toVectors v :: S.Vector Word8+ i = S.sum $ S.map P.fromIntegral a+ i' = i + acc+ n' = n + 1+ if i' `seq` n' `seq` (n == lIMIT)+ then acc `seq` return ()+ else consumer' n' i'++acc_producer :: DIM2 -> Producer (Array DIM2 Word8) IO ()+acc_producer sh = producer' 0+ where+ producer' :: Int -> Producer (Array DIM2 Word8) IO ()+ producer' i =+ do+ yield $ A.fromFunction sh (\_ -> 1)+ if i == 5+ then producer' 0+ else producer' (i+1)++acc_consume_sv :: DIM2 -> Backend -> Consumer (S.Vector Word8) IO ()+acc_consume_sv sh backend = consumer' 0 0+ where+ go = run1 backend (A.sum . A.map A.fromIntegral)++ consumer' :: Int -> Float -> Consumer (S.Vector Word8) IO ()+ consumer' n acc = do+ v <- await+ let+ a = fromVectors sh v :: Array DIM2 Word8+ i = the' $ go a+ i' = i + acc+ n' = n + 1+ if i' `seq` n' `seq` (n == lIMIT)+ then acc `seq` return ()+ else consumer' n' i'++acc_consume_acc :: Backend -> Consumer (Array DIM2 Word8) IO ()+acc_consume_acc backend = consumer' 0 0+ where+ go = run1 backend (A.sum . A.map A.fromIntegral)++ consumer' :: Int -> Float -> Consumer (Array DIM2 Word8) IO ()+ consumer' n acc = do+ a <- await+ let+ i = the' $ go a+ i' = i + acc+ n' = n + 1+ if i' `seq` n' `seq` (n == lIMIT)+ then acc `seq` return ()+ else consumer' n' i'+++lIMIT :: Int+lIMIT = 50000++the' :: Scalar a -> a+the' x = indexArray x Z+
+ examples/nofib/Test/Issues/Issue287.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- https://github.com/AccelerateHS/accelerate/issues/287+-- https://gist.github.com/cpdurham/7c11134bc345f12a8863+--++module Test.Issues.Issue287 (test_issue287)+ where++import Config+import Test.Framework+import Test.Framework.Providers.HUnit++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+++test_issue287 :: Backend -> Config -> Test+test_issue287 backend _conf =+ testGroup "287"+ [ testCase "A" (assertEqual ref1 $ run1 backend (\x -> A.scanl1 f x) arr1)+ , testCase "B" (assertEqual ref1 $ run1 backend (\x -> A.scanl1Seg (\_ b -> b) x (use segs)) arr1)+ , testCase "C" (assertEqual ref1 $ run1 backend (\x -> A.scanl1Seg f x (use segs)) arr1)+ ]++ref1 :: Vector (Int,Int,Int,Int,Int,Int)+ref1 = fromList (Z:.4) [(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0)]++arr1 :: Vector (Int,Int,Int,Int,Int,Int)+arr1 = fromList (Z:.4) [(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0)]++segs :: Segments Int+segs = A.fromList (Z:.2) [2,2]++f :: forall a. (A.Num a, A.Ord a)+ => Exp (a,a,a,a,a,a)+ -> Exp (a,a,a,a,a,a)+ -> Exp (a,a,a,a,a,a)+f x y = lift (mi3,l3,c3,r3,li3,ri3)+ where+ ( mi1,l1, c1,r1, li1,ri1) = unlift x :: (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)+ (_mi2,l2,_c2,r2,_li2,ri2) = unlift y :: (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)+ --+ l3 = l1+ c3 = c1+ r3 = r2 * r1+ mi3 = A.max mi1 (ri1+l2)+ li3 = li1+ ri3 = ri2++-- fExp+-- :: Exp (Int,Int,Int,Int,Int,Int)+-- -> Exp (Int,Int,Int,Int,Int,Int)+-- -> Exp (Int,Int,Int,Int,Int,Int)+-- fExp e1 e2 =+-- let+-- v1 = unlift6E e1+-- v2 = unlift6E e2+-- in+-- lift $ f v1 v2++-- unlift6E+-- :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+-- => Exp (a,b,c,d,e,f)+-- -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+-- unlift6E = unlift++-- lift6E+-- :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+-- => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+-- -> Exp (a,b,c,d,e,f)+-- lift6E = lift++-- convert+-- :: Acc (Array DIM1 Int)+-- -> Acc (Array DIM1 (Int,Int,Int,Int,Int,Int))+-- convert = A.map (\_ -> lift6E (0,0,0,0,0,0))++-- arr2 = I.run1 convert (A.fromList (Z :. 4 :: DIM1) ([1,1,1,1]) :: Array DIM1 Int)++-- print $ C.run1 (\x -> A.scanl1 fExp x) $ arr2+-- --no problem++-- print $ C.run1 (\x -> A.scanl1Seg (\_ b -> b) x segs) $ arr2+-- --no problem++-- print $ C.run1 (\x -> A.scanl1Seg fExp x segs) $ arr2+-- -- CUDA exception: invalid argument+
+ examples/nofib/Test/Issues/Issue288.hs view
@@ -0,0 +1,25 @@+-- https://github.com/AccelerateHS/accelerate/issues/288+--++module Test.Issues.Issue288 (test_issue288)+ where++import Config+import Test.Framework+import Test.Framework.Providers.HUnit++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+++test_issue288 :: Backend -> Config -> Test+test_issue288 backend _conf =+ testCase "288" (assertEqual xs $ run1 backend (A.map f) xs)++f :: Exp (Int, Int) -> Exp (Int, Int)+f e = while (const (lift False)) id e++xs :: Vector (Int, Int)+xs = fromList (Z:.10) (P.zip [1..] [1..])+
+ examples/nofib/Test/Issues/Issue362.hs view
@@ -0,0 +1,52 @@++-- https://github.com/AccelerateHS/accelerate-llvm/issues/12+--++module Test.Issues.Issue362 (test_issue362)+ where++import Config+import Test.Framework+import Test.Framework.Providers.HUnit++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+++test_issue362 :: Backend -> Config -> Test+test_issue362 backend _conf =+ testGroup "362"+ [ testCase "A" (assertEqual e1 $ run backend t1)+ , testCase "B" (assertEqual e2 $ run backend t2)+ ]++-- should work+e1 :: Vector (Int,Int,Int,Int)+e1 = fromList (Z:.10) [(0,0,0,0),(1,1,1,1),(3,3,3,3),(6,6,6,6),(10,10,10,10),(15,15,15,15),(21,21,21,21),(28,28,28,28),(36,36,36,36),(45,45,45,45)]++t1 :: Acc (Vector (Int,Int,Int,Int))+t1 = A.scanl1 (lift2 f) xs+ where+ xs = use $ fromList (Z:.10) [ (x,x,x,x) | x <- [0..9] ]+ --+ f :: (Exp Int, Exp Int, Exp Int, Exp Int)+ -> (Exp Int, Exp Int, Exp Int, Exp Int)+ -> (Exp Int, Exp Int, Exp Int, Exp Int)+ f (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)+++-- was broken on pascal +e2 :: Vector (Int,Int,Int,Int,Int)+e2 = fromList (Z:.10) [(0,0,0,0,0),(1,1,1,1,1),(3,3,3,3,3),(6,6,6,6,6),(10,10,10,10,10),(15,15,15,15,15),(21,21,21,21,21),(28,28,28,28,28),(36,36,36,36,36),(45,45,45,45,45)]++t2 :: Acc (Vector (Int,Int,Int,Int,Int))+t2 = A.scanl1 (lift2 f) xs+ where+ xs = use $ fromList (Z:.10) [ (x,x,x,x,x) | x <- [0..9] ]+ --+ f :: (Exp Int, Exp Int, Exp Int, Exp Int, Exp Int)+ -> (Exp Int, Exp Int, Exp Int, Exp Int, Exp Int)+ -> (Exp Int, Exp Int, Exp Int, Exp Int, Exp Int)+ f (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)+
examples/nofib/Test/Prelude.hs view
@@ -2,17 +2,18 @@ module Test.Prelude where import Config+import Data.Array.Accelerate.Examples.Internal -import Test.Framework+import Test.Prelude.Backpermute import Test.Prelude.Filter-import Test.Prelude.IndexSpace-import Test.Prelude.Mapping-import Test.Prelude.PrefixSum-import Test.Prelude.Reduction+import Test.Prelude.Fold+import Test.Prelude.Map+import Test.Prelude.Permute import Test.Prelude.Replicate+import Test.Prelude.Scan+-- import Test.Prelude.Sequences import Test.Prelude.Stencil--import Data.Array.Accelerate.Examples.Internal+import Test.Prelude.ZipWith test_prelude :: Backend -> Config -> Test@@ -24,10 +25,10 @@ , test_fold be conf , test_backpermute be conf , test_permute be conf- , test_prefixsum be conf -- requires fold+ , test_scan be conf -- requires fold , test_foldSeg be conf -- requires scan , test_stencil be conf , test_replicate be conf , test_filter be conf+ -- , test_sequences be conf ]-
+ examples/nofib/Test/Prelude/Backpermute.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Test.Prelude.Backpermute (++ test_backpermute++) where++import Prelude as P+import Data.Label+import Data.Maybe+import Data.Typeable+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.Array.Sugar as A ( Array(..) )+import Data.Array.Accelerate.Examples.Internal as A+++--+-- Backward permutation --------------------------------------------------------+--++test_backpermute :: Backend -> Config -> Test+test_backpermute backend opt = testGroup "backpermute" $ catMaybes+ [ testElt configInt8 (undefined :: Int8)+ , testElt configInt16 (undefined :: Int16)+ , testElt configInt32 (undefined :: Int32)+ , testElt configInt64 (undefined :: Int64)+ , testElt configWord8 (undefined :: Word8)+ , testElt configWord16 (undefined :: Word16)+ , testElt configWord32 (undefined :: Word32)+ , testElt configWord64 (undefined :: Word64)+ , testElt configFloat (undefined :: Float)+ , testElt configDouble (undefined :: Double)+ ]+ where+ testElt :: forall e. (Elt e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test+ testElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined::e)))+ [ testProperty "reverse" (test_reverse :: Array DIM1 e -> Property)+ , testProperty "transpose" (test_transpose :: Array DIM2 e -> Property)+ , testProperty "init" (test_init :: Array DIM1 e -> Property)+ , testProperty "tail" (test_tail :: Array DIM1 e -> Property)+ , testProperty "take" (test_take :: Array DIM1 e -> Property)+ , testProperty "drop" (test_drop :: Array DIM1 e -> Property)+ , testProperty "slit" (test_slit :: Array DIM1 e -> Property)+ , testProperty "gather" (test_gather :: Array DIM1 e -> Property)+ -- , testProperty "gatherIf" (test_gatherIf :: Array DIM1 e -> Property)+ ]+ where+ test_reverse :: Vector e -> Property+ test_reverse xs = run1 backend A.reverse xs ~?= reverseRef xs++ test_transpose :: Array DIM2 e -> Property+ test_transpose xs = run1 backend A.transpose xs ~?= transposeRef xs++ -- Reverse a vector+ --+ reverseRef xs = fromList (arrayShape xs) (P.reverse $ toList xs)++ -- Transpose a 2D matrix+ --+ transposeRef xs =+ let swap (Z:.x:.y) = Z :. y :. x+ in fromFunction (swap (arrayShape xs)) (\ix -> indexArray xs (swap ix))++ -- Extracting sub-vectors+ --+ test_init :: Vector e -> Property+ test_init xs =+ P.not (isEmptyArray xs)+ ==> toList (run1 backend A.init xs) ~?= P.init (toList xs)++ test_tail :: Vector e -> Property+ test_tail xs =+ P.not (isEmptyArray xs)+ ==> toList (run1 backend A.tail xs) ~?= P.tail (toList xs)++ test_drop :: Vector e -> Property+ test_drop xs =+ let n = arraySize (arrayShape xs)+ in forAll (choose (0, 0 `P.max` (n-1))) $ \i ->+ toList (run2 backend (\i' -> A.drop (the i')) (scalar i) xs)+ ~?=+ P.drop i (toList xs)++ test_take :: Vector e -> Property+ test_take xs@(Array _ adata) =+ let Z :. n = arrayShape xs+ in forAll (choose (0, 0 `P.max` (n-1))) $ \i ->+ run2 backend (\i' -> A.take (the i')) (scalar i) xs+ ~?=+ Array ((),i) adata++ test_slit :: Vector e -> Property+ test_slit xs =+ let n = arraySize (arrayShape xs)+ in forAll (choose (0, 0 `P.max` (n-1))) $ \i ->+ forAll (choose (0, 0 `P.max` (n-1-i))) $ \j ->+ toList (run3 backend (\i' j' -> A.slit (the i') (the j')) (scalar i) (scalar j) xs)+ ~?=+ P.take j (P.drop i (toList xs))++ -- Gathering+ --+ test_gather :: Vector e -> Property+ test_gather xs =+ let Z :. n = arrayShape xs+ in n P.> 0 ==>+ forAll arbitrary $ \(sh' :: DIM1) ->+ forAll (arbitraryArrayOf sh' (choose (0,n-1))) $ \mapv ->+ toList (run2 backend A.gather mapv xs)+ ~?=+ [ xs `indexArray` (Z:.i) | i <- toList mapv ]++ -- test_gatherIf :: Vector e -> Property+ -- test_gatherIf xs =+ -- let n = arraySize (arrayShape xs)+ -- n' = 0 `P.max` (n-1)+ -- in+ -- forAll arbitrary $ \sh' ->+ -- forAll (arbitraryArrayOf sh' (choose (0,n'))) $ \mapv ->+ -- forAll (arbitraryArray sh') $ \(maskv :: Vector Int) ->+ -- forAll (arbitraryArray sh') $ \defaultv ->+ -- toList (run4 backend (\p m d x -> A.gatherIf p m A.even d x) mapv maskv defaultv xs)+ -- ~?=+ -- gatherIfRef P.even mapv maskv defaultv xs+++-- Reference Implementation+-- ------------------------++-- gatherIfRef :: (e -> Bool) -> Vector Int -> Vector e -> Vector t -> Vector t -> [t]+-- gatherIfRef g mapv maskv defaultv inputv+-- = let n = arraySize (arrayShape defaultv)+-- select ix+-- | g (maskv `indexArray` ix) = inputv `indexArray` (Z :. mapv `indexArray` ix)+-- | otherwise = defaultv `indexArray` ix+-- in+-- [ select ix | i <- [0 .. n-1], let ix = Z :. i ]+
examples/nofib/Test/Prelude/Filter.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -16,9 +18,11 @@ import Test.Framework.Providers.QuickCheck2 import Config+import Test.Base import QuickCheck.Arbitrary.Array ()-import Data.Array.Accelerate as A+import Data.Array.Accelerate as A hiding ( size ) import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.Array.Sugar as Sugar -- -- Filter ----------------------------------------------------------------------@@ -38,18 +42,45 @@ , testFloatingElt configDouble (undefined :: Double) ] where- testIntegralElt :: forall e. (Elt e, Integral e, IsIntegral e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test+ testIntegralElt :: forall e. (P.Integral e, A.Integral e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test testIntegralElt ok _ | P.not (get ok opt) = Nothing- | otherwise = Just- $ testProperty (show (typeOf (undefined :: e))) (run_filter A.even P.even :: Vector e -> Property)+ | otherwise = Just $ testGroup (show (typeOf (undefined::e)))+ [ testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, Slice sh, P.Eq sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [ testProperty "even" (run_filter A.even P.even :: Array (sh:.Int) e -> Property)+ ] - testFloatingElt :: forall e. (Elt e, RealFrac e, IsFloating e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test+ testFloatingElt :: forall e. (P.RealFrac e, A.RealFrac e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test testFloatingElt ok _ | P.not (get ok opt) = Nothing- | otherwise = Just- $ testProperty (show (typeOf (undefined :: e))) (run_filter (>* 0) (> 0) :: Vector e -> Property)+ | otherwise = Just $ testGroup (show (typeOf (undefined::e)))+ [ testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, Slice sh, P.Eq sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [ testProperty "positive" (run_filter (A.> 0) (P.> 0) :: Array (sh:.Int) e -> Property)+ ] run_filter f g xs- = toList (run1 backend (A.filter f) xs) ~?= P.filter g (toList xs)+ = run1 backend (A.filter f) xs ~?= filterRef g xs+++filterRef+ :: (Shape sh, Elt e)+ => (e -> Bool)+ -> Array (sh:.Int) e+ -> (Vector e, Array sh Int)+filterRef f arr = (fromList (Z:.total) (concat result), fromList sh len)+ where+ sh :. n = arrayShape arr+ result = P.take (size sh) [ P.filter f sub | sub <- splitEvery n (toList arr) ]+ len = P.map P.length result+ total = P.sum len
+ examples/nofib/Test/Prelude/Fold.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Prelude.Fold (++ test_fold,+ test_foldAll,+ test_foldSeg,++) where++import Prelude as P+import Data.List+import Data.Label+import Data.Maybe+import Data.Typeable+import Test.QuickCheck+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Data.Array.Accelerate as A hiding ( Ord(..), indexHead, indexTail )+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar as Sugar+import Data.Array.Accelerate.Examples.Internal as A+import qualified Data.Array.Accelerate as A++import Config+import Test.Base+import System.Random+import QuickCheck.Arbitrary.Array++++--+-- Reduction -------------------------------------------------------------------+--++-- foldAll+-- -------++test_foldAll :: Backend -> Config -> Test+test_foldAll backend opt = testGroup "foldAll" $ catMaybes+ [ testElt configInt8 (undefined :: Int8)+ , testElt configInt16 (undefined :: Int16)+ , testElt configInt32 (undefined :: Int32)+ , testElt configInt64 (undefined :: Int64)+ , testElt configWord8 (undefined :: Word8)+ , testElt configWord16 (undefined :: Word16)+ , testElt configWord32 (undefined :: Word32)+ , testElt configWord64 (undefined :: Word64)+ , testElt configFloat (undefined :: Float)+ , testElt configDouble (undefined :: Double)+ ]+ where+ testElt :: forall e. (P.Num e, P.Ord e, A.Num e, A.Ord e, Similar e, Arbitrary e, Random e) => (Config :-> Bool) -> e -> Maybe Test+ testElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))+ [ testDim dim0+ , testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, Arbitrary sh, Arbitrary (Array sh e)) => sh -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [+ testProperty "sum" (test_sum :: Array sh e -> Property)+ , testProperty "non-neutral sum" (test_sum' :: Array sh e -> NonZero e -> Property)+ , testProperty "non-commutative" (test_mss :: sh -> e -> Property)+ , testProperty "minimum" (test_min :: Array sh e -> Property)+ , testProperty "maximum" (test_max :: Array sh e -> Property)+ ]+ where+ --+ -- The tests+ --+ test_min :: Array sh e -> Property+ test_min xs+ = arraySize (arrayShape xs) > 0+ ==> run1 backend (A.fold1All A.min) xs ~?= fold1AllRef P.min xs++ test_max :: Array sh e -> Property+ test_max xs+ = arraySize (arrayShape xs) > 0+ ==> run1 backend (A.fold1All A.max) xs ~?= fold1AllRef P.max xs++ test_sum :: Array sh e -> Property+ test_sum xs = run1 backend (A.foldAll (+) 0) xs ~?= foldAllRef (+) 0 xs++ test_sum' :: Array sh e -> NonZero e -> Property+ test_sum' xs (NonZero z) =+ run2 backend (\z' -> A.foldAll (+) (the z')) (scalar z) xs+ ~?=+ foldAllRef (+) z xs++ test_mss :: sh -> e -> Property+ test_mss (arraySize -> n) _+ = n > 0+ ==> forAll (arbitraryArrayOf (Z:.n) smallArbitrary) $ \(xs :: Vector e) ->+ run1 backend maximumSegmentSum xs ~?= maximumSegmentSumRef xs+++-- multidimensional fold+-- ---------------------++test_fold :: Backend -> Config -> Test+test_fold backend opt = testGroup "fold" $ catMaybes+ [ testElt configInt8 (undefined :: Int8)+ , testElt configInt16 (undefined :: Int16)+ , testElt configInt32 (undefined :: Int32)+ , testElt configInt64 (undefined :: Int64)+ , testElt configWord8 (undefined :: Word8)+ , testElt configWord16 (undefined :: Word16)+ , testElt configWord32 (undefined :: Word32)+ , testElt configWord64 (undefined :: Word64)+ , testElt configFloat (undefined :: Float)+ , testElt configDouble (undefined :: Double)+ ]+ where+ testElt :: forall e. (P.Num e, P.Ord e, A.Num e, A.Ord e, Similar e, Arbitrary e, Random e) => (Config :-> Bool) -> e -> Maybe Test+ testElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))+ [ testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary (sh :. Int), Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [+ testProperty "sum" (test_sum :: Array (sh :. Int) e -> Property)+ , testProperty "non-neutral sum" (test_sum' :: Array (sh :. Int) e -> NonZero e -> Property)+ , testProperty "non-commutative" (test_mss :: (sh :. Int) -> e -> Property)+ , testProperty "minimum" (test_min :: Array (sh :. Int) e -> Property)+ , testProperty "maximum" (test_max :: Array (sh :. Int) e -> Property)+ ]+ where+ --+ -- The tests+ --+ test_min :: Array (sh:.Int) e -> Property+ test_min xs+ = indexHead (arrayShape xs) > 0+ ==> run1 backend (A.fold1 A.min) xs ~?= fold1Ref P.min xs++ test_max :: Array (sh:.Int) e -> Property+ test_max xs+ = indexHead (arrayShape xs) > 0+ ==> run1 backend (A.fold1 A.max) xs ~?= fold1Ref P.max xs++ test_sum :: Array (sh:.Int) e -> Property+ test_sum xs = run1 backend (A.fold (+) 0) xs ~?= foldRef (+) 0 xs++ test_sum' :: Array (sh:.Int) e -> NonZero e -> Property+ test_sum' xs (NonZero z) =+ run2 backend (\z' -> A.fold (+) (the z')) (scalar z) xs ~?= foldRef (+) z xs++ test_mss :: (sh:.Int) -> e -> Property+ test_mss sz _+ = indexHead sz > 0+ ==> forAll (arbitraryArrayOf sz smallArbitrary) $ \(xs :: Array (sh:.Int) e) ->+ run1 backend maximumSegmentSum xs ~?= maximumSegmentSumRef xs+++-- segmented fold+-- --------------++test_foldSeg :: Backend -> Config -> Test+test_foldSeg backend opt = testGroup "foldSeg" $ catMaybes+ [ testElt configInt8 (undefined :: Int8)+ , testElt configInt16 (undefined :: Int16)+ , testElt configInt32 (undefined :: Int32)+ , testElt configInt64 (undefined :: Int64)+ , testElt configWord8 (undefined :: Word8)+ , testElt configWord16 (undefined :: Word16)+ , testElt configWord32 (undefined :: Word32)+ , testElt configWord64 (undefined :: Word64)+ , testElt configFloat (undefined :: Float)+ , testElt configDouble (undefined :: Double)+ ]+ where+ testElt :: forall e. (P.Num e, P.Ord e, A.Num e, A.Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test+ testElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))+ [ testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary sh) => (sh:.Int) -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [+ testProperty "sum"+ $ forAllShrink arbitrarySegments shrinkSegments $ \(seg :: Segments Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \(xs :: Array (sh:.Int) e) ->+ run2 backend (A.foldSeg (+) 0) xs seg ~?= foldSegRef (+) 0 xs seg++ , testProperty "non-neutral sum"+ $ forAllShrink arbitrarySegments shrinkSegments $ \(seg :: Segments Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \(xs :: Array (sh:.Int) e) ->+ forAll arbitrary $ \(NonZero z) ->+ run3 backend (\z' -> A.foldSeg (+) (the z')) (scalar z) xs seg ~?= foldSegRef (+) z xs seg++ , testProperty "minimum"+ $ forAllShrink arbitrarySegments1 shrinkSegments1 $ \(seg :: Segments Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \(xs :: Array (sh:.Int) e) ->+ run2 backend (A.fold1Seg A.min) xs seg ~?= fold1SegRef P.min xs seg+ ]+++-- Reference implementation+-- ------------------------++foldAllRef :: Elt e => (e -> e -> e) -> e -> Array sh e -> Array Z e+foldAllRef f z+ = A.fromList Z+ . return+ . foldl' f z+ . A.toList++fold1AllRef :: Elt e => (e -> e -> e) -> Array sh e -> Array Z e+fold1AllRef f+ = A.fromList Z+ . return+ . foldl1' f+ . A.toList++foldRef :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Array sh e+foldRef f z arr =+ let (sh :. n) = arrayShape arr+ sh' = listToShape . P.map (P.max 1) . shapeToList $ sh+ in fromList sh' [ foldl' f z sub | sub <- splitEvery n (toList arr) ]++fold1Ref :: (Shape sh, Elt e) => (e -> e -> e) -> Array (sh :. Int) e -> Array sh e+fold1Ref f arr =+ let (sh :. n) = arrayShape arr+ in fromList sh [ foldl1' f sub | sub <- splitEvery n (toList arr) ]++foldSegRef :: (Shape sh, Elt e, P.Integral i) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e+foldSegRef f z arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ]+ where+ (sh :. n) = arrayShape arr+ (Z :. sz) = arrayShape seg+ seg' = toList seg+ foldseg xs = P.map (foldl' f z) (splitPlaces seg' xs)++fold1SegRef :: (Shape sh, Elt e, P.Integral i) => (e -> e -> e) -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e+fold1SegRef f arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ]+ where+ (sh :. n) = arrayShape arr+ (Z :. sz) = arrayShape seg+ seg' = toList seg+ foldseg xs = P.map (foldl1' f) (splitPlaces seg' xs)++maximumSegmentSum :: forall sh e. (Shape sh, A.Num e, A.Ord e) => Acc (Array (sh :. Int) e) -> Acc (Array sh e)+maximumSegmentSum+ = A.map (\v -> let (x,_,_,_) = unlift v :: (Exp e, Exp e, Exp e, Exp e) in x)+ . A.fold1 f+ . A.map g+ where+ f :: (A.Num a, A.Ord a) => Exp (a,a,a,a) -> Exp (a,a,a,a) -> Exp (a,a,a,a)+ f x y =+ let (mssx, misx, mcsx, tsx) = unlift x+ (mssy, misy, mcsy, tsy) = unlift y+ in+ lift ( mssx `A.max` (mssy `A.max` (mcsx+misy))+ , misx `A.max` (tsx+misy)+ , mcsy `A.max` (mcsx+tsy)+ , tsx+tsy+ )++ g :: (A.Num a, A.Ord a) => Exp a -> Exp (a,a,a,a)+ g x = let y = A.max x 0+ in lift (y,y,y,x)+++maximumSegmentSumRef :: (P.Num e, P.Ord e, Shape sh, Elt e) => Array (sh :. Int) e -> Array sh e+maximumSegmentSumRef arr = fromList sh [ go 0 0 sub | sub <- splitEvery n (toList arr) ]+ where+ sh :. n = arrayShape arr+ --+ go _ v [] = v+ go u v (x:xs) =+ let u' = 0 `P.max` (u+x)+ v' = v `P.max` u'+ in+ go u' v' xs+++smallArbitrary :: forall e. (P.Num e, Elt e, Arbitrary e, Random e) => Gen e+smallArbitrary+ | SingleTuple t <- eltType (undefined::e)+ , NumScalarType s <- t+ , IntegralNumType i <- s+ = case i of+ TypeInt{} -> choose (-100,100)+ TypeInt8{} -> choose (-1,1)+ TypeInt16{} -> choose (-10,10)+ TypeInt32{} -> choose (-1000,1000)+ TypeInt64{} -> choose (-10000,10000)+ TypeWord{} -> choose (0,1000)+ TypeWord8{} -> choose (0,1)+ TypeWord16{} -> choose (0,10)+ TypeWord32{} -> choose (0,1000)+ TypeWord64{} -> choose (0,10000)+ _ -> arbitrary++ | otherwise+ = arbitrary+
− examples/nofib/Test/Prelude/IndexSpace.hs
@@ -1,293 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--module Test.Prelude.IndexSpace (-- test_permute,- test_backpermute--) 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.Array.Sugar ( newArray, dim )-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. (Elt e, Integral e, IsIntegral e, 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. (Elt e, RealFrac e, IsFloating 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. (Elt e, IsNum 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, Eq sh, Arbitrary sh, Arbitrary (Array sh e)) => sh -> Test- testDim sh = testProperty ("DIM" P.++ show (dim sh)) (push_fill :: Array sh e -> Property)- where- push_fill :: Array sh e -> Property- push_fill xs =- let xs' = use xs- zeros = A.fill (A.shape xs') (constant 0)- in- run backend (permute const zeros id xs') ~?= xs-- -- Test if the combining operation for forward permutation works, by- -- building a histogram. Often tricky for parallel backends.- --- test_histogram :: (Elt e, IsNum e, Similar e, Arbitrary e, IArray UArray e) => (Exp e -> Exp Int) -> (e -> Int) -> Vector e -> Property- test_histogram f g xs =- forAll (sized return) $- \n -> run backend (histogramAcc n f xs) ~?= histogramRef n g xs-- histogramAcc :: (Elt e, IsNum e) => Int -> (Exp e -> Exp Int) -> Vector e -> Acc (Vector e)- histogramAcc n f xs =- let n' = unit (constant n)- xs' = use xs- zeros = A.generate (constant (Z :. n)) (const 0)- ones = A.generate (shape xs') (const 1)- in- permute (+) zeros (\ix -> index1 $ f (xs' A.! ix) `mod` the n') ones-- histogramRef :: forall e. (Elt e, 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 (run backend $ A.scatter (use mapV) (use defaultV) (use 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 (run backend $ A.scatterIf (use mapV) (use maskV) A.even (use defaultV) (use inputV))- ~?=- IArray.elems (scatterIfRef (toIArray mapV) (toIArray maskV) P.even (toIArray defaultV) (toIArray inputV))-------- Backward permutation -------------------------------------------------------------test_backpermute :: Backend -> Config -> Test-test_backpermute backend opt = testGroup "backpermute" $ catMaybes- [ testElt configInt8 (undefined :: Int8)- , testElt configInt16 (undefined :: Int16)- , testElt configInt32 (undefined :: Int32)- , testElt configInt64 (undefined :: Int64)- , testElt configWord8 (undefined :: Word8)- , testElt configWord16 (undefined :: Word16)- , testElt configWord32 (undefined :: Word32)- , testElt configWord64 (undefined :: Word64)- , testElt configFloat (undefined :: Float)- , testElt configDouble (undefined :: Double)- ]- where- testElt :: forall e. (Elt e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test- testElt ok _- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined::e)))- [ testProperty "reverse" (test_reverse :: Array DIM1 e -> Property)- , testProperty "transpose" (test_transpose :: Array DIM2 e -> Property)- , testProperty "init" (test_init :: Array DIM1 e -> Property)- , testProperty "tail" (test_tail :: Array DIM1 e -> Property)- , testProperty "take" (test_take :: Array DIM1 e -> Property)- , testProperty "drop" (test_drop :: Array DIM1 e -> Property)- , testProperty "slit" (test_slit :: Array DIM1 e -> Property)- , testProperty "gather" (test_gather :: Array DIM1 e -> Property)- , testProperty "gatherIf" (test_gatherIf :: Array DIM1 e -> Property)- ]- where- test_reverse :: Vector e -> Property- test_reverse xs = run backend (reverseAcc xs) ~?= reverseRef xs-- test_transpose :: Array DIM2 e -> Property- test_transpose xs = run backend (transposeAcc xs) ~?= transposeRef xs-- -- Reverse a vector- --- reverseAcc xs = A.reverse (use xs)- reverseRef xs = fromList (arrayShape xs) (P.reverse $ toList xs)-- -- Transpose a 2D matrix- --- transposeAcc xs = A.transpose (use xs)- transposeRef xs =- let swap (Z:.x:.y) = Z :. y :. x- in newArray (swap (arrayShape xs)) (\ix -> indexArray xs (swap ix))-- -- Extracting sub-vectors- --- test_init :: Vector e -> Property- test_init xs =- P.not (isEmptyArray xs)- ==> toList (run backend (A.init (A.use xs))) ~?= P.init (toList xs)-- test_tail :: Vector e -> Property- test_tail xs =- P.not (isEmptyArray xs)- ==> toList (run backend (A.tail (A.use xs))) ~?= P.tail (toList xs)-- test_drop :: Vector e -> Property- test_drop xs =- let n = arraySize (arrayShape xs)- in forAll (choose (0, 0 `P.max` (n-1))) $ \i ->- toList (run backend (A.drop (constant i) (use xs))) ~?= P.drop i (toList xs)-- test_take :: Vector e -> Property- test_take xs =- let n = arraySize (arrayShape xs)- in forAll (choose (0, 0 `P.max` (n-1))) $ \i ->- toList (run backend (A.take (constant i) (use xs))) ~?= P.take i (toList xs)-- test_slit :: Vector e -> Property- test_slit xs =- let n = arraySize (arrayShape xs)- in forAll (choose (0, 0 `P.max` (n-1))) $ \i ->- forAll (choose (0, 0 `P.max` (n-1-i))) $ \j ->- toList (run backend (A.slit (constant i) (constant j) (use xs))) ~?= P.take j (P.drop i (toList xs))-- -- Gathering- --- test_gather :: Vector e -> Property- test_gather xs =- let n = arraySize (arrayShape xs)- n' = 0 `P.max` (n-1)- in- forAll arbitrary $ \sh' ->- forAll (arbitraryArrayOf sh' (choose (0,n'))) $ \mapv ->- toList (run backend (A.gather (use mapv) (use xs)))- ~?=- [ xs `indexArray` (Z:.i) | i <- toList mapv ]-- test_gatherIf :: Vector e -> Property- test_gatherIf xs =- let n = arraySize (arrayShape xs)- n' = 0 `P.max` (n-1)- in- forAll arbitrary $ \sh' ->- forAll (arbitraryArrayOf sh' (choose (0,n'))) $ \mapv ->- forAll (arbitraryArray sh') $ \(maskv :: Vector Int) ->- forAll (arbitraryArray sh') $ \defaultv ->- toList (run backend $ A.gatherIf (use mapv) (use maskv) A.even (use defaultv) (use xs))- ~?=- gatherIfRef P.even mapv maskv defaultv xs----- Reference Implementation--- --------------------------gatherIfRef :: (e -> Bool) -> Vector Int -> Vector e -> Vector t -> Vector t -> [t]-gatherIfRef g mapv maskv defaultv inputv- = let n = arraySize (arrayShape defaultv)- select ix- | g (maskv `indexArray` ix) = inputv `indexArray` (Z :. mapv `indexArray` ix)- | otherwise = defaultv `indexArray` ix- in- [ select ix | i <- [0 .. n-1], let ix = Z :. i ]---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-
+ examples/nofib/Test/Prelude/Map.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Test.Prelude.Map (++ test_map++) where++import Prelude as P+import Data.Bits as P+import Data.Label+import Data.Maybe+import Data.Typeable+import System.Random+import Test.QuickCheck hiding ( (.&.), suchThat )+import Test.Framework+import Test.Framework.Providers.QuickCheck2++import Config+import Test.Base+import QuickCheck.Arbitrary.Array+import QuickCheck.Arbitrary.Shape+import Data.Array.Accelerate as A hiding ( Ord(..) )+import Data.Array.Accelerate.Data.Bits as A+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.Array.Sugar as Sugar++--+-- Map -------------------------------------------------------------------------+--++test_map :: Backend -> Config -> Test+test_map backend opt = testGroup "map" $ 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 a. (P.Integral a, P.FiniteBits a, A.Integral a, A.FiniteBits a, Arbitrary a, Similar a, A.FromIntegral a Float) => (Config :-> Bool) -> a -> Maybe Test+ testIntegralElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))+ [ testDim dim0+ , testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary (Array sh a)) => sh -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [ -- operators on Num+ testProperty "neg" (test_negate :: Array sh a -> Property)+ , testProperty "abs" (test_abs :: Array sh a -> Property)+ , testProperty "signum" (test_signum :: Array sh a -> Property)++ -- operators on Integral & Bits+ , testProperty "complement" (test_complement :: Array sh a -> Property)+ , testProperty "popCount" (test_popCount :: Array sh a -> Property)+ , testProperty "countLeadingZeros" (test_countLeadingZeros :: Array sh a -> Property)+ , testProperty "countTrailingZeros" (test_countTrailingZeros :: Array sh a -> Property)++ -- conversions+ , testProperty "fromIntegral" (test_fromIntegral :: Array sh a -> Property)+ ]+ where+ test_fromIntegral xs = run1 backend (A.map A.fromIntegral) xs ~?= mapRef (P.fromIntegral :: a -> Float) xs++ testFloatingElt :: forall a. (P.Floating a, P.RealFloat a, A.Floating a, A.RealFloat a, Random a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testFloatingElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))+ [ testDim dim0+ , testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, P.Eq sh, Random a, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test+ testDim _ = testGroup ("DIM" P.++ show (rank (undefined::sh)))+ [ -- operators on Num+ testProperty "neg" (test_negate :: Array sh a -> Property)+ , testProperty "abs" (test_abs :: Array sh a -> Property)+ , testProperty "signum" (test_signum :: Array sh a -> Property)++ -- operators on Fractional, Floating, RealFrac & RealFloat+ , testProperty "recip" (test_recip :: Array sh a -> Property)+ , testProperty "sin" (test_sin :: Array sh a -> Property)+ , testProperty "cos" (test_cos :: Array sh a -> Property)+ , testProperty "tan" (requiring (\x -> P.not (sin x ~= 1)) (test_tan :: Array sh a -> Property))+ , testProperty "asin" (forAll (sized arbitraryShape) $ \sh ->+ forAll (arbitraryArrayOf sh (choose (-1,1))) $ \(xs :: Array sh a) -> test_asin xs)+ , testProperty "acos" (forAll (sized arbitraryShape) $ \sh ->+ forAll (arbitraryArrayOf sh (choose (-1,1))) $ \(xs :: Array sh a) -> test_acos xs)+ , testProperty "atan" (test_atan :: Array sh a -> Property)+ , testProperty "asinh" (test_asinh :: Array sh a -> Property)+ , testProperty "acosh" (requiring (>= 1) (test_acosh :: Array sh a -> Property))+ , testProperty "atanh" (forAll (sized arbitraryShape) $ \sh ->+ forAll (arbitraryArrayOf sh (choose (-1,1))) $ \(xs :: Array sh a) -> test_atanh xs)+ , testProperty "exp" (test_exp :: Array sh a -> Property)+ , testProperty "sqrt" (requiring (>= 0) (test_sqrt :: Array sh a -> Property))+ , testProperty "log" (requiring (> 0) (test_log :: Array sh a -> Property))+ , testProperty "truncate" (test_truncate :: Array sh a -> Property)+ , testProperty "round" (test_round :: Array sh a -> Property)+ , testProperty "floor" (test_floor :: Array sh a -> Property)+ , testProperty "ceiling" (test_ceiling :: Array sh a -> Property)+ ]+ where+ test_truncate xs = run1 backend (A.map A.truncate) xs ~?= mapRef (P.truncate :: a -> Int) xs+ test_round xs = run1 backend (A.map A.round) xs ~?= mapRef (P.round :: a -> Int) xs+ test_floor xs = run1 backend (A.map A.floor) xs ~?= mapRef (P.floor :: a -> Int) xs+ test_ceiling xs = run1 backend (A.map A.ceiling) xs ~?= mapRef (P.ceiling :: a -> Int) xs++ test_negate xs = run1 backend (A.map negate) xs ~?= mapRef negate xs+ test_abs xs = run1 backend (A.map abs) xs ~?= mapRef abs xs+ test_signum xs = run1 backend (A.map signum) xs ~?= mapRef signum xs++ test_complement xs = run1 backend (A.map A.complement) xs ~?= mapRef P.complement xs+ test_popCount xs = run1 backend (A.map A.popCount) xs ~?= mapRef P.popCount xs+ test_countLeadingZeros xs = run1 backend (A.map A.countLeadingZeros) xs ~?= mapRef countLeadingZerosRef xs+ test_countTrailingZeros xs = run1 backend (A.map A.countTrailingZeros) xs ~?= mapRef countTrailingZerosRef xs++ test_recip xs = run1 backend (A.map recip) xs ~?= mapRef recip xs+ test_sin xs = run1 backend (A.map sin) xs ~?= mapRef sin xs+ test_cos xs = run1 backend (A.map cos) xs ~?= mapRef cos xs+ test_tan xs = run1 backend (A.map tan) xs ~?= mapRef tan xs+ test_asin xs = run1 backend (A.map asin) xs ~?= mapRef asin xs+ test_acos xs = run1 backend (A.map acos) xs ~?= mapRef acos xs+ test_atan xs = run1 backend (A.map atan) xs ~?= mapRef atan xs+ test_asinh xs = run1 backend (A.map asinh) xs ~?= mapRef asinh xs+ test_acosh xs = run1 backend (A.map acosh) xs ~?= mapRef acosh xs+ test_atanh xs = run1 backend (A.map atanh) xs ~?= mapRef atanh xs+ test_exp xs = run1 backend (A.map exp) xs ~?= mapRef exp xs+ test_sqrt xs = run1 backend (A.map sqrt) xs ~?= mapRef sqrt xs+ test_log xs = run1 backend (A.map log) xs ~?= mapRef log xs+++suchThat :: Gen a -> (a -> Bool) -> Gen a+suchThat gen p = do+ x <- gen+ case p x of+ True -> return x+ False -> sized $ \n -> resize (n+1) (suchThat gen p)+++{-# INLINE requiring #-}+requiring+ :: (Elt e, Shape sh, Arbitrary e, Arbitrary sh, Testable prop)+ => (e -> Bool)+ -> (Array sh e -> prop)+ -> Property+requiring f go =+ let+ shrinkRequiring arr = [ fromList (Sugar.shape arr) sl | sl <- shrinkOneRequiring (toList arr) ]+ shrinkOneRequiring [] = []+ shrinkOneRequiring (x:xs) = [ x':xs | x' <- shrink x, f x' ]+ P.++ [ x:xs' | xs' <- shrinkOneRequiring xs ]+ in+ forAllShrink arbitrary shrink $ \sh ->+ forAllShrink (arbitraryArrayOf sh (arbitrary `suchThat` f)) shrinkRequiring $ \arr ->+ go arr+++-- Reference Implementation+-- ------------------------++mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b+mapRef f xs+ = fromList (arrayShape xs)+ $ P.map f+ $ toList xs++countLeadingZerosRef :: P.FiniteBits a => a -> Int+#if __GLASGOW_HASKELL__ >= 710+countLeadingZerosRef = P.countLeadingZeros+#else+countLeadingZerosRef = clz+ where+ clz x = (w-1) - go (w-1)+ where+ go i | i < 0 = i -- no bit set+ | P.testBit x i = i+ | otherwise = go (i-1)+ w = P.finiteBitSize x+#endif++countTrailingZerosRef :: P.FiniteBits a => a -> Int+#if __GLASGOW_HASKELL__ >= 710+countTrailingZerosRef = P.countTrailingZeros+#else+countTrailingZerosRef = ctz+ where+ ctz x = go 0+ where+ go i | i >= w = i+ | P.testBit x i = i+ | otherwise = go (i+1)+ w = P.finiteBitSize x+#endif+
− examples/nofib/Test/Prelude/Mapping.hs
@@ -1,263 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Test.Prelude.Mapping (-- test_map,- test_zipWith,- mapRef,- zipWithRef,--) where--import Prelude as P-import Data.Bits as P-import Data.Label-import Data.Maybe-import Data.Typeable-import Test.QuickCheck hiding ( (.&.) )-import Test.Framework-import Test.Framework.Providers.QuickCheck2--import Config-import Test.Base-import QuickCheck.Arbitrary.Array-import QuickCheck.Arbitrary.Shape-import Data.Array.Accelerate as A-import Data.Array.Accelerate.Examples.Internal as A-import Data.Array.Accelerate.Array.Sugar as Sugar-import qualified Data.Array.Accelerate.Array.Representation as R------- Map ------------------------------------------------------------------------------test_map :: Backend -> Config -> Test-test_map backend opt = testGroup "map" $ 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 a. (Elt a, Integral a, Bits a, IsNum a, IsIntegral a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test- testIntegralElt ok a- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))- [ testDim dim0- , testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [ -- operators on Num- testProperty "neg" (test negate negate)- , testProperty "abs" (test abs abs)- , testProperty "sig" (test signum signum)-- -- operators on Integral & Bits- , testProperty "complement" (test complement complement)-- -- conversions- , testProperty "fromIntegral" (testF A.fromIntegral P.fromIntegral)- ]- where- test = mkTest a a sh- testF = mkTest a (undefined::Float) sh-- testFloatingElt :: forall a. (Elt a, RealFrac a, IsFloating a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test- testFloatingElt ok a- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))- [ testDim dim0- , testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [ -- operators on Num- testProperty "neg" (test negate negate)- , testProperty "abs" (test abs abs)- , testProperty "sig" (test signum signum)-- -- operators on Fractional, Floating, RealFrac & RealFloat- , testProperty "recip" (test recip recip)- , testProperty "sin" (test sin sin)- , testProperty "cos" (test cos cos)- , testProperty "tan" (requiring (\x -> P.not (sin x ~= 1)) $ test tan tan)- , testProperty "asin" (requiring (\x -> -1 <= x && x <= 1) $ test asin asin)- , testProperty "acos" (requiring (\x -> -1 <= x && x <= 1) $ test acos acos)- , testProperty "atan" (test atan atan)- , testProperty "asinh" (test asinh asinh)- , testProperty "acosh" (requiring (>= 1) $ test acosh acosh)- , testProperty "atanh" (requiring (\x -> -1 < x && x < 1) $ test atanh atanh)- , testProperty "exp" (test exp exp)- , testProperty "sqrt" (requiring (>= 0) $ test sqrt sqrt)- , testProperty "log" (requiring (> 0) $ test log log)- , testProperty "truncate" (testI A.truncate P.truncate)- , testProperty "round" (testI A.round P.round)- , testProperty "floor" (testI A.floor P.floor)- , testProperty "ceiling" (testI A.ceiling P.ceiling)- ]- where- test = mkTest a a sh- testI = mkTest a (undefined::Int) sh-- -- The test generator. The first three arguments are dummies that are used- -- to fix the types. The next two are the Accelerate and Prelude functions- -- respectively that are arguments to the Map operation, and the final is- -- the (randomly generated) input data.- --- mkTest :: (Elt a, Elt b, Shape sh, Eq sh, Similar b)- => a -> b -> sh -> (Exp a -> Exp b) -> (a -> b) -> Array sh a -> Property- mkTest _ _ _ f g xs = run1 backend (A.map f) xs ~?= mapRef g xs---test_zipWith :: Backend -> Config -> Test-test_zipWith backend opt = testGroup "zipWith" $ 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 a. (Elt a, Integral a, Bits a, IsNum a, IsIntegral a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test- testIntegralElt ok a- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))- [ testDim dim0- , testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a), Arbitrary (Array sh Int)) => sh -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [ -- operators on Num- testProperty "(+)" (test (+) (+))- , testProperty "(-)" (test (-) (-))- , testProperty "(*)" (test (*) (*))-- -- operators on Integral & Bits- , testProperty "quot" (denom $ test quot quot)- , testProperty "rem" (denom $ test rem rem)- , testProperty "quotRem" (denom $ test' (\x y -> lift (quotRem x y)) quotRem)- , testProperty "div" (denom $ test div div)- , testProperty "mod" (denom $ test mod mod)- , testProperty "divMod" (denom $ test' (\x y -> lift (divMod x y)) divMod)- , testProperty "(.&.)" (test (.&.) (.&.))- , testProperty "(.|.)" (test (.|.) (.|.))- , testProperty "xor" (test xor xor)- , testProperty "shiftL" (testSR A.shiftL P.shiftL)- , testProperty "shiftR" (testSR A.shiftR P.shiftR)- , testProperty "rotateL" (testSR A.rotateL P.rotateL)- , testProperty "rotateR" (testSR A.rotateR P.rotateR)-- -- relational and equality operators- , testProperty "(<)" (testAB (A.<*) (<))- , testProperty "(>)" (testAB (A.>*) (>))- , testProperty "(<=)" (testAB (<=*) (<=))- , testProperty "(>=)" (testAB (>=*) (>=))- , testProperty "(==)" (testAB (==*) (==))- , testProperty "(/=)" (testAB (/=*) (/=))- , testProperty "min" (test min min)- , testProperty "max" (test max max)- ]- where- test = mkTest a a a sh- test' = mkTest a a (undefined::(a,a)) sh- testAB = mkTest a a (undefined::Bool) sh-- testSR f g = forAll arbitrary $ \xs ->- requiring (>= 0) $ \ys ->- mkTest a (undefined::Int) a sh f g xs ys-- testFloatingElt :: forall a. (Elt a, RealFrac a, RealFloat a, IsFloating a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test- testFloatingElt ok a- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))- [ testDim dim0- , testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [ -- operators on Num- testProperty "(+)" (test (+) (+))- , testProperty "(-)" (test (-) (-))- , testProperty "(*)" (test (*) (*))-- -- operators on Fractional, Floating, RealFrac & RealFloat- , testProperty "(/)" (denom $ test (/) (/))- , testProperty "(**)" (test (**) (**))- , testProperty "atan2" (test atan2 atan2)- , testProperty "logBase" (requiring (> 0) $ \xs ->- requiring (> 0) $ \ys -> test logBase logBase xs ys)-- -- relational and equality operators- , testProperty "(<)" (testAB (A.<*) (<))- , testProperty "(>)" (testAB (A.>*) (>))- , testProperty "(<=)" (testAB (<=*) (<=))- , testProperty "(>=)" (testAB (>=*) (>=))- , testProperty "(==)" (testAB (==*) (==))- , testProperty "(/=)" (testAB (/=*) (/=))- , testProperty "min" (test min min)- , testProperty "max" (test max max)- ]- where- test = mkTest a a a sh- testAB = mkTest a a (undefined::Bool) sh-- -- The test generator. See comments in test_map above.- --- mkTest :: (Elt a, Elt b, Elt c, Shape sh, Eq sh, Similar c)- => a -> b -> c -> sh -> (Exp a -> Exp b -> Exp c) -> (a -> b -> c) -> Array sh a -> Array sh b -> Property- mkTest _ _ _ _ f g xs ys = run2 backend (A.zipWith f) xs ys ~?= zipWithRef g xs ys-- denom f = forAll arbitrary $ \xs ->- requiring (/= 0) $ \ys -> f xs ys---requiring- :: (Elt e, Shape sh, Arbitrary e, Arbitrary sh, Testable prop)- => (e -> Bool)- -> (Array sh e -> prop)- -> Property-requiring f go =- forAll (do sh <- sized arbitraryShape- arbitraryArrayOf sh (arbitrary `suchThat` f)) go----- Reference Implementation--- --------------------------mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b-mapRef f xs- = fromList (arrayShape xs)- $ P.map f- $ toList xs--zipWithRef :: (Shape sh, Elt c) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c-zipWithRef f xs ys =- let shx = fromElt (arrayShape xs)- shy = fromElt (arrayShape ys)- sh = toElt (R.intersect shx shy)- in- newArray sh (\ix -> f (xs Sugar.! ix) (ys Sugar.! ix))-
+ examples/nofib/Test/Prelude/Permute.hs view
@@ -0,0 +1,171 @@+{-# 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+
− examples/nofib/Test/Prelude/PrefixSum.hs
@@ -1,215 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Test.Prelude.PrefixSum (-- test_prefixsum,--) where--import Prelude as P-import Test.QuickCheck-import Data.Label-import Data.Maybe-import Data.Typeable-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.Examples.Internal as A-------- prefix sum -----------------------------------------------------------------------test_prefixsum :: Backend -> Config -> Test-test_prefixsum backend opt = testGroup "prefix sum" $ catMaybes- [ testElt configInt8 (undefined :: Int8)- , testElt configInt16 (undefined :: Int16)- , testElt configInt32 (undefined :: Int32)- , testElt configInt64 (undefined :: Int64)- , testElt configWord8 (undefined :: Word8)- , testElt configWord16 (undefined :: Word16)- , testElt configWord32 (undefined :: Word32)- , testElt configWord64 (undefined :: Word64)- , testElt configFloat (undefined :: Float)- , testElt configDouble (undefined :: Double)- ]- where- testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test- testElt ok _- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))- [ testProperty "scanl" (test_scanl :: Vector e -> Property)- , testProperty "scanl'" (test_scanl' :: Vector e -> Property)- , testProperty "scanl1" (test_scanl1 :: Vector e -> Property)- , testProperty "scanr" (test_scanr :: Vector e -> Property)- , testProperty "scanr'" (test_scanr' :: Vector e -> Property)- , testProperty "scanr1" (test_scanr1 :: Vector e -> Property)- --- , testProperty "scanl1Seg" (test_scanl1seg :: Vector e -> Property)- , testProperty "scanr1Seg" (test_scanr1seg :: Vector e -> Property)- , testProperty "scanlSeg" (test_scanlseg :: Vector e -> Property)- , testProperty "scanrSeg" (test_scanrseg :: Vector e -> Property)- , testProperty "scanl'Seg" (test_scanl'seg :: Vector e -> Property)- , testProperty "scanr'Seg" (test_scanr'seg :: Vector e -> Property)- ]-- -- left scan- --- test_scanl xs = run backend (A.scanl (+) 0 (use xs)) ~?= scanlRef (+) 0 xs- test_scanl' xs = run backend (A.lift $ A.scanl' (+) 0 (use xs)) ~?= scanl'Ref (+) 0 xs- test_scanl1 xs =- arraySize (arrayShape xs) > 0 ==>- run backend (A.scanl1 min (use xs)) ~?= scanl1Ref min xs-- -- right scan- --- test_scanr xs = run backend (A.scanr (+) 0 (use xs)) ~?= scanrRef (+) 0 xs- test_scanr' xs = run backend (A.lift $ A.scanr' (+) 0 (use xs)) ~?= scanr'Ref (+) 0 xs- test_scanr1 xs =- arraySize (arrayShape xs) > 0 ==>- run backend (A.scanr1 max (use xs)) ~?= scanr1Ref max xs-- -- segmented left/right scan- --- test_scanl1seg elt =- forAll arbitrarySegments1 $ \(seg :: Vector Int32) ->- forAll (arbitrarySegmentedArray seg) $ \xs ->- arraySize (arrayShape xs) > 0 ==>- run backend (A.scanl1Seg (+) (use xs) (use seg))- ~?=- scanl1SegRef (+) (xs `asTypeOf` elt) seg-- test_scanr1seg elt =- forAll arbitrarySegments1 $ \(seg :: Vector Int32) ->- forAll (arbitrarySegmentedArray seg) $ \xs ->- arraySize (arrayShape xs) > 0 ==>- run backend (A.scanr1Seg (+) (use xs) (use seg))- ~?=- scanr1SegRef (+) (xs `asTypeOf` elt) seg-- test_scanlseg elt =- forAll arbitrarySegments $ \(seg :: Vector Int32) ->- forAll (arbitrarySegmentedArray seg) $ \xs ->- run backend (A.scanlSeg (+) 0 (use xs) (use seg))- ~?=- scanlSegRef (+) 0 (xs `asTypeOf` elt) seg-- test_scanrseg elt =- forAll arbitrarySegments $ \(seg :: Vector Int32) ->- forAll (arbitrarySegmentedArray seg) $ \xs ->- run backend (A.scanrSeg (+) 0 (use xs) (use seg))- ~?=- scanrSegRef (+) 0 (xs `asTypeOf` elt) seg-- test_scanl'seg elt =- forAll arbitrarySegments $ \(seg :: Vector Int32) ->- forAll (arbitrarySegmentedArray seg) $ \xs ->- run backend (lift $ A.scanl'Seg (+) 0 (use xs) (use seg))- ~?=- scanl'SegRef (+) 0 (xs `asTypeOf` elt) seg-- test_scanr'seg elt =- forAll arbitrarySegments $ \(seg :: Vector Int32) ->- forAll (arbitrarySegmentedArray seg) $ \xs ->- run backend (lift $ A.scanr'Seg (+) 0 (use xs) (use seg))- ~?=- scanr'SegRef (+) 0 (xs `asTypeOf` elt) seg----- Reference implementation--- --------------------------scanlRef :: Elt e => (e -> e -> e) -> e -> Vector e -> Vector e-scanlRef f z vec =- let (Z :. n) = arrayShape vec- in A.fromList (Z :. n+1) . P.scanl f z . A.toList $ vec--scanl'Ref :: Elt e => (e -> e -> e) -> e -> Vector e -> (Vector e, Scalar e)-scanl'Ref f z vec =- let (Z :. n) = arrayShape vec- result = P.scanl f z (A.toList vec)- in (A.fromList (Z :. n) result, A.fromList Z (P.drop n result))--scanl1Ref :: Elt e => (e -> e -> e) -> Vector e -> Vector e-scanl1Ref f vec- = A.fromList (arrayShape vec)- . P.scanl1 f- . A.toList $ vec--scanrRef :: Elt e => (e -> e -> e) -> e -> Vector e -> Vector e-scanrRef f z vec =- let (Z :. n) = arrayShape vec- in A.fromList (Z :. n+1) . P.scanr f z . A.toList $ vec--scanr'Ref :: Elt e => (e -> e -> e) -> e -> Vector e -> (Vector e, Scalar e)-scanr'Ref f z vec =- let (Z :. n) = arrayShape vec- result = P.scanr f z (A.toList vec)- in (A.fromList (Z :. n) (P.tail result), A.fromList Z result)--scanr1Ref :: Elt e => (e -> e -> e) -> Vector e -> Vector e-scanr1Ref f vec- = A.fromList (arrayShape vec)- . P.scanr1 f- . A.toList $ vec----- segmented operations----scanlSegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> Vector e-scanlSegRef f z vec seg =- let seg' = toList seg- vec' = toList vec- n = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg'- in fromList (Z :. n) $- concat [ P.scanl f z v | v <- splitPlaces seg' vec' ]--scanl1SegRef :: (Elt e, Integral i) => (e -> e -> e) -> Vector e -> Vector i -> Vector e-scanl1SegRef f vec seg =- let seg' = toList seg- vec' = toList vec- n = P.sum $ P.map P.fromIntegral seg'- in fromList (Z :. n) $- concat [ P.scanl1 f v | v <- splitPlaces seg' vec' ]--scanl'SegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> (Vector e, Vector e)-scanl'SegRef f z vec seg =- let seg' = toList seg- vec' = toList vec- scanl'_ v = let res = P.scanl f z v in (P.init res, P.last res)- (scans, sums) = P.unzip [ scanl'_ v | v <- splitPlaces seg' vec']- in ( fromList (arrayShape vec) (concat scans)- , fromList (arrayShape seg) sums )--scanrSegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> Vector e-scanrSegRef f z vec seg =- let seg' = toList seg- vec' = toList vec- n = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg'- in fromList (Z :. n) $- concat [ P.scanr f z v | v <- splitPlaces seg' vec' ]--scanr1SegRef :: (Elt e, Integral i) => (e -> e -> e) -> Vector e -> Vector i -> Vector e-scanr1SegRef f vec seg =- let seg' = toList seg- vec' = toList vec- n = P.sum $ P.map P.fromIntegral seg'- in fromList (Z :. n) $- concat [ P.scanr1 f v | v <- splitPlaces seg' vec' ]--scanr'SegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> (Vector e, Vector e)-scanr'SegRef f z vec seg =- let seg' = toList seg- vec' = toList vec- scanr'_ v = let res = P.scanr f z v in (P.tail res, P.head res)- (scans, sums) = P.unzip [ scanr'_ v | v <- splitPlaces seg' vec']- in ( fromList (arrayShape vec) (concat scans)- , fromList (arrayShape seg) sums )-
− examples/nofib/Test/Prelude/Reduction.hs
@@ -1,227 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Test.Prelude.Reduction (-- test_fold,- test_foldAll,- test_foldSeg,--) where--import Prelude as P-import Data.List-import Data.Label-import Data.Maybe-import Data.Typeable-import Test.QuickCheck-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Data.Array.Accelerate as A hiding (indexHead, indexTail)-import Data.Array.Accelerate.Array.Sugar as Sugar-import Data.Array.Accelerate.Examples.Internal as A--import Config-import Test.Base-import QuickCheck.Arbitrary.Array--------- Reduction -------------------------------------------------------------------------- foldAll--- ---------test_foldAll :: Backend -> Config -> Test-test_foldAll backend opt = testGroup "foldAll" $ catMaybes- [ testElt configInt8 (undefined :: Int8)- , testElt configInt16 (undefined :: Int16)- , testElt configInt32 (undefined :: Int32)- , testElt configInt64 (undefined :: Int64)- , testElt configWord8 (undefined :: Word8)- , testElt configWord16 (undefined :: Word16)- , testElt configWord32 (undefined :: Word32)- , testElt configWord64 (undefined :: Word64)- , testElt configFloat (undefined :: Float)- , testElt configDouble (undefined :: Double)- ]- where- testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test- testElt ok _- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))- [ testDim dim0- , testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Arbitrary sh, Arbitrary (Array sh e)) => sh -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [- testProperty "sum" (test_sum :: Array sh e -> Property)- , testProperty "non-neutral sum" (test_sum' :: Array sh e -> e -> Property)- , testProperty "minimum" (test_min :: Array sh e -> Property)- , testProperty "maximum" (test_max :: Array sh e -> Property)- ]- --- -- The tests- --- test_min xs- = arraySize (arrayShape xs) > 0- ==> run backend (A.fold1All min (use xs)) ~?= fold1AllRef min xs-- test_max xs- = arraySize (arrayShape xs) > 0- ==> run backend (A.fold1All max (use xs)) ~?= fold1AllRef max xs-- test_sum xs = run backend (A.foldAll (+) 0 (use xs)) ~?= foldAllRef (+) 0 xs- test_sum' xs z =- let z' = unit (constant z)- in run backend (A.foldAll (+) (the z') (use xs)) ~?= foldAllRef (+) z xs------ multidimensional fold--- -----------------------test_fold :: Backend -> Config -> Test-test_fold backend opt = testGroup "fold" $ catMaybes- [ testElt configInt8 (undefined :: Int8)- , testElt configInt16 (undefined :: Int16)- , testElt configInt32 (undefined :: Int32)- , testElt configInt64 (undefined :: Int64)- , testElt configWord8 (undefined :: Word8)- , testElt configWord16 (undefined :: Word16)- , testElt configWord32 (undefined :: Word32)- , testElt configWord64 (undefined :: Word64)- , testElt configFloat (undefined :: Float)- , testElt configDouble (undefined :: Double)- ]- where- testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test- testElt ok _- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))- [ testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [- testProperty "sum" (test_sum :: Array (sh :. Int) e -> Property)- , testProperty "non-neutral sum" (test_sum' :: Array (sh :. Int) e -> e -> Property)- , testProperty "minimum" (test_min :: Array (sh :. Int) e -> Property)- , testProperty "maximum" (test_max :: Array (sh :. Int) e -> Property)- ]- --- -- The tests- --- test_min xs- = indexHead (arrayShape xs) > 0- ==> run backend (A.fold1 min (use xs)) ~?= fold1Ref min xs-- test_max xs- = indexHead (arrayShape xs) > 0- ==> run backend (A.fold1 max (use xs)) ~?= fold1Ref max xs-- test_sum xs = run backend (A.fold (+) 0 (use xs)) ~?= foldRef (+) 0 xs- test_sum' xs z =- let z' = unit (constant z)- in run backend (A.fold (+) (the z') (use xs)) ~?= foldRef (+) z xs----- segmented fold--- ----------------test_foldSeg :: Backend -> Config -> Test-test_foldSeg backend opt = testGroup "foldSeg" $ catMaybes- [ testElt configInt8 (undefined :: Int8)- , testElt configInt16 (undefined :: Int16)- , testElt configInt32 (undefined :: Int32)- , testElt configInt64 (undefined :: Int64)- , testElt configWord8 (undefined :: Word8)- , testElt configWord16 (undefined :: Word16)- , testElt configWord32 (undefined :: Word32)- , testElt configWord64 (undefined :: Word64)- , testElt configFloat (undefined :: Float)- , testElt configDouble (undefined :: Double)- ]- where- testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test- testElt ok _- | P.not (get ok opt) = Nothing- | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))- [ testDim dim1- , testDim dim2- ]- where- testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test- testDim sh = testGroup ("DIM" P.++ show (dim sh))- [- testProperty "sum"- $ forAll arbitrarySegments $ \(seg :: Segments Int32) ->- forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) ->- run backend (A.foldSeg (+) 0 (use xs) (use seg)) ~?= foldSegRef (+) 0 xs seg-- , testProperty "non-neutral sum"- $ forAll arbitrarySegments $ \(seg :: Segments Int32) ->- forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) ->- forAll arbitrary $ \z ->- let z' = unit (constant z)- in run backend (A.foldSeg (+) (the z') (use xs) (use seg)) ~?= foldSegRef (+) z xs seg-- , testProperty "minimum"- $ forAll arbitrarySegments1 $ \(seg :: Segments Int32) ->- forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) ->- run backend (A.fold1Seg min (use xs) (use seg)) ~?= fold1SegRef min xs seg- ]----- Reference implementation--- --------------------------foldAllRef :: Elt e => (e -> e -> e) -> e -> Array sh e -> Array Z e-foldAllRef f z- = A.fromList Z- . return- . foldl f z- . A.toList--fold1AllRef :: Elt e => (e -> e -> e) -> Array sh e -> Array Z e-fold1AllRef f- = A.fromList Z- . return- . foldl1 f- . A.toList--foldRef :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Array sh e-foldRef f z arr =- let (sh :. n) = arrayShape arr- sh' = listToShape . P.map (max 1) . shapeToList $ sh- in fromList sh' [ foldl f z sub | sub <- splitEvery n (toList arr) ]--fold1Ref :: (Shape sh, Elt e) => (e -> e -> e) -> Array (sh :. Int) e -> Array sh e-fold1Ref f arr =- let (sh :. n) = arrayShape arr- in fromList sh [ foldl1 f sub | sub <- splitEvery n (toList arr) ]--foldSegRef :: (Shape sh, Elt e, Elt i, Integral i) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e-foldSegRef f z arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ]- where- (sh :. n) = arrayShape arr- (Z :. sz) = arrayShape seg- seg' = toList seg- foldseg xs = P.map (foldl' f z) (splitPlaces seg' xs)--fold1SegRef :: (Shape sh, Elt e, Elt i, Integral i) => (e -> e -> e) -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e-fold1SegRef f arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ]- where- (sh :. n) = arrayShape arr- (Z :. sz) = arrayShape seg- seg' = toList seg- foldseg xs = P.map (foldl1' f) (splitPlaces seg' xs)-
examples/nofib/Test/Prelude/Replicate.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -13,6 +14,7 @@ import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.IO as A import Data.Array.Accelerate.Examples.Internal as A import Data.Array.Unboxed as IArray hiding ( Array ) import Data.Label@@ -39,7 +41,7 @@ , testElt configDouble (undefined :: Double) ] where- testElt :: forall e. (Elt e, IsNum e, Num e, Eq e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test+ testElt :: forall e. (P.Num e, A.Num e, P.Eq e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test testElt ok _ | P.not (get ok opt) = Nothing | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))
+ examples/nofib/Test/Prelude/Scan.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Test.Prelude.Scan (++ test_scan,++) where++import Prelude as P+import Test.QuickCheck+import Data.Label+import Data.Maybe+import Data.Typeable+import Test.Framework+import Test.Framework.Providers.QuickCheck2++import Config+import Test.Base+import QuickCheck.Arbitrary.Array+import QuickCheck.Arbitrary.Shape ()+import Data.Array.Accelerate as A hiding ( Ord(..) )+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.Array.Sugar as Sugar+import qualified Data.Array.Accelerate as A+++--+-- scan ------------------------------------------------------------------------+--++test_scan :: Backend -> Config -> Test+test_scan backend opt = testGroup "scan" $ catMaybes+ [ testElt configInt8 (undefined :: Int8)+ , testElt configInt16 (undefined :: Int16)+ , testElt configInt32 (undefined :: Int32)+ , testElt configInt64 (undefined :: Int64)+ , testElt configWord8 (undefined :: Word8)+ , testElt configWord16 (undefined :: Word16)+ , testElt configWord32 (undefined :: Word32)+ , testElt configWord64 (undefined :: Word64)+ , testElt configFloat (undefined :: Float)+ , testElt configDouble (undefined :: Double)+ ]+ where+ testElt :: forall e. (P.Num e, P.Ord e, A.Num e, A.Ord e, P.Enum e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test+ testElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))+ [ testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, Slice sh, P.Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => sh:.Int -> Test+ testDim _sh = testGroup ("DIM" P.++ show (rank _sh))+ [ testGroup "scanl"+ [ testProperty "sum" (test_scanl :: Array (sh:.Int) e -> Property)+ , testProperty "interval" (intv_scanl :: sh -> NonNegative Int -> Property)+ ]+ , testGroup "scanl'"+ [ testProperty "sum" (test_scanl' :: Array (sh:.Int) e -> Property)+ , testProperty "interval" (intv_scanl' :: sh -> NonNegative Int -> Property)+ ]+ , testGroup "scanl1"+ [ testProperty "sum" (test_scanl1 :: Array (sh:.Int) e -> Property)+ , testProperty "interval" (intv_scanl1 :: sh -> Positive Int -> Property)+ ]+ , testGroup "scanr"+ [ testProperty "sum" (test_scanr :: Array (sh:.Int) e -> Property)+ , testProperty "interval" (intv_scanr :: sh -> NonNegative Int -> Property)+ ]+ , testGroup "scanr'"+ [ testProperty "sum" (test_scanr' :: Array (sh:.Int) e -> Property)+ , testProperty "interval" (intv_scanr' :: sh -> NonNegative Int -> Property)+ ]+ , testGroup "scanr1"+ [ testProperty "sum" (test_scanr1 :: Array (sh:.Int) e -> Property)+ , testProperty "interval" (intv_scanr1 :: sh -> Positive Int -> Property)+ ]+ --+ , testProperty "scanl1Seg" (test_scanl1seg (undefined::Array (sh:.Int) e))+ , testProperty "scanr1Seg" (test_scanr1seg (undefined::Array (sh:.Int) e))+ , testProperty "scanlSeg" (test_scanlseg (undefined::Array (sh:.Int) e))+ , testProperty "scanrSeg" (test_scanrseg (undefined::Array (sh:.Int) e))+ , testProperty "scanl'Seg" (test_scanl'seg (undefined::Array (sh:.Int) e))+ , testProperty "scanr'Seg" (test_scanr'seg (undefined::Array (sh:.Int) e))+ ]+ where+ -- left scan+ --+ test_scanl xs = (run1 backend (A.scanl (+) 0)) xs ~?= scanlRef (+) 0 xs+ test_scanl' xs = (run1 backend (A.lift . A.scanl' (+) 0)) xs ~?= scanl'Ref (+) 0 xs+ test_scanl1 xs =+ arraySize (arrayShape xs) > 0 ==>+ (run1 backend (A.scanl1 A.min)) xs ~?= scanl1Ref P.min xs++ intv_scanl sh (NonNegative sz) =+ let xs = intervalArray sh sz+ in (run1 backend (A.scanl iappend' (constant one))) xs ~?= scanlRef iappend one xs++ intv_scanl' sh (NonNegative sz) =+ let xs = intervalArray sh sz+ in (run1 backend (A.lift . A.scanl' iappend' (constant one))) xs ~?= scanl'Ref iappend one xs++ intv_scanl1 sh (Positive sz) =+ arraySize sh > 0 ==>+ let xs = intervalArray sh sz+ in (run1 backend (A.scanl1 iappend')) xs ~?= scanl1Ref iappend xs++ -- right scan+ --+ test_scanr xs = run1 backend (A.scanr (+) 0) xs ~?= scanrRef (+) 0 xs+ test_scanr' xs = run1 backend (A.lift . A.scanr' (+) 0) xs ~?= scanr'Ref (+) 0 xs+ test_scanr1 xs =+ arraySize (arrayShape xs) > 0 ==>+ (run1 backend (A.scanr1 A.max)) xs ~?= scanr1Ref P.max xs++ intv_scanr sh (NonNegative sz) =+ let xs = intervalArray sh sz+ in (run1 backend (A.scanr iappend' (constant one))) xs ~?= scanrRef iappend one xs++ intv_scanr' sh (NonNegative sz) =+ let xs = intervalArray sh sz+ in (run1 backend (A.lift . A.scanr' iappend' (constant one))) xs ~?= scanr'Ref iappend one xs++ intv_scanr1 sh (Positive sz) =+ arraySize sh > 0 ==>+ let xs = intervalArray sh sz+ in (run1 backend (A.scanr1 iappend')) xs ~?= scanr1Ref iappend xs++ -- segmented left/right scan+ --+ test_scanl1seg elt =+ forAllShrink arbitrarySegments1 shrinkSegments1 $ \(seg :: Vector Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \xs ->+ arraySize (arrayShape xs) > 0 ==>+ (run2 backend (A.scanl1Seg (+))) xs seg+ ~?=+ scanl1SegRef (+) (xs `asTypeOf` elt) seg++ test_scanr1seg elt =+ forAllShrink arbitrarySegments1 shrinkSegments1 $ \(seg :: Vector Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \xs ->+ arraySize (arrayShape xs) > 0 ==>+ (run2 backend (A.scanr1Seg (+))) xs seg+ ~?=+ scanr1SegRef (+) (xs `asTypeOf` elt) seg++ test_scanlseg elt =+ forAllShrink arbitrarySegments shrinkSegments $ \(seg :: Vector Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \xs ->+ (run2 backend (A.scanlSeg (+) 0)) xs seg+ ~?=+ scanlSegRef (+) 0 (xs `asTypeOf` elt) seg++ test_scanrseg elt =+ forAllShrink arbitrarySegments shrinkSegments $ \(seg :: Vector Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \xs ->+ (run2 backend (A.scanrSeg (+) 0)) xs seg+ ~?=+ scanrSegRef (+) 0 (xs `asTypeOf` elt) seg++ test_scanl'seg elt =+ forAllShrink arbitrarySegments shrinkSegments $ \(seg :: Vector Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \xs ->+ (run2 backend (lift $$ A.scanl'Seg (+) 0)) xs seg+ ~?=+ scanl'SegRef (+) 0 (xs `asTypeOf` elt) seg++ test_scanr'seg elt =+ forAllShrink arbitrarySegments shrinkSegments $ \(seg :: Vector Int32) ->+ forAllShrink (arbitrarySegmentedArray seg) shrinkSegmentedArray $ \xs ->+ (run2 backend (lift $$ A.scanr'Seg (+) 0)) xs seg+ ~?=+ scanr'SegRef (+) 0 (xs `asTypeOf` elt) seg++ -- interval of summations monoid+ --+ one,top :: (e,e)+ one = (-1,-1)+ top = (-2,-2)++ iappend :: (e,e) -> (e,e) -> (e,e)+ iappend x y+ | x P.== one = y+ | y P.== one = x+ | x P.== top P.|| y P.== top = top+ iappend (x1,x2) (y1,y2)+ | x2 + 1 P.== y1 = (x1,y2)+ | otherwise = top++ iappend' :: Exp (e,e) -> Exp (e,e) -> Exp (e,e)+ iappend' x y+ = x A.== constant one ? ( y+ , y A.== constant one ? ( x+ , x A.== constant top ? ( constant top -- A.|| y A.== constant top; see AccelerateHS/accelerate#364+ , let+ (x1,x2) = unlift x :: (Exp e, Exp e)+ (y1,y2) = unlift y :: (Exp e, Exp e)+ in+ x2 + 1 A.== y1 ? ( lift (x1,y2) , constant top )+ )))++ intervalArray :: sh -> Int -> Array (sh:.Int) (e,e)+ intervalArray sh n = fromList (sh:.n)+ . concat+ $ P.replicate (Sugar.size sh) [ (i,i) | i <- [0.. (P.fromIntegral n-1)] ]+++-- Reference implementation+-- ------------------------++scanlRef :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh:.Int) e -> Array (sh:.Int) e+scanlRef f z arr =+ let sz :. n = arrayShape arr+ arr' = [ P.scanl f z sub | sub <- splitEvery n (toList arr) ]+ in+ A.fromList (sz :. n+1) (concat arr')++scanl'Ref :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh:.Int) e -> (Array (sh:.Int) e, Array sh e)+scanl'Ref f z arr =+ let sz :. n = arrayShape arr+ (arr',sums) = P.unzip [ P.splitAt n (P.scanl f z sub) | sub <- splitEvery n (toList arr) ]+ in+ ( A.fromList (sz:.n) (concat arr'), A.fromList sz (concat sums) )++scanl1Ref :: (Shape sh, Elt e) => (e -> e -> e) -> Array (sh:.Int) e -> Array (sh:.Int) e+scanl1Ref f arr =+ let sz :. n = arrayShape arr+ arr' = [ P.scanl1 f sub | sub <- splitEvery n (toList arr) ]+ in+ A.fromList (sz:.n) (concat arr')++scanrRef :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh:.Int) e -> Array (sh:.Int) e+scanrRef f z arr =+ let sz :. n = arrayShape arr+ arr' = [ P.scanr f z sub | sub <- splitEvery n (toList arr) ]+ in+ A.fromList (sz :. n+1) (concat arr')++scanr'Ref :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh:.Int) e -> (Array (sh:.Int) e, Array sh e)+scanr'Ref f z arr =+ let sz :. n = arrayShape arr+ (sums,arr') = P.unzip [ P.splitAt 1 (P.scanr f z sub) | sub <- splitEvery n (toList arr) ]+ in+ ( A.fromList (sz:.n) (concat arr'), A.fromList sz (concat sums) )++scanr1Ref :: (Shape sh, Elt e) => (e -> e -> e) -> Array (sh:.Int) e -> Array (sh:.Int) e+scanr1Ref f arr =+ let sz :. n = arrayShape arr+ arr' = [ P.scanr1 f sub | sub <- splitEvery n (toList arr) ]+ in+ A.fromList (sz:.n) (concat arr')+++-- segmented operations+--+scanlSegRef+ :: (Shape sh, Elt e, P.Integral i)+ => (e -> e -> e)+ -> e+ -> Array (sh:.Int) e+ -> Segments i+ -> Array (sh:.Int) e+scanlSegRef f z arr seg =+ let+ sz :. n = arrayShape arr+ seg' = toList seg+ n' = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg'+ arr' = [ P.scanl f z sec | sub <- splitEvery n (toList arr)+ , sec <- splitPlaces seg' sub ]+ in+ A.fromList (sz:.n') (concat arr')++scanl1SegRef+ :: (Shape sh, Elt e, P.Integral i)+ => (e -> e -> e)+ -> Array (sh:.Int) e+ -> Segments i+ -> Array (sh:.Int) e+scanl1SegRef f arr seg =+ let+ sz :. n = arrayShape arr+ seg' = toList seg+ n' = P.fromIntegral (P.sum seg')+ arr' = [ P.scanl1 f sec | sub <- splitEvery n (toList arr)+ , sec <- splitPlaces seg' sub ]+ in+ A.fromList (sz:.n') (concat arr')++scanl'SegRef+ :: (Shape sh, Elt e, P.Integral i)+ => (e -> e -> e)+ -> e+ -> Array (sh:.Int) e+ -> Segments i+ -> (Array (sh:.Int) e, Array (sh:.Int) e)+scanl'SegRef f z arr seg =+ let+ sz :. n = arrayShape arr+ Z :. s = arrayShape seg+ scanl'_ v = P.splitAt (P.length v) (P.scanl f z v)+ (arr',sums) = P.unzip [ scanl'_ sec | sub <- splitEvery n (toList arr)+ , sec <- splitPlaces (toList seg) sub ]+ in+ ( A.fromList (sz:.n) (concat arr'), A.fromList (sz:.s) (concat sums) )++scanrSegRef+ :: (Shape sh, Elt e, P.Integral i)+ => (e -> e -> e)+ -> e+ -> Array (sh:.Int) e+ -> Segments i+ -> Array (sh:.Int) e+scanrSegRef f z arr seg =+ let+ sz :. n = arrayShape arr+ seg' = toList seg+ n' = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg'+ arr' = [ P.scanr f z sec | sub <- splitEvery n (toList arr)+ , sec <- splitPlaces seg' sub ]+ in+ A.fromList (sz:.n') (concat arr')++scanr1SegRef+ :: (Shape sh, Elt e, P.Integral i)+ => (e -> e -> e)+ -> Array (sh:.Int) e+ -> Segments i+ -> Array (sh:.Int) e+scanr1SegRef f arr seg =+ let sz :. n = arrayShape arr+ seg' = toList seg+ n' = P.fromIntegral (P.sum seg')+ arr' = [ P.scanr1 f sec | sub <- splitEvery n (toList arr)+ , sec <- splitPlaces seg' sub ]+ in+ A.fromList (sz:.n') (concat arr')++scanr'SegRef+ :: (Shape sh, Elt e, P.Integral i)+ => (e -> e -> e)+ -> e+ -> Array (sh:.Int) e+ -> Segments i+ -> (Array (sh:.Int) e, Array (sh:.Int) e)+scanr'SegRef f z arr seg =+ let+ sz :. n = arrayShape arr+ Z :. s = arrayShape seg+ (sums, arr') = P.unzip [ P.splitAt 1 (P.scanr f z sec) | sub <- splitEvery n (toList arr)+ , sec <- splitPlaces (toList seg) sub ]+ in+ ( A.fromList (sz:.n) (concat arr'), A.fromList (sz:.s) (concat sums) )+
examples/nofib/Test/Prelude/Stencil.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -23,6 +24,7 @@ import QuickCheck.Arbitrary.Array () import Data.Array.Accelerate as A+import Data.Array.Accelerate.IO as A import Data.Array.Accelerate.Examples.Internal as A import Data.Array.Unboxed as IArray hiding ( Array ) import qualified Data.Array.IArray as IArray@@ -53,7 +55,7 @@ , testBoundary ] where- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a, IArray UArray a)+ testElt :: forall a. (P.Num a, A.Num a, Similar a, Arbitrary a, IArray UArray a) => (Config :-> Bool) -> a -> Maybe Test@@ -68,14 +70,14 @@ -- 1D Stencil --- test_stencil1D :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Vector a -> Property+ test_stencil1D :: (P.Num a, A.Num a, Similar a, IArray UArray a) => Vector a -> Property test_stencil1D vec = toList (acc vec) ~?= elems (ref (toIArray vec)) where pattern (x,y,z) = x + z - 2 * y - acc xs = run backend $ stencil pattern Clamp (use xs)+ acc xs = run1 backend (stencil pattern Clamp) xs - ref :: (Num e, IArray UArray e) => UArray Int e -> UArray Int e+ ref :: (P.Num e, IArray UArray e) => UArray Int e -> UArray Int e ref xs = let (minx,maxx) = bounds xs clamp x = Right (minx `P.max` x `P.min` maxx)@@ -84,7 +86,7 @@ -- 2D Stencil --- test_stencil2D1 :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Array DIM2 a -> Property+ test_stencil2D1 :: (P.Num a, A.Num a, Similar a, IArray UArray a) => Array DIM2 a -> Property test_stencil2D1 vec = toList (acc vec) ~?= elems (ref (toIArray vec)) where pattern ( (t1, t2, t3)@@ -93,9 +95,9 @@ ) = (t1 + t2 + t3 - l + 4*m - r - b1 - b2 - b3) - acc xs = run backend $ stencil pattern (Constant 0) (use xs)+ acc xs = run1 backend (stencil pattern (Constant 0)) xs - ref :: (Num a, IArray UArray a) => UArray (Int,Int) a -> UArray (Int,Int) a+ ref :: (P.Num a, IArray UArray a) => UArray (Int,Int) a -> UArray (Int,Int) a ref xs = let sh = bounds xs@@ -107,7 +109,7 @@ stencil2DRef pattern constant xs - test_stencil2D2 :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Array DIM2 a -> Property+ test_stencil2D2 :: (P.Num a, A.Num a, Similar a, IArray UArray a) => Array DIM2 a -> Property test_stencil2D2 vec = toList (acc vec) ~?= elems (ref (toIArray vec)) where pattern ( (_, t, _)@@ -117,12 +119,12 @@ = (t + l + r + b - 4 * m) acc xs =- let pattern' :: (Elt a, IsNum a) => Stencil3x3 a -> Exp a+ let pattern' :: A.Num a => Stencil3x3 a -> Exp a pattern' = pattern in- run backend $ stencil pattern' Clamp (use xs)+ run1 backend (stencil pattern' Clamp) xs - ref :: (Num a, IArray UArray a) => UArray (Int,Int) a -> UArray (Int,Int) a+ ref :: (P.Num a, IArray UArray a) => UArray (Int,Int) a -> UArray (Int,Int) a ref xs = let ((minu,minv),(maxu,maxv)) = bounds xs clamp (u,v) = Right (minu `P.max` u `P.min` maxu@@ -130,10 +132,10 @@ in stencil2DRef pattern clamp xs - test_stencil2D3 :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Array DIM2 (a,a) -> Property+ test_stencil2D3 :: (P.Num a, A.Num a, Similar a) => Array DIM2 (a,a) -> Property test_stencil2D3 vec = toList (acc vec) ~?= elems (ref (toIArray vec)) where- pattern :: forall a. (Elt a, IsNum a) => Stencil3x3 (a,a) -> Exp a+ pattern :: forall a. A.Num a => Stencil3x3 (a,a) -> Exp a pattern ( (_, _, _) , (x, _, _) , (y, _, z)) = let (x1,x2) = unlift x (y1,y2) = unlift y@@ -148,9 +150,9 @@ in x1 - y2 + y1 - z2 + z1 - x2 - acc xs = run backend $ stencil pattern (Constant (0,0)) (use xs)+ acc xs = run1 backend (stencil pattern (Constant (0,0))) xs - ref :: Num a => IArray.Array (Int,Int) (a,a) -> IArray.Array (Int,Int) a+ ref :: P.Num a => IArray.Array (Int,Int) (a,a) -> IArray.Array (Int,Int) a ref xs = let sh = bounds xs
+ examples/nofib/Test/Prelude/ZipWith.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Test.Prelude.ZipWith (++ test_zipWith++) where++import Prelude as P+import Data.Bits as P+import Data.Label+import Data.Maybe+import Data.Typeable+import Test.QuickCheck hiding ( (.&.), suchThat )+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.Data.Bits as A+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.Array.Sugar as Sugar+import qualified Data.Array.Accelerate.Array.Representation as R++--+-- ZipWith ---------------------------------------------------------------------+--++test_zipWith :: Backend -> Config -> Test+test_zipWith backend opt = testGroup "zipWith" $ 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 a. (P.Integral a, P.Bits a, A.Integral a, A.Bits a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testIntegralElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))+ [ testDim dim0+ , testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary sh, Arbitrary (Array sh a), Arbitrary (Array sh Int)) => sh -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [ -- operators on Num+ testProperty "(+)" (test_plus :: Array sh a -> Array sh a -> Property)+ , testProperty "(-)" (test_minus :: Array sh a -> Array sh a -> Property)+ , testProperty "(*)" (test_mult :: Array sh a -> Array sh a -> Property)++ -- operators on Integral & Bits+ , testProperty "quot" (denom (test_quot :: Array sh a -> Array sh a -> Property))+ , testProperty "rem" (denom (test_rem :: Array sh a -> Array sh a -> Property))+ , testProperty "quotRem" (denom (test_quotRem :: Array sh a -> Array sh a -> Property))+ , testProperty "div" (denom (test_div :: Array sh a -> Array sh a -> Property))+ , testProperty "mod" (denom (test_mod :: Array sh a -> Array sh a -> Property))+ , testProperty "divMod" (denom (test_divMod :: Array sh a -> Array sh a -> Property))+ , testProperty "(.&.)" (test_band :: Array sh a -> Array sh a -> Property)+ , testProperty "(.|.)" (test_bor :: Array sh a -> Array sh a -> Property)+ , testProperty "xor" (test_xor :: Array sh a -> Array sh a -> Property)+ , testProperty "shift" (test_shift :: Array sh a -> Array sh Int -> Property)+ , testProperty "shiftL" (requiring (P.>= 0) (flip test_shiftL :: Array sh Int -> Array sh a -> Property))+ , testProperty "shiftR" (requiring (P.>= 0) (flip test_shiftR :: Array sh Int -> Array sh a -> Property))+ , testProperty "rotate" (test_rotate :: Array sh a -> Array sh Int -> Property)+ , testProperty "rotateL" (requiring (P.>= 0) (flip test_rotateL :: Array sh Int -> Array sh a -> Property))+ , testProperty "rotateR" (requiring (P.>= 0) (flip test_rotateR :: Array sh Int -> Array sh a -> Property))++ -- relational and equality operators+ , testProperty "(<)" (test_lt :: Array sh a -> Array sh a -> Property)+ , testProperty "(>)" (test_gt :: Array sh a -> Array sh a -> Property)+ , testProperty "(<=)" (test_lte :: Array sh a -> Array sh a -> Property)+ , testProperty "(>=)" (test_gte :: Array sh a -> Array sh a -> Property)+ , testProperty "(==)" (test_eq :: Array sh a -> Array sh a -> Property)+ , testProperty "(/=)" (test_neq :: Array sh a -> Array sh a -> Property)+ , testProperty "min" (test_min :: Array sh a -> Array sh a -> Property)+ , testProperty "max" (test_max :: Array sh a -> Array sh a -> Property)+ ]+ where+ test_quot xs ys = run2 backend (A.zipWith quot) xs ys ~?= zipWithRef quot xs ys+ test_rem xs ys = run2 backend (A.zipWith rem) xs ys ~?= zipWithRef rem xs ys+ test_quotRem xs ys = run2 backend (A.zipWith (lift $$ quotRem)) xs ys ~?= zipWithRef quotRem xs ys+ test_div xs ys = run2 backend (A.zipWith div) xs ys ~?= zipWithRef div xs ys+ test_mod xs ys = run2 backend (A.zipWith mod) xs ys ~?= zipWithRef mod xs ys+ test_divMod xs ys = run2 backend (A.zipWith (lift $$ divMod)) xs ys ~?= zipWithRef divMod xs ys++ test_band xs ys = run2 backend (A.zipWith (A..&.)) xs ys ~?= zipWithRef (P..&.) xs ys+ test_bor xs ys = run2 backend (A.zipWith (A..|.)) xs ys ~?= zipWithRef (P..|.) xs ys+ test_xor xs ys = run2 backend (A.zipWith A.xor) xs ys ~?= zipWithRef P.xor xs ys++ test_shift xs ys = run2 backend (A.zipWith A.shift) xs ys ~?= zipWithRef P.shift xs ys+ test_shiftL xs ys = run2 backend (A.zipWith A.shiftL) xs ys ~?= zipWithRef P.shiftL xs ys+ test_shiftR xs ys = run2 backend (A.zipWith A.shiftR) xs ys ~?= zipWithRef P.shiftR xs ys+ test_rotate xs ys = run2 backend (A.zipWith A.rotate) xs ys ~?= zipWithRef P.rotate xs ys+ test_rotateL xs ys = run2 backend (A.zipWith A.rotateL) xs ys ~?= zipWithRef P.rotateL xs ys+ test_rotateR xs ys = run2 backend (A.zipWith A.rotateR) xs ys ~?= zipWithRef P.rotateR xs ys++ testFloatingElt :: forall a. (P.RealFrac a, P.RealFloat a, A.RealFloat a, A.RealFrac a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testFloatingElt ok _+ | P.not (get ok opt) = Nothing+ | otherwise = Just $ testGroup (show (typeOf (undefined :: a)))+ [ testDim dim0+ , testDim dim1+ , testDim dim2+ ]+ where+ testDim :: forall sh. (Shape sh, P.Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test+ testDim sh = testGroup ("DIM" P.++ show (rank sh))+ [ -- operators on Num+ testProperty "(+)" (test_plus :: Array sh a -> Array sh a -> Property)+ , testProperty "(-)" (test_minus :: Array sh a -> Array sh a -> Property)+ , testProperty "(*)" (test_mult :: Array sh a -> Array sh a -> Property)++ -- operators on Fractional, Floating, RealFrac & RealFloat+ , testProperty "(/)" (denom (test_div :: Array sh a -> Array sh a -> Property))+ , testProperty "(**)" (test_pow :: Array sh a -> Array sh a -> Property)+ , testProperty "atan2" (test_atan2 :: Array sh a -> Array sh a -> Property)+ , testProperty "logBase" (requiring (P.> 0) $ \(xs :: Array sh a) ->+ requiring (P.> 0) $ \(ys :: Array sh a) -> test_logBase xs ys)++ -- relational and equality operators+ , testProperty "(<)" (test_lt :: Array sh a -> Array sh a -> Property)+ , testProperty "(>)" (test_gt :: Array sh a -> Array sh a -> Property)+ , testProperty "(<=)" (test_lte :: Array sh a -> Array sh a -> Property)+ , testProperty "(>=)" (test_gte :: Array sh a -> Array sh a -> Property)+ , testProperty "(==)" (test_eq :: Array sh a -> Array sh a -> Property)+ , testProperty "(/=)" (test_neq :: Array sh a -> Array sh a -> Property)+ , testProperty "min" (test_min :: Array sh a -> Array sh a -> Property)+ , testProperty "max" (test_max :: Array sh a -> Array sh a -> Property)+ ]+ where+ test_div xs ys = run2 backend (A.zipWith (/)) xs ys ~?= zipWithRef (/) xs ys+ test_pow xs ys = run2 backend (A.zipWith (**)) xs ys ~?= zipWithRef (**) xs ys+ test_atan2 xs ys = run2 backend (A.zipWith A.atan2) xs ys ~?= zipWithRef P.atan2 xs ys+ test_logBase xs ys = run2 backend (A.zipWith logBase) xs ys ~?= zipWithRef logBase xs ys++ test_plus xs ys = run2 backend (A.zipWith (+)) xs ys ~?= zipWithRef (+) xs ys+ test_minus xs ys = run2 backend (A.zipWith (-)) xs ys ~?= zipWithRef (-) xs ys+ test_mult xs ys = run2 backend (A.zipWith (*)) xs ys ~?= zipWithRef (*) xs ys++ test_lt xs ys = run2 backend (A.zipWith (A.<)) xs ys ~?= zipWithRef (P.<) xs ys+ test_gt xs ys = run2 backend (A.zipWith (A.>)) xs ys ~?= zipWithRef (P.>) xs ys+ test_lte xs ys = run2 backend (A.zipWith (A.<=)) xs ys ~?= zipWithRef (P.<=) xs ys+ test_gte xs ys = run2 backend (A.zipWith (A.>=)) xs ys ~?= zipWithRef (P.>=) xs ys+ test_eq xs ys = run2 backend (A.zipWith (A.==)) xs ys ~?= zipWithRef (P.==) xs ys+ test_neq xs ys = run2 backend (A.zipWith (A./=)) xs ys ~?= zipWithRef (P./=) xs ys+ test_min xs ys = run2 backend (A.zipWith (A.min)) xs ys ~?= zipWithRef (P.min) xs ys+ test_max xs ys = run2 backend (A.zipWith (A.max)) xs ys ~?= zipWithRef (P.max) xs ys++ {-# INLINE denom #-}+ denom f = forAllShrink arbitrary shrink $ \xs ->+ requiring (P./= 0) $ \ys -> f xs ys+++suchThat :: Gen a -> (a -> Bool) -> Gen a+suchThat gen p = do+ x <- gen+ case p x of+ True -> return x+ False -> sized $ \n -> resize (n+1) (suchThat gen p)++{-# INLINE requiring #-}+requiring+ :: (Elt e, Shape sh, Arbitrary e, Arbitrary sh, Testable prop)+ => (e -> Bool)+ -> (Array sh e -> prop)+ -> Property+requiring f go =+ let+ shrinkRequiring arr = [ fromList (Sugar.shape arr) sl | sl <- shrinkOneRequiring (toList arr) ]+ shrinkOneRequiring [] = []+ shrinkOneRequiring (x:xs) = [ x':xs | x' <- shrink x, f x' ]+ P.++ [ x:xs' | xs' <- shrinkOneRequiring xs ]+ in+ forAllShrink arbitrary shrink $ \sh ->+ forAllShrink (arbitraryArrayOf sh (arbitrary `suchThat` f)) shrinkRequiring $ \arr ->+ go arr+++-- Reference Implementation+-- ------------------------++zipWithRef :: (Shape sh, Elt c) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c+zipWithRef f xs ys =+ let shx = fromElt (arrayShape xs)+ shy = fromElt (arrayShape ys)+ sh = toElt (R.intersect shx shy)+ in+ fromFunction sh (\ix -> f (xs Sugar.! ix) (ys Sugar.! ix))+
examples/nofib/Test/Sharing.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -11,6 +13,7 @@ import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Bits as A import Test.Framework import Test.Framework.Providers.HUnit @@ -119,13 +122,13 @@ keys = A.map keyFun inArr bits = A.map (\a -> (A.testBit a bitNum) ? (1, 0)) keys- bitsInv = A.map (\b -> (b ==* 0) ? (1, 0)) bits+ bitsInv = A.map (\b -> (b A.== 0) ? (1, 0)) bits (falses, numZeroes) = A.scanl' (+) 0 bitsInv trues = A.map (\x -> (A.the numZeroes) + (A.fst x) - (A.snd x)) $ A.zip ixs falses - dstIxs = A.map (\x -> let (b, t, f) = unlift x in (b ==* (constant (0::Int))) ? (f, t))+ dstIxs = A.map (\x -> let (b, t, f) = unlift x in (b A.== (constant (0::Int))) ? (f, t)) $ A.zip3 bits trues falses outArr = scatter dstIxs inArr inArr -- just use input as default array --(we're writing over everything anyway)@@ -236,19 +239,19 @@ test1 :: Acc (Vector Float) test1 = flip A.map vec- $ \x -> A.while (A.<* x) (+1) 0+ $ \x -> A.while (A.< x) (+1) 0 test2 :: Acc (Vector Float) test2 = flip A.map vec $ \x -> let y = 2*pi- in y + A.while (A.<* 10) (+y) x+ in y + A.while (A.< 10) (+y) x test3 :: Acc (Vector Float) test3 = flip A.map vec- $ \x -> A.while (A.<* x) (+x) 0+ $ \x -> A.while (A.< x) (+x) 0 awhile_test :: Acc (Vector Float)- awhile_test = A.awhile (\a -> A.unit (the (A.sum a) A.<* 200)) (A.map (+1)) vec+ awhile_test = A.awhile (\a -> A.unit (the (A.sum a) A.< 200)) (A.map (+1)) vec iterate_test :: Acc (Vector Float) iterate_test = flip A.map vec@@ -268,7 +271,7 @@ for 64 (\j acc' -> i + j + acc') 0) 0 unused :: Exp Int- = A.while (==* 10) (const 10) 5+ = A.while (A.== 10) (const 10) 5 ---------------------------------------------------------------------- @@ -278,7 +281,7 @@ _shouldFail :: Acc (Vector Float) _shouldFail = mvm (use $ fromList (Z:.10:.10) [0..]) (use $ fromList (Z:.10) [0..]) where- dotp :: (Elt e, IsNum e) => Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e)+ dotp :: A.Num e => Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e) dotp xs ys = A.fold (+) 0 $ A.zipWith (*) xs ys takeRow :: Elt e => Exp Int -> Acc (Array DIM2 e) -> Acc (Vector e)@@ -288,7 +291,7 @@ (\ix -> index2 n (unindex1 ix)) mat - mvm :: (Elt e, IsNum e) => Acc (Array DIM2 e) -> Acc (Vector e) -> Acc (Vector e)+ mvm :: A.Num e => Acc (Array DIM2 e) -> Acc (Vector e) -> Acc (Vector e) mvm mat vec = let Z :. rows :. _ = unlift (shape mat) :: Z :. Exp Int :. Exp Int in generate (index1 rows)
examples/nofib/Test/Spectral/BlackScholes.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -37,8 +38,8 @@ , testElt configDouble c_BlackScholes_d ] where- testElt :: forall a. ( Elt a, IsFloating a, Similar a, Arbitrary a, Random a, Storable a- , BlockPtrs (EltRepr a) ~ ((), Ptr a), BlockPtrs (EltRepr' a) ~ Ptr a)+ testElt :: forall a. ( P.Floating a, A.Floating a, A.Ord a, Similar a, Arbitrary a, Random a, Storable a+ , BlockPtrs (EltRepr a) ~ Ptr a ) => (Config :-> Bool) -> BlackScholes a -> Maybe Test@@ -47,11 +48,11 @@ | otherwise = Just $ testProperty (show (typeOf (undefined :: a))) (run_blackscholes cfun) - opts :: (Floating a, Random a) => Gen (a,a,a)+ opts :: (P.Floating a, Random a) => Gen (a,a,a) opts = (,,) <$> choose (5,30) <*> choose (1,100) <*> choose (0.25,10) - run_blackscholes :: forall a. ( Elt a, IsFloating a, Similar a, Storable a, Random a, Arbitrary a- , BlockPtrs (EltRepr a) ~ ((), Ptr a), BlockPtrs (EltRepr' a) ~ Ptr a)+ run_blackscholes :: forall a. ( P.Floating a, A.Floating a, A.Ord a, Similar a, Storable a, Random a+ , BlockPtrs (EltRepr a) ~ Ptr a ) => BlackScholes a -> Property run_blackscholes cfun =@@ -67,16 +68,16 @@ -- Black-Scholes option pricing ------------------------------------------------ -- -riskfree, volatility :: Floating a => a+riskfree, volatility :: P.Floating a => a riskfree = 0.02 volatility = 0.30 -horner :: Num a => [a] -> a -> a+horner :: P.Num a => [a] -> a -> a horner coeff x = x * foldr1 madd coeff where madd a b = a + x*b -cnd' :: Floating a => a -> a+cnd' :: P.Floating a => a -> a cnd' d = let poly = horner coeff coeff = [0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429]@@ -86,7 +87,7 @@ rsqrt2pi * exp (-0.5*d*d) * poly k -blackscholes :: (Elt a, IsFloating a) => Acc (Vector (a, a, a)) -> Acc (Vector (a, a))+blackscholes :: (P.Floating a, A.Floating a, A.Ord a) => Acc (Vector (a, a, a)) -> Acc (Vector (a, a)) blackscholes = A.map go where go x =@@ -96,7 +97,7 @@ v_sqrtT = v * sqrt years d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / v_sqrtT d2 = d1 - v_sqrtT- cnd d = let c = cnd' d in d >* 0 ? (1.0 - c, c)+ cnd d = let c = cnd' d in d A.> 0 ? (1.0 - c, c) cndD1 = cnd d1 cndD2 = cnd d2 x_expRT = strike * exp (-r * years)@@ -111,7 +112,7 @@ type BlackScholes a = Ptr a -> Ptr a -> Ptr a -> Ptr a -> Ptr a -> a -> a -> Int32 -> IO () blackScholesRef- :: forall a. (Storable a, Floating a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a), BlockPtrs (EltRepr' a) ~ Ptr a)+ :: forall a. (Storable a, P.Floating a, A.Floating a, BlockPtrs (EltRepr a) ~ Ptr a) => BlackScholes a -> Vector (a,a,a) -> IO (Vector (a,a))
examples/nofib/Test/Spectral/RadixSort.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -13,7 +14,7 @@ ) where import Prelude as P-import Data.Bits+import Data.Bits as P ( finiteBitSize ) import Data.List import Data.Label import Data.Maybe@@ -26,6 +27,7 @@ import Config import QuickCheck.Arbitrary.Array () import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Bits as A import Data.Array.Accelerate.Examples.Internal as A @@ -49,7 +51,7 @@ , testElt configWord64 (undefined :: Word64) ] where- testElt :: forall a. (Radix a, Ord a, Elt a, IsIntegral a, Similar a, Arbitrary a)+ testElt :: forall a. (Radix a, P.Ord a, A.Integral a, Similar a, Arbitrary a) => (Config :-> Bool) -> a -> Maybe Test@@ -70,18 +72,18 @@ -- Implementation -- -------------- -class Elt e => Radix e where+class A.Bits e => Radix e where passes :: e {- dummy -} -> Int radix :: Exp Int -> Exp e -> Exp Int #define signed(ty) \ instance Radix ty where ; \- passes = finiteBitSize ; \+ passes = P.finiteBitSize ; \ radix = radixOfSigned ; #define unsigned(ty) \ instance Radix ty where ; \- passes = finiteBitSize ; \+ passes = P.finiteBitSize ; \ radix = radixOfUnsigned ; signed(Int)@@ -95,13 +97,13 @@ unsigned(Word32) unsigned(Word64) -radixOfSigned :: forall e. (Radix e, IsIntegral e) => Exp Int -> Exp e -> Exp Int-radixOfSigned i e = i ==* (passes' - 1) ? (radix' (e `xor` minBound), radix' e)+radixOfSigned :: forall e. (Radix e, A.Bounded e, A.Integral e, A.FromIntegral e Int) => Exp Int -> Exp e -> Exp Int+radixOfSigned i e = i A.== (passes' - 1) ? (radix' (e `xor` minBound), radix' e) where radix' x = A.fromIntegral $ (x `A.shiftR` i) .&. 1 passes' = constant (passes (undefined :: e)) -radixOfUnsigned :: (Radix e, IsIntegral e) => Exp Int -> Exp e -> Exp Int+radixOfUnsigned :: (Radix e, A.Integral e, A.FromIntegral e Int) => Exp Int -> Exp e -> Exp Int radixOfUnsigned i e = A.fromIntegral $ (e `A.shiftR` i) .&. 1 @@ -118,7 +120,7 @@ where p = passes (undefined :: r) --- deal f x = let (a,b) = unlift x in (f ==* 0) ? (a,b)+ deal f x = let (a,b) = unlift x in (f A.== 0) ? (a,b) radixPass k v = let k' = unit (constant k) flags = A.map (radix (the k') . rdx) v idown = prescanl (+) 0 . A.map (xor 1) $ flags
examples/nofib/Test/Spectral/SMVM.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Spectral.SMVM (@@ -37,7 +39,7 @@ , testElt configDouble (undefined :: Double) ] where- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a)+ testElt :: forall a. (P.Num a, A.Num a, Similar a, Arbitrary a) => (Config :-> Bool) -> a -> Maybe Test@@ -46,7 +48,7 @@ | otherwise = Just $ testProperty (show (typeOf (undefined :: a))) (run_smvm (undefined :: a)) - run_smvm :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) => a -> Property+ run_smvm :: forall a. (P.Num a, A.Num a, Similar a, Arbitrary a) => a -> Property run_smvm _ = forAll arbitraryCSRMatrix $ \(segd, svec :: Vector (Int32,a), cols) -> forAll (arbitraryArray (Z :. cols)) $ \vec ->@@ -58,7 +60,7 @@ -- Reference implementation -- ------------------------ -smvmRef :: (Elt a, IsNum a)+smvmRef :: (Elt a, P.Num a) => Segments Int32 -> Vector (Int32, a) -> Vector a
examples/pagerank/Config.hs view
@@ -11,6 +11,7 @@ _configSteps :: Int , _configChunkSize :: Int , _configCount :: Bool+ , _configNoSeq :: Bool } deriving Show @@ -21,6 +22,7 @@ { _configSteps = 10 , _configChunkSize = 12000000 , _configCount = False+ , _configNoSeq = True } @@ -29,6 +31,7 @@ [ Option [] ["steps"] (ReqArg (set configSteps . read) "INT") "number of steps to perform" , Option [] ["chunk-size"] (ReqArg (set configChunkSize . read) "INT") "size of chunks to be processed" , Option [] ["count"] (NoArg (set configCount True)) "count number of pages in the links file"+ , Option [] ["noseq"] (NoArg (set configNoSeq True)) "do not use Accelerate sequencing" ]
examples/pagerank/Load.hs view
@@ -38,9 +38,9 @@ -- Slice out the pages we read from the buffer. | [] <- ls = do printPosition True " lines read : " 10000 ixLine- from' <- V.freeze (VM.slice 0 ix from)- to' <- V.freeze (VM.slice 0 ix to)- sizes' <- V.freeze sizes+ from' <- V.freeze (VM.slice 0 ml_ix ml_from)+ to' <- V.freeze (VM.slice 0 ml_ix ml_to)+ sizes' <- V.freeze ml_sizes return (from', to', sizes') @@ -53,5 +53,6 @@ Just links' <- parsePage l links go links' (ixLine+1) rest -+ | otherwise+ = error "PageRank.loadPages: unexpected error"
examples/pagerank/Main.hs view
@@ -8,26 +8,23 @@ import Count import Rank -import Control.Monad-import Data.Char-import Data.Label ( get )-import System.Environment-import System.Exit- import Data.Array.Accelerate.Examples.Internal +import Control.Monad+import Data.Label ( get ) + main :: IO () main = do beginMonitoring- argv <- getArgs- (conf, opts, linksPath : titlesPath : _) <- parseArgs options defaults header footer argv+ (conf, opts, linksPath : titlesPath : _) <- parseArgs options defaults header footer let backend = get optBackend opts steps = get configSteps conf chunk = get configChunkSize conf+ noSeq = get configNoSeq conf if get configCount conf then void (countPages linksPath)- else rank backend steps chunk linksPath titlesPath+ else rank backend noSeq steps chunk linksPath titlesPath
examples/pagerank/Page.hs view
@@ -2,19 +2,16 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Page- ( PageId- , Rank- , Link- , MLinks(..)- , parsePage- , parsePageId)-where+module Page (++ PageId, Rank, Link, MLinks(..),+ parsePage, parsePageId++) where+ import Prelude as P import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Vector.Storable as U import qualified Data.Vector.Storable.Mutable as UM-import Control.Monad.ST import Data.Word @@ -33,11 +30,14 @@ = Float -- | A mutable set of links-data MLinks = MLinks { ix :: Int- , size :: Int- , from :: (UM.IOVector PageId)- , to :: (UM.IOVector PageId)- , sizes :: UM.IOVector Int }+data MLinks+ = MLinks+ { ml_ix :: Int+ , ml_size :: Int+ , ml_from :: UM.IOVector PageId+ , ml_to :: UM.IOVector PageId+ , ml_sizes :: UM.IOVector Int+ } -- | Parse just the PageId from a line in the links file.@@ -74,14 +74,14 @@ -- | Parse a vector of PageIds. pageIds :: PageId -> BL.ByteString -> MLinks -> IO (MLinks)-pageIds pid bs0 links- = go links 0 bs0+pageIds pid bs0 links0+ = go links0 0 bs0 where go links@(MLinks{..}) count bs- | ix >= size- = do from' <- UM.grow from size- to' <- UM.grow to size- go (MLinks ix (2*size) from' to' sizes) count bs+ | ml_ix >= ml_size+ = do from' <- UM.grow ml_from ml_size+ to' <- UM.grow ml_to ml_size+ go (MLinks ml_ix (2*ml_size) from' to' ml_sizes) count bs | BL.null bs = final@@ -90,14 +90,15 @@ = go links count bs2 | Just (i, bs2) <- BL.readInt bs- = do UM.write from ix pid- UM.write to ix (fromIntegral i)- go (MLinks (ix+1) size from to sizes) (count+1) bs2+ = do UM.write ml_from ml_ix pid+ UM.write ml_to ml_ix (fromIntegral i)+ go (MLinks (ml_ix+1) ml_size ml_from ml_to ml_sizes) (count+1) bs2 | otherwise = final where final = do- UM.write sizes (fromIntegral pid) count+ UM.write ml_sizes (fromIntegral pid) count return links+
+ examples/pagerank/README.md view
@@ -0,0 +1,37 @@+accelerate-pagerank+-------------------++A simplified version of the [PageRank][pagerank-wiki] algorithm in Accelerate, based on a [repa][repa-homepage] implementation.++Example+-------++### Getting sample data++In `data/pagerank/` there is a simple test graph consisting of only a handful of pages and links. The file `titles.txt` contains the names of all the pages, one page per line. In `pages.txt` is the actual link graph. Each line is of the form:++```+n: m0 m1 m2 m3...+```++This specifies that the page at index `n` in the titles file has outgoing links to pages `m0`, `m1`, etc.++A more realistic dataset in the same format is available from [here][wikipedia-link-dump]. The two files you need are:+ * [links-simple-sorted.zip](http://users.on.net/~henry/pagerank/links-simple-sorted.zip) (323 MB)+ * [titles-sorted.zip](http://users.on.net/~henry/pagerank/titles-sorted.zip) (28 MB)++### Running the program++> accelerate-pagerank data/pagerank/pages.txt data/pagerank/titles.txt++This will run 10 steps of the algorithm using the simple test graph and output the page with the highest rank. More or fewer steps can be run with the `-steps` flag.++> accelerate-pagerank -steps 12 data/pagerank/pages.txt data/pagerank/titles.txt++By default this example will execute in chunks consisting of 12 million links at a time. Depending on the capability of your hardware, the available memory, and the size of your dataset, you may wish to adjust this. This can be done with `-chunk-size`.++> accelerate-pagerank -chunk-size 24000000 links-simple-sorted.txt titles-sorted.txt++ [pagerank-wiki]: https://en.wikipedia.org/wiki/PageRank+ [repa-homepage]: http://repa.ouroborus.net/+ [wikipedia-link-dump]: https://wayback.archive.org/web/20160818143819/http://haselgrove.id.au/wikipedia.htm
examples/pagerank/Rank.hs view
@@ -1,49 +1,57 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Rank (rank) where --import Load-import Step import Count+import Load import Page-import System.Directory-import Control.Monad-import Prelude as P+import Step+ import Data.Array.Accelerate as A-import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Array.Sugar as A ( EltRepr ) import Data.Array.Accelerate.Examples.Internal as A-import qualified Data.Vector as V-import qualified Data.Vector.Storable as S+import Data.Array.Accelerate.IO as A++import Control.Monad import System.CPUTime+import qualified Data.Vector.Storable as S+import Prelude as P +arrayize+ :: (Vectors (EltRepr e) ~ S.Vector a, Elt e, S.Storable a)+ => S.Vector a+ -> Vector e+arrayize vec = (A.fromVectors (Z :. S.length vec) vec)+ -- | Perform some iterations of the PageRank algorithm by loading the whole -- links graph into memory and passes it off in chunks to Accelerate to -- avoid running out of device memory. rank :: Backend+ -> Bool -- ^ Do not use Accelerate sequencing -> Int -- ^ Number of iterations to run. -> Int -- ^ Size of chunk. -> FilePath -- ^ Path to links file. -> FilePath -- ^ Path to titles file. -> IO ()--rank backend steps chunkSize pagesPath titlesPath+rank backend noSeq steps chunkSize pagesPath titlesPath = do (_, maxPageId) <- countPages pagesPath putStrLn "* Loading pages." (!from, !to, !sizes) <- loadPages pagesPath (P.fromIntegral maxPageId) let pageCount = S.length sizes+ -- let edgeCount = S.length from let !ranks = initialRanks backend pageCount start <- getCPUTime- pageRank backend steps chunkSize pageCount (from, to) (A.fromVectors (Z:.pageCount) ((), sizes)) titlesPath ranks+ pageRank backend noSeq steps chunkSize pageCount from to (arrayize sizes) titlesPath ranks end <- getCPUTime- putStrLn $ "Time taken: " P.++ show (P.fromIntegral (end - start) / (10^12)) P.++ " secs"+ putStrLn $ "Time taken: " P.++ show (P.fromIntegral (end - start) / (10 P.^ (12::Int)) :: Double) P.++ " secs" return () - -- | Construct the initial ranks vector. initialRanks :: Backend -> Int -> A.Vector Rank initialRanks backend pageCount@@ -54,52 +62,47 @@ -- | Run several iterations of the internal PageRank algorithm. pageRank :: Backend+ -> Bool -- ^ Do not use Accelerate sequencing. -> Int -- ^ Number of iterations to run. -> Int -- ^ Chunk size -> Int -- ^ Number of pages- -> (S.Vector PageId, S.Vector PageId) -- ^ Pages graph.+ -> S.Vector PageId -- ^ Pages graph from.+ -> S.Vector PageId -- ^ Pages graph to (same length as from). -> A.Vector Int -- ^ The degree of each page -> FilePath -- ^ Path to titles file. -> A.Vector Rank -- ^ Initial ranks. -> IO () -pageRank backend maxIters chunkSize pageCount (from, to) sizes titlesFile ranks0- = go maxIters ranks0- where go 0 !ranks- = do -- Show the page with the maximum rank.- let !rankMaxIx = maxIndex ranks- let !rankMax = indexArray ranks (Z:.indexArray rankMaxIx Z)- putStrLn $ " high ix : " P.++ show rankMaxIx- putStrLn $ " high rank : " P.++ show rankMax-- return ()+pageRank backend _noSeq maxIters chunkSize pageCount from to sizes0 _titlesFile ranks0 =+ go maxIters ranks0+ where+ go :: Int -> A.Vector Rank -> IO ()+ go 0 !ranks+ = let !rankMaxIx = maxIndex ranks+ !rankMax = indexArray ranks (Z:.indexArray rankMaxIx Z)+ -- Sum up the ranks for all the pages,+ -- this should be very close to 1, minus some some round-off error.+ in do -- Show the page with the maximum rank.+ putStrLn $ " high ix : " P.++ show rankMaxIx+ putStrLn $ " high rank : " P.++ show rankMax+ return () go !i !ranks = do putStr "\n" putStrLn $ "* Step " P.++ show i -- Run a step of the algorithm.- let !ranks1 = stepInChunks ranks zeroes 0- let !ranks2 = addDangles (ranks, sizes)+ -- let ranks1 = if noSeq then stepInChunks ranks zeros 0 else stepInSeq ranks+ let ranks1 = stepInChunks ranks zeros 0+ let ranks2 = addDangles (ranks1, sizes0) -- Sum up the ranks for all the pages, -- this should be very close to 1, minus some some round-off error.- let !rankSum = sum ranks2+ let rankSum = run1 backend A.sum ranks2 putStrLn $ " rank sum : " P.++ show rankSum go (i - 1) ranks2 - stepInChunks !ranks !parRanks !start- | start >= edgeCount- = parRanks- | otherwise- = let end = P.min (start + chunkSize) edgeCount- from' = S.slice start (end - start) from- to' = S.slice start (end - start) to- !pages = A.fromVectors (Z:.(end - start)) (((), from'), to')- !parRanks1 = step (pages, sizes, ranks, parRanks)- in stepInChunks ranks parRanks1 (start + chunkSize)- -- Add to the rank the score due to dangling vectors. addDangles :: (Vector Rank, Vector Int) -> Vector Rank addDangles = run1 backend $ A.uncurry $ \ranks sizes -> let@@ -109,20 +112,35 @@ dangleContrib :: Acc (Scalar Rank) dangleContrib = A.unit (the dangleScore / (A.lift (P.fromIntegral pageCount :: Float))) - d r s = s ==* 0 ? (r, 0)+ d r s = s A.== 0 ? (r, 0) in A.map (+ A.the dangleContrib) ranks + -- stepInSeq :: A.Vector Rank -> A.Vector Rank+ -- stepInSeq =+ -- let !pages = A.fromVectors (Z:.S.length from) (((), from), to)+ -- in run1 backend (stepRankSeq pages (use sizes))+ edgeCount = S.length from - zeroes :: Vector Rank- zeroes = run backend $ A.fill (A.lift $ Z :. pageCount) 0+ zeros :: Vector Rank+ zeros = run backend $ A.fill (A.lift $ Z :. pageCount) 0 + stepInChunks !ranks !parRanks !start+ | start P.>= edgeCount+ = parRanks+ | otherwise+ = let end = P.min (start + chunkSize) edgeCount+ from' = S.slice start (end - start) from+ to' = S.slice start (end - start) to+ !pages = A.fromVectors (Z:.(end - start)) (((), from'), to')+ !parRanks1 = step (pages, sizes0, ranks, parRanks)+ in stepInChunks ranks parRanks1 (start + chunkSize)+ step :: (PageGraph, Vector Int, Vector Rank, Vector Rank) -> Vector Rank step = run1 backend $ (\t -> let (p,s,r,pr) = unlift t in stepRank p s r pr) - sum = run1 backend A.sum- -- Computer the index of the maximum rank. maxIndex :: A.Vector Rank -> A.Scalar Int- maxIndex = run1 backend $ (\ranks -> A.fold (\x y -> ranks ! index1 x >* ranks ! index1 y ? (x,y)) 0 (A.enumFromN (A.shape ranks) 0))+ maxIndex = run1 backend $ (\ranks -> A.fold (\x y -> ranks ! index1 x A.> ranks ! index1 y ? (x,y)) 0 (A.enumFromN (A.shape ranks) 0))+
examples/pagerank/Step.hs view
@@ -1,17 +1,57 @@ -module Step- (stepRank, PageGraph)-where-import Page-import Progress-import Control.Monad-import Data.IORef-import Data.Array.Accelerate as A+module Step ( + stepRank, Update, PageGraph +) where++import Page+import Data.Array.Accelerate as A+ type PageGraph = Vector Link +type Update = (PageId, Rank) +{--+-- | Find the page rank contribution of one edge in the page graph.+contribution+ :: Acc (Vector Int) -- ^ Number of outgoing links for each page.+ -> Acc (Vector Rank) -- ^ Old ranks vector.+ -> Exp Link -- ^ A link.+ -> Exp Update -- ^ New rank.+contribution sizes ranks link+ = let (from, to) = unlift link :: (Exp PageId, Exp PageId)+ in lift (to, ranks ! index1 (A.fromIntegral from) / A.fromIntegral (sizes ! index1 (A.fromIntegral from))) :: Exp Update++-- | Updates a vector of ranks by a given vector of updates.+addUpdates+ :: Acc (Vector Rank) -- ^ Old partial ranks.+ -> Acc (Vector Update) -- ^ Updates.+ -> Acc (Vector Rank) -- ^ New partial ranks.+addUpdates parRanks updates+ = let+ (to, contr) = A.unzip updates+ in A.permute (+) parRanks (index1 . A.fromIntegral . (to !)) contr++stepRankSeq :: PageGraph+ -> Acc (Vector Int) -- Sizes.+ -> Acc (Vector Rank) -- Initial ranks.+ -> Acc (Vector Rank) -- Final ranks.+stepRankSeq p sizes ranks+ = let+ zeroes :: Acc (Vector Rank)+ zeroes = A.fill (shape ranks) 0.0++ -- Ignore shape vector.+ addUpdates' :: Acc (Vector Rank) -> Acc (Vector Z) -> Acc (Vector Update) -> Acc (Vector Rank)+ addUpdates' = const . addUpdates++ in A.collect+ $ A.foldSeqFlatten addUpdates' zeroes+ $ A.mapSeq (A.map (contribution sizes ranks))+ (A.toSeq (Z :. Split) (use p))+--}+ -- | Perform one iteration step for the internal Page Rank algorithm. stepRank :: Acc PageGraph -- ^ Part of the pages graph.@@ -22,7 +62,7 @@ stepRank links sizes ranks parRanks = let- pageCount = A.size sizes+ -- pageCount = A.size sizes -- For every link supplied, calculate it's contribution to the page it points to. contribution :: Acc (Vector Float)
+ examples/ray/Common/Type.hs view
@@ -0,0 +1,14 @@++module Common.Type (++ V3(..),+ module Common.Type,++) where++import Data.Array.Accelerate.Linear.V3++type Position = V3 Float+type Direction = V3 Float+type Noraml = (Position, Direction)+
examples/ray/Gloss/Draw.hs view
@@ -3,7 +3,7 @@ where -- friends-import Vec3+import Common.Type import Scene.Light import Scene.Object import Scene.State@@ -11,9 +11,12 @@ -- frenemies import Data.Array.Accelerate as A-import Graphics.Gloss.Accelerate.Data.Color.RGB-import qualified Graphics.Gloss.Accelerate.Raster.Field as G+import Data.Array.Accelerate.Data.Colour.RGB as RGB+import Data.Array.Accelerate.Linear.Metric+import qualified Data.Array.Accelerate.Data.Colour.RGBA as RGBA +import Graphics.Gloss.Accelerate.Data.Point+ --library import Prelude as P import Data.Label ( get )@@ -38,10 +41,10 @@ -> Int -> Int -> Int- -> Exp Color+ -> Exp Colour -> Acc (Objects, Lights, Scalar Position)- -> Exp G.Point- -> Exp G.Color+ -> Exp Point+ -> Exp RGBA.Colour tracePixel sizeX sizeY fov bounces ambient state point = let sizeX' = P.fromIntegral sizeX@@ -51,14 +54,14 @@ fovX = fov' * aspect fovY = fov' - (x,y) = G.xyOfPoint point+ (x,y) = xyOfPoint point - eyeDir = normalise $ makeVec3 (x * fovX) ((-y) * fovY) 0 - eyePos+ eyeDir = normalize $ lift (V3 (x * fovX) ((-y) * fovY) 0) - eyePos eyePos = the eyePos' (objects, lights, eyePos') = unlift state - (r,g,b) = rgbOfColor $ traceRay bounces objects lights ambient eyePos eyeDir+ RGB r g b = unlift $ traceRay bounces objects lights ambient eyePos eyeDir in- G.rawColor r g b 1+ RGBA.rgba r g b 1
examples/ray/Gloss/Event.hs view
@@ -4,7 +4,7 @@ where -- friends-import Vec3+import Common.Type import Scene.State -- library@@ -45,12 +45,12 @@ motion (x,y) | Just (oX, oY) <- get stateLeftClick state- , XYZ eyeX eyeY eyeZ <- get stateEyeDelta state+ , V3 eyeX eyeY eyeZ <- get stateEyeDelta state = let eyeX' = eyeX + (x - oX) eyeY' = eyeY eyeZ' = eyeZ + (y - oY) in- set stateEyeDelta (XYZ eyeX' eyeY' eyeZ')+ set stateEyeDelta (V3 eyeX' eyeY' eyeZ') $ set stateLeftClick (Just (x, y)) $ state
examples/ray/Main.hs view
@@ -13,19 +13,17 @@ -- Friends import Data.Array.Accelerate as A import Data.Array.Accelerate.Examples.Internal-import Graphics.Gloss.Accelerate.Data.Color.RGB+import Data.Array.Accelerate.Data.Colour.RGB import qualified Graphics.Gloss.Accelerate.Raster.Field as G -- Enemies import Data.Label-import System.Environment ( getArgs ) main :: IO () main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer let width = get configWidth conf height = get configHeight conf@@ -35,9 +33,9 @@ fps = get configFramerate conf backend = get optBackend opts state = initState 0- ambient = rawColor 0.3 0.3 0.3+ ambient = rgb 0.3 0.3 0.3 - scene :: Acc (Objects,Lights) -> Acc (Array DIM2 Color)+ scene :: Acc (Objects,Lights) -> Acc (Array DIM2 Colour) scene st = let eye = constant (get stateEyePos state) eyeDir = castViewRays width height fov eye
+ examples/ray/README.md view
@@ -0,0 +1,17 @@+accelerate-ray+==============++Implementation of a simple [ray tracer][ray-tracing-wiki] in Accelerate. The+program supports multiple reflections, but is otherwise quite basic. This+simplicity however means the GUI program can be interactive; use the WASD keys+to move the view port around, and the arrow keys to move the position of the+light source.++Example+-------++![ray][ray-img]++ [ray-tracing-wiki]: https://en.wikipedia.org/wiki/Ray_tracing_(graphics)+ [ray-img]: https://github.com/AccelerateHS/accelerate-examples/raw/master/samples/ray.jpg+
examples/ray/Ray/Intersect.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -5,16 +6,13 @@ where -- friends-import Vec3+import Common.Type import Scene.Object -- frenemies import Data.Array.Accelerate as A --- standard library-import Prelude as P - -- | Of two intersection tests, take the nearest. -- nearest :: forall a. Elt a@@ -26,8 +24,8 @@ (h1, d1, _ :: Exp a) = unlift x (h2, d2, _ :: Exp a) = unlift y in- h1 &&* h2 ? ( d1 A.<* d2 ? (x, y) -- both objects intersect; take the nearest- , h1 ? (x, y) ) -- only one object intersects+ h1 && h2 ? ( d1 < d2 ? (x, y) -- both objects intersect; take the nearest+ , h1 ? (x, y) ) -- only one object intersects -- | Find the nearest point of intersection for a ray. If there is a hit, then@@ -54,7 +52,7 @@ = sfoldl (\s o -> let (_, dist, _) = unlift s :: (Exp Bool, Exp Float, Exp object) (hit, dist') = unlift $ distanceTo o orig dir in- hit &&* dist' A.<* dist ? (lift (hit, dist', o), s))+ hit && dist' < dist ? (lift (hit, dist', o), s)) (lift (False, infinity, dummy)) (constant Z) objects@@ -72,9 +70,9 @@ -> Exp Float -- minimum distance -> Exp Bool checkRay distanceTo objs orig dir dist- = A.fst $ A.while (\s -> let (hit, i) = unlift s in A.not hit &&* i A.<* unindex1 (shape objs))- (\s -> let i = A.snd s- (hit, dist') = unlift $ distanceTo (objs ! index1 i) orig dir- in hit &&* dist' A.<* dist ? (lift (True, i), lift (False, i+1)))- (constant (False, 0))+ = fst $ while (\s -> let (hit, i) = unlift s in not hit && i < unindex1 (shape objs))+ (\s -> let i = snd s+ (hit, dist') = unlift $ distanceTo (objs ! index1 i) orig dir+ in hit && dist' < dist ? (lift (True, i), lift (False, i+1)))+ (constant (False, 0))
examples/ray/Ray/Trace.hs view
@@ -4,18 +4,21 @@ where -- friends-import Vec3+import Common.Type import Scene.Object import Scene.Light import Ray.Intersect -- frenemies import Data.Array.Accelerate as A-import Graphics.Gloss.Accelerate.Data.Color.RGB+import Data.Array.Accelerate.Data.Colour.RGB as RGB+import Data.Array.Accelerate.Data.Colour.Names+import Data.Array.Accelerate.Linear.Metric+import Data.Array.Accelerate.Linear.Vector import Graphics.Gloss.Accelerate.Data.Point -- standard library-import Prelude as P+import qualified Prelude as P -- | Generate all of the rays that will be cast from the given eye position to@@ -38,7 +41,7 @@ in A.generate (constant (Z :. sizeY :. sizeX)) (\ix -> let (x, y) = xyOfPoint $ pointOfIndex sizeX sizeY ix- in normalise $ makeVec3 (x * fovX) ((-y) * fovY) 0 - eyePos)+ in normalize $ lift (V3 (x * fovX) ((-y) * fovY) 0) - eyePos) -- | Cast a single ray into the scene@@ -47,22 +50,23 @@ :: Int -- ^ Maximum reflection count -> Acc Objects -- ^ Objects in the scene -> Acc Lights -- ^ Direct lighting in the scene- -> Exp Color -- ^ Ambient light in the scene+ -> Exp Colour -- ^ Ambient light in the scene -> Exp Position -- ^ Origin of the ray -> Exp Direction -- ^ Direction of the ray- -> Exp Color+ -> Exp Colour traceRay limit objects lights ambient = go limit where (spheres, planes) = unlift objects - dummySphere = constant (Sphere (XYZ 0 0 0) 0 (RGB 0 0 0) 0)- dummyPlane = constant (Plane (XYZ 0 0 0) (XYZ 0 0 1) (RGB 0 0 0) 0)+ dummySphere = constant (Sphere (V3 0 0 0) 0 (RGB 0 0 0) 0)+ dummyPlane = constant (Plane (V3 0 0 0) (V3 0 0 1) (RGB 0 0 0) 0) -- Stop once there are too many reflections, in case we've found two -- parallel mirrors. --+ go :: Int -> Exp Position -> Exp Direction -> Exp Colour go 0 _ _- = black+ = constant black go bounces orig dir = let@@ -73,9 +77,9 @@ (hit_s, dist_s, s) = unlift $ castRay distanceToSphere dummySphere spheres orig dir (hit_p, dist_p, p) = unlift $ castRay distanceToPlane dummyPlane planes orig dir in- A.not (hit_s ||* hit_p) ?+ A.not (hit_s || hit_p) ? -- ray didn't intersect any objects- ( black+ ( constant black -- ray hit an object , let@@ -84,11 +88,11 @@ next_s = hitSphere s dist_s orig dir next_p = hitPlaneCheck p dist_p orig dir - (point, normal, color, shine)- = unlift (dist_s A.<* dist_p ? ( next_s, next_p ))+ (point, normal, colour, shine)+ = unlift (dist_s < dist_p ? ( next_s, next_p )) -- result angle of ray after reflection- newdir = dir - (2.0 * (normal `dot` dir)) .* normal+ newdir = dir - (2.0 * (normal `dot` dir)) *^ normal -- determine the direct lighting at this point direct = applyLights objects lights point normal@@ -103,47 +107,45 @@ light_in = scaleColour shine refl + scaleColour (1.0 - shine) lighting - -- outgoing light is incoming light modified by surface color.- -- We also need to clip it in case the sum of all incoming- -- lights is too bright to display.- light_out = clampColor (light_in * color)+ -- outgoing light is incoming light modified by surface colour. We+ -- also need to clip it in case the sum of all incoming lights is+ -- too bright to display.+ light_out = RGB.clamp (light_in * colour) in light_out ) -scaleColour :: Exp Float -> Exp Color -> Exp Color-scaleColour s c- = let (r,g,b) = rgbOfColor c- in rawColor (r * s) (g * s) (b * s)+scaleColour :: Exp Float -> Exp Colour -> Exp Colour+scaleColour s c = lift (RGB s s s) * c -hitSphere :: Exp Sphere -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Color, Float)+hitSphere :: Exp Sphere -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float) hitSphere sph dist orig dir = let- point = orig + dist .* dir+ point = orig + dist *^ dir normal = sphereNormal sph point- color = sphereColor sph+ colour = sphereColor sph shine = sphereShine sph in- lift (point, normal, color, shine)+ lift (point, normal, colour, shine) -hitPlane :: Exp Plane -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Color, Float)+hitPlane :: Exp Plane -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float) hitPlane pln dist orig dir = let- point = orig + dist .* dir+ point = orig + dist *^ dir normal = planeNormal pln- color = planeColor pln+ colour = planeColor pln shine = planeShine pln in- lift (point, normal, color, shine)+ lift (point, normal, colour, shine) -hitPlaneCheck :: Exp PlaneCheck -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Color, Float)+hitPlaneCheck :: Exp PlaneCheck -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float) hitPlaneCheck pln dist orig dir = let- point = orig + dist .* dir+ point = orig + dist *^ dir normal = planeCheckNormal pln- color = checkers point+ colour = checkers point shine = planeCheckShine pln in- lift (point, normal, color, shine)+ lift (point, normal, colour, shine)
examples/ray/Scene/Light.hs view
@@ -8,31 +8,36 @@ where -- friends-import Vec3+import Common.Type import Ray.Intersect import Scene.Object -- frenemies import Data.Array.Accelerate as A+import Data.Array.Accelerate.Data.Colour.Names+import Data.Array.Accelerate.Data.Colour.RGB+import Data.Array.Accelerate.Linear.Metric+import Data.Array.Accelerate.Linear.Vector++import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..), fromTuple, toTuple )+import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, EltRepr' )-import Graphics.Gloss.Accelerate.Data.Color.RGB -- standard library import Data.Typeable+import qualified Prelude as P -- | An omnidirectional point light source, whose intensity drops off with -- distance from the source. ---data Light = Light Position Color- deriving (Eq, Show, Typeable)+data Light = Light Position Colour+ deriving (P.Eq, P.Show, Typeable) type Lights = Array DIM1 Light lightPos :: Exp Light -> Exp Position-lightColor :: Exp Light -> Exp Color+lightColor :: Exp Light -> Exp Colour -- | Compute the direct lighting contribution of all lights acting on a point on@@ -51,9 +56,9 @@ -> Acc Lights -> Exp Position -> Exp Direction- -> Exp Color+ -> Exp Colour applyLights objects lights point normal- = sfoldl (\c l -> c + applyLight objects point normal l) black (constant Z) lights+ = sfoldl (\c l -> c + applyLight objects point normal l) (constant black) (constant Z) lights -- | Compute the direct lighting at a particular point for a single light@@ -63,7 +68,7 @@ -> Exp Position -- point which is being lit -> Exp Direction -- surface normal at this point -> Exp Light -- does this light contribute colour to this point?- -> Exp Color+ -> Exp Colour applyLight objects point normal light = let (spheres, planes) = unlift objects@@ -72,18 +77,18 @@ -- on the surface? -- lp_p = lightPos light - point- dist = magnitude lp_p- dir = (1.0 / dist) .* lp_p+ dist = norm lp_p+ dir = (1.0 / dist) *^ lp_p -- Calculate the magnitude of the reflected light, if there are no -- occluding objects between the light and the surface point. -- mag = (normal `dot` dir) / (dist * dist)- (r, g, b) = rgbOfColor (lightColor light)- refl = rawColor (r * mag) (g * mag) (b * mag)+ RGB r g b = unlift (lightColor light)+ refl = lift $ RGB (r * mag) (g * mag) (b * mag) in- checkRay distanceToSphere spheres point dir dist ||* checkRay distanceToPlane planes point dir dist- ? ( black, refl )+ checkRay distanceToSphere spheres point dir dist || checkRay distanceToPlane planes point dir dist+ ? ( constant black, refl ) @@ -92,22 +97,18 @@ lightPos l = Exp $ SuccTupIdx ZeroTupIdx `Prj` l lightColor l = Exp $ ZeroTupIdx `Prj` l -type instance EltRepr Light = EltRepr (Position, Color)-type instance EltRepr' Light = EltRepr' (Position, Color)+type instance EltRepr Light = EltRepr (Position, Colour) instance Elt Light where- eltType (_ :: Light) = eltType (undefined :: (Position, Color))+ eltType (_ :: Light) = eltType (undefined :: (Position, Colour)) toElt light = let (p,c) = toElt light in Light p c fromElt (Light p c) = fromElt (p,c) - eltType' (_ :: Light) = eltType' (undefined :: (Position, Color))- toElt' light = let (p,c) = toElt' light in Light p c- fromElt' (Light p c) = fromElt' (p,c)--instance IsTuple Light where- type TupleRepr Light = TupleRepr (Position, Color)- fromTuple (Light p c) = fromTuple (p,c)- toTuple t = let (p,c) = toTuple t in Light p c+instance IsProduct Elt Light where+ type ProdRepr Light = ProdRepr (Position, Colour)+ fromProd _ (Light p c) = fromTuple (p,c)+ toProd _ t = let (p,c) = toTuple t in Light p c+ prod cst _ = prod cst (undefined :: (Position, Colour)) instance Lift Exp Light where type Plain Light = Light
examples/ray/Scene/Object.hs view
@@ -8,19 +8,25 @@ where -- friends-import Vec3+import Common.Type -- frenemies import Data.Array.Accelerate as A+import Data.Array.Accelerate.Control.Lens+import Data.Array.Accelerate.Data.Bits+import Data.Array.Accelerate.Linear.Metric+import Data.Array.Accelerate.Linear.V3+import Data.Array.Accelerate.Linear.Vector++import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..), fromTuple, toTuple )+import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, EltRepr' )-import Graphics.Gloss.Accelerate.Data.Color.RGB +import Data.Array.Accelerate.Data.Colour.RGB+ -- standard library-import Prelude as P-import Data.Bits ( xor ) import Data.Typeable+import qualified Prelude as P -- | All objects in the scene@@ -31,21 +37,21 @@ -- | Objects in the world. Accelerate does not have sum types, so define each -- object separately (and hope this works out...) ---data Sphere = Sphere Position Float Color Float- deriving (Eq, Show, Typeable)+data Sphere = Sphere Position Float Colour Float+ deriving (P.Eq, P.Show, Typeable) spherePos :: Exp Sphere -> Exp Position-sphereColor :: Exp Sphere -> Exp Color+sphereColor :: Exp Sphere -> Exp Colour sphereShine :: Exp Sphere -> Exp Float sphereRadius :: Exp Sphere -> Exp Float -data Plane = Plane Position Direction Color Float- deriving (Eq, Show, Typeable)+data Plane = Plane Position Direction Colour Float+ deriving (P.Eq, P.Show, Typeable) planePos :: Exp Plane -> Exp Position planeNormal :: Exp Plane -> Exp Direction-planeColor :: Exp Plane -> Exp Color+planeColor :: Exp Plane -> Exp Colour planeShine :: Exp Plane -> Exp Float @@ -68,13 +74,13 @@ pos = spherePos sphere radius = sphereRadius sphere - p = origin + ((pos - origin) `dot` direction) .* direction- d_cp = magnitude (p - pos)+ p = origin + ((pos - origin) `dot` direction) *^ direction+ d_cp = norm (p - pos) sep = p - origin- miss = d_cp >=* radius ||* sep `dot` direction <=* 0+ miss = d_cp >= radius || sep `dot` direction <= 0 in miss ? ( lift (False, infinity)- , lift (True, magnitude sep - sqrt (radius * radius - d_cp * d_cp)) )+ , lift (True, norm sep - sqrt (radius * radius - d_cp * d_cp)) ) -- | Compute the distance to the surface of a Plane@@ -90,20 +96,20 @@ normal = planeNormal plane theta = direction `dot` normal -- TLM: name? in- theta >=* 0 ? ( lift (False, infinity)- , lift (True, ((pos - origin) `dot` normal) / theta) )+ theta >= 0 ? ( lift (False, infinity)+ , lift (True, ((pos - origin) `dot` normal) / theta) ) -- | The maximum representable floating point value -- infinity :: Exp Float-infinity = constant (encodeFloat m n)+infinity = constant (P.encodeFloat m n) where a = undefined :: Float- b = floatRadix a- e = floatDigits a- (_, e') = floatRange a- m = b ^ e - 1+ b = P.floatRadix a+ e = P.floatDigits a+ (_, e') = P.floatRange a+ m = b P.^ e - 1 n = e' - e @@ -114,24 +120,24 @@ -> Exp Position -- ^ A point on the surface of the sphere -> Exp Direction -- ^ Normal at that point sphereNormal sphere point- = normalise (point - spherePos sphere)+ = normalize (point - spherePos sphere) -- | A checkerboard pattern along the x/z axis ---checkers :: Exp Position -> Exp Color+checkers :: Exp Position -> Exp Colour checkers pos = let- (x,_,z) = xyzOfVec pos-+ x = pos ^. _x+ z = pos ^. _z v1 = (A.truncate (x / 100) :: Exp Int32) `mod` 2 v2 = (A.truncate (z / 100) :: Exp Int32) `mod` 2- v3 = A.fromIntegral . boolToInt $ x A.<* 0.0- v4 = A.fromIntegral . boolToInt $ z A.<* 0.0+ v3 = A.fromIntegral . boolToInt $ x A.< 0.0+ v4 = A.fromIntegral . boolToInt $ z A.< 0.0 in- v1 `xor` v2 `xor` v3 `xor` v4 ==* 1 {- True -}- ? ( rawColor 1.0 1.0 1.0- , rawColor 0.4 0.4 0.4 )+ v1 `xor` v2 `xor` v3 `xor` v4 == 1 {- True -}+ ? ( rgb 1.0 1.0 1.0+ , rgb 0.4 0.4 0.4 ) -- Get Objects into Accelerate -------------------------------------------------@@ -158,22 +164,18 @@ -- Sphere -- ------ -type instance EltRepr Sphere = EltRepr (Position, Float, Color, Float)-type instance EltRepr' Sphere = EltRepr' (Position, Float, Color, Float)+type instance EltRepr Sphere = EltRepr (Position, Float, Colour, Float) instance Elt Sphere where- eltType (_ :: Sphere) = eltType (undefined :: (Position, Float, Color, Float))+ eltType (_ :: Sphere) = eltType (undefined :: (Position, Float, Colour, Float)) toElt sphere = let (p,r,c,s) = toElt sphere in Sphere p r c s fromElt (Sphere p r c s) = fromElt (p, r, c, s) - eltType' (_ :: Sphere) = eltType' (undefined :: (Position, Float, Color, Float))- toElt' sphere = let (p,r,c,s) = toElt' sphere in Sphere p r c s- fromElt' (Sphere p r c s) = fromElt' (p, r, c, s)--instance IsTuple Sphere where- type TupleRepr Sphere = TupleRepr (Position, Float, Color, Float)- fromTuple (Sphere p r c s) = fromTuple (p, r, c, s)- toTuple t = let (p, r, c, s) = toTuple t in Sphere p r c s+instance IsProduct Elt Sphere where+ type ProdRepr Sphere = ProdRepr (Position, Float, Colour, Float)+ fromProd _ (Sphere p r c s) = fromTuple (p, r, c, s)+ toProd _ t = let (p, r, c, s) = toTuple t in Sphere p r c s+ prod cst _ = prod cst (undefined :: (Position, Float, Colour, Float)) instance Lift Exp Sphere where type Plain Sphere = Sphere@@ -185,22 +187,18 @@ -- Plane -- ----- -type instance EltRepr Plane = EltRepr (Position, Direction, Color, Float)-type instance EltRepr' Plane = EltRepr' (Position, Direction, Color, Float)+type instance EltRepr Plane = EltRepr (Position, Direction, Colour, Float) instance Elt Plane where- eltType (_ :: Plane) = eltType (undefined :: (Position, Direction, Color, Float))+ eltType (_ :: Plane) = eltType (undefined :: (Position, Direction, Colour, Float)) toElt plane = let (p,n,c,s) = toElt plane in Plane p n c s fromElt (Plane p n c s) = fromElt (p, n, c, s) - eltType' (_ :: Plane) = eltType' (undefined :: (Position, Direction, Color, Float))- toElt' plane = let (p,n,c,s) = toElt' plane in Plane p n c s- fromElt' (Plane p n c s) = fromElt' (p, n, c, s)--instance IsTuple Plane where- type TupleRepr Plane = TupleRepr (Position, Direction, Color, Float)- fromTuple (Plane p n c s) = fromTuple (p, n, c, s)- toTuple t = let (p, n, c, s) = toTuple t in Plane p n c s+instance IsProduct Elt Plane where+ type ProdRepr Plane = ProdRepr (Position, Direction, Colour, Float)+ fromProd _ (Plane p n c s) = fromTuple (p, n, c, s)+ toProd _ t = let (p, n, c, s) = toTuple t in Plane p n c s+ prod cst _ = prod cst (undefined :: (Position, Direction, Colour, Float)) instance Lift Exp Plane where type Plain Plane = Plane@@ -213,17 +211,12 @@ -- Checkered Plane -- --------------- -type instance EltRepr PlaneCheck = EltRepr (Position, Direction, Float)-type instance EltRepr' PlaneCheck = EltRepr' (Position, Direction, Float)+type instance EltRepr PlaneCheck = EltRepr (Position, Direction, Float) instance Elt PlaneCheck where eltType (_ :: PlaneCheck) = eltType (undefined :: (Position, Direction, Float)) toElt plane = let (p,n,s) = toElt plane in PlaneCheck p n s fromElt (PlaneCheck p n s) = fromElt (p, n, s)-- eltType' (_ :: PlaneCheck) = eltType' (undefined :: (Position, Direction, Float))- toElt' plane = let (p,n,s) = toElt' plane in PlaneCheck p n s- fromElt' (PlaneCheck p n s) = fromElt' (p, n, s) instance IsTuple PlaneCheck where type TupleRepr PlaneCheck = TupleRepr (Position, Direction, Float)
examples/ray/Scene/State.hs view
@@ -4,7 +4,7 @@ where -- friends-import Vec3+import Common.Type import Scene.Light import Scene.Object import Scene.World@@ -51,10 +51,10 @@ = advanceState 0 $ State { _stateTime = time- , _stateEyePos = XYZ 50 (-100) (-700)+ , _stateEyePos = V3 50 (-100) (-700) - , _stateEyeDelta = XYZ (-50) 200 1296- , _stateLightDelta = XYZ 0 0 0+ , _stateEyeDelta = V3 (-50) 200 1296+ , _stateLightDelta = V3 0 0 0 , _stateLeftClick = Nothing @@ -83,11 +83,11 @@ speed = get stateMoveSpeed state move eye f d = case get f state of Nothing -> id- Just Fwd -> modify eye (+ (set d ( speed * dt) (XYZ 0 0 0)))- Just Rev -> modify eye (+ (set d (-speed * dt) (XYZ 0 0 0)))+ Just Fwd -> modify eye (+ (set d ( speed * dt) (V3 0 0 0)))+ Just Rev -> modify eye (+ (set d (-speed * dt) (V3 0 0 0))) - zz = lens (\(XYZ _ _ z) -> z) (\f (XYZ x y z) -> XYZ x y (f z))- xx = lens (\(XYZ x _ _) -> x) (\f (XYZ x y z) -> XYZ (f x) y z)+ zz = lens (\(V3 _ _ z) -> z) (\f (V3 x y z) -> V3 x y (f z))+ xx = lens (\(V3 x _ _) -> x) (\f (V3 x y z) -> V3 (f x) y z) -- | Set the time of the world
examples/ray/Scene/World.hs view
@@ -1,19 +1,18 @@- module Scene.World where -- friends-import Vec3+import Common.Type import Scene.Light import Scene.Object -- frenemies import Data.Array.Accelerate as A-import Graphics.Gloss.Accelerate.Data.Color.RGB+import Data.Array.Accelerate.Data.Colour.RGB makeLights :: Float -> Lights makeLights _time- = A.fromList (Z :. 1) [ Light (XYZ 300 (-300) (-100))+ = A.fromList (Z :. 1) [ Light (V3 300 (-300) (-100)) (RGB 150000 150000 150000) ] @@ -21,30 +20,30 @@ makeObjects time = let spheres = A.fromList (Z :. 4)- [ Sphere (XYZ (40 * sin time) 80 0.0)+ [ Sphere (V3 (40 * sin time) 80 0.0) 20 (RGB 1.0 0.3 1.0) 0.4 - , Sphere (XYZ (200 * sin time) (-40 * sin (time + pi/2)) (200 * cos time))+ , Sphere (V3 (200 * sin time) (-40 * sin (time + pi/2)) (200 * cos time)) 100.0 (RGB 0.4 0.4 1.0) 0.8 - , Sphere (XYZ (-200.0 * sin time) (-40 * sin (time - pi/2)) (-200 * cos time))+ , Sphere (V3 (-200.0 * sin time) (-40 * sin (time - pi/2)) (-200 * cos time)) 100.0 (RGB 0.4 0.4 1.0) 0.5 - , Sphere (XYZ 0.0 (-150.0) (-100.0))+ , Sphere (V3 0.0 (-150.0) (-100.0)) 50.0 (RGB 1.0 1.0 1.0) 0.8 ] planes = A.fromList (Z :. 1)- [ Plane (XYZ 0.0 100.0 0.0)- (XYZ 0.0 (-0.9805807) (-0.19611613))+ [ Plane (V3 0.0 100.0 0.0)+ (V3 0.0 (-0.9805807) (-0.19611613)) (RGB 1.0 1.0 1.0) 0.2 ]
− examples/ray/Vec3.hs
@@ -1,148 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS -fno-warn-missing-methods #-}--module Vec3- where--import Prelude-import Data.Typeable-import Data.Array.Accelerate-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Sugar----- | Points and vectors in 3D Space----type Position = Vec3-type Direction = Vec3-type Normal = (Position, Direction)---- | A parameterised point in XYZ space.----type Vec3 = XYZ Float---- | Make a Vec3----makeVec3 :: Exp Float -> Exp Float -> Exp Float -> Exp Vec3-makeVec3 x y z = lift (XYZ x y z)----- | Extract the components of the Vec3----xyzOfVec :: Exp Vec3 -> (Exp Float, Exp Float, Exp Float)-xyzOfVec v- = let XYZ x y z = unlift v- in (x, y, z)----- | Yield the magnitude of a vector.----magnitude :: Exp Vec3 -> Exp Float-magnitude v- = let XYZ x y z = unlift v- in- sqrt (x * x + y * y + z * z)----- | Normalise a vector to have unit length.----normalise :: Exp Vec3 -> Exp Vec3-normalise v = (1.0 / magnitude v) .* v----- | Component-wise multiply a vector by a scalar.----infixl 7 .*-(.*) :: Exp Float -> Exp Vec3 -> Exp Vec3-(.*) s v- = let XYZ x y z = unlift v- in- makeVec3 (s * x) (s * y) (s * z)----- | Compute the dot product of two vectors.----dot :: Exp Vec3 -> Exp Vec3 -> Exp Float-dot v1 v2- = let XYZ x1 y1 z1 = unlift v1- XYZ x2 y2 z2 = unlift v2- in- x1 * x2 + y1 * y2 + z1 * z2----- | Clamp a vectors components to some minimum and maximum values.----clamp :: Exp Vec3 -> Exp Float -> Exp Float -> Exp Vec3-clamp v minVal maxVal =- makeVec3 (go x) (go y) (go z)- where- XYZ x y z = unlift v- go u = minVal `max` u `min` maxVal----- | Clip a vector's components to some maximum value.----clip :: Exp Vec3 -> Exp Float -> Exp Vec3-clip v maxVal =- makeVec3 (go x) (go y) (go z)- where- XYZ x y z = unlift v- go u = u `min` maxVal----- Get a Vec3 into Accelerate ----------------------------------------------------data XYZ a = XYZ a a a- deriving (Eq, Show, Typeable)--type instance EltRepr (XYZ a) = EltRepr (a, a, a)-type instance EltRepr' (XYZ a) = EltRepr' (a, a, a)--instance Elt a => Elt (XYZ a) where- eltType (_ :: XYZ a) = eltType (undefined :: (a, a, a))- toElt p = let (x,y,z) = toElt p in XYZ x y z- fromElt (XYZ x y z) = fromElt (x, y, z)-- eltType' (_ :: XYZ a) = eltType (undefined :: (a, a, a))- toElt' p = let (x,y,z) = toElt p in XYZ x y z- fromElt' (XYZ x y z) = fromElt (x, y, z)--instance IsTuple (XYZ a) where- type TupleRepr (XYZ a) = TupleRepr (a, a, a)- fromTuple (XYZ x y z) = fromTuple (x, y, z)- toTuple t = let (x,y,z) = toTuple t in XYZ x y z--instance (Lift Exp a, Elt (Plain a)) => Lift Exp (XYZ a) where- type Plain (XYZ a) = XYZ (Plain a)- lift (XYZ x y z) = Exp . Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y `SnocTup` lift z--instance Elt a => Unlift Exp (XYZ (Exp a)) where- unlift t = let x = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t- y = Exp $ SuccTupIdx ZeroTupIdx `Prj` t- z = Exp $ ZeroTupIdx `Prj` t- in XYZ x y z---- | Pretend a Vec3 is a number----instance Num a => Num (XYZ a) where- (+) (XYZ x1 x2 x3) (XYZ y1 y2 y3)- = XYZ (x1 + y1) (x2 + y2) (x3 + y3)-- (-) (XYZ x1 x2 x3) (XYZ y1 y2 y3)- = XYZ (x1 - y1) (x2 - y2) (x3 - y3)-- (*) (XYZ x1 x2 x3) (XYZ y1 y2 y3)- = XYZ (x1 * y1) (x2 * y2) (x3 * y3)---instance (Elt a, IsNum a) => Num (Exp (XYZ a)) where- (+) = lift2 ((+) :: XYZ (Exp a) -> XYZ (Exp a) -> XYZ (Exp a))- (-) = lift2 ((-) :: XYZ (Exp a) -> XYZ (Exp a) -> XYZ (Exp a))- (*) = lift2 ((*) :: XYZ (Exp a) -> XYZ (Exp a) -> XYZ (Exp a))-
examples/smoothlife/Config.hs view
@@ -6,6 +6,7 @@ import Prelude as P hiding ((.), id, fst, snd) import qualified Prelude as P +import Data.Word import Data.Label import Control.Category import System.Console.GetOpt@@ -18,6 +19,7 @@ -- type R = Float type C = Complex R+type RGBA32 = Word32 type Matrix a = Array DIM2 a data SigmoidFunction
examples/smoothlife/Gloss/Draw.hs view
@@ -5,50 +5,53 @@ import Config -import Prelude as P+import qualified Prelude as P import Data.Label-import Graphics.Gloss++import Graphics.Gloss ( Picture, scale ) import Graphics.Gloss.Accelerate.Data.Picture-import Data.Array.Accelerate as A hiding ( size )-import Data.Array.Accelerate.IO as A +import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate.Data.Colour.RGB+import Data.Array.Accelerate.Data.Colour.Names + colourise :: ColourScheme -> Acc (Matrix R) -> Acc (Matrix RGBA32)-colourise scheme = A.map (rgba32OfFloat . colour scheme)+colourise scheme = A.map (packRGB . colour scheme) where phase = 0.01- alpha = constant 1- fract x = x - A.fromIntegral (A.floor x :: Exp Int) mix x y a = x*(1-a) + y*a - colour RedBlack f = lift (f, constant 0, constant 0, alpha)- colour WhiteBlack f = lift (f, f, f, alpha)- colour BlackWhite f = lift (x, x, x, alpha) where x = 1-f- colour BrownGreen f = lift (mix 0.5 0.5 f, mix 0.3 0.75 f, mix 0 1 f, alpha)+ colour :: ColourScheme -> Exp Float -> Exp Colour+ colour RedBlack f = rgb f 0 0+ colour WhiteBlack f = rgb f f f+ colour BlackWhite f = rgb x x x where x = 1-f+ colour BrownGreen f = rgb (mix 0.5 0.5 f) (mix 0.3 0.75 f) (mix 0 1 f) colour GoldBrown f = let ssf = sqrt (sqrt f)- in lift ( mix 0.5 (mix 1 0.3 f) ssf- , mix 0.3 (mix 0.95 0.2 f) ssf- , constant 0- , alpha)+ in rgb ( mix 0.5 (mix 1 0.3 f) ssf )+ ( mix 0.3 (mix 0.95 0.2 f) ssf )+ 0 colour Rainbow1 f = rainbow (fract phase * 6) f colour Rainbow2 f = rainbow (6 * sqrt (sqrt (1-f))) (sqrt (sqrt f)) colour Rainbow3 f = rainbow' (sqrt (sqrt (1-f))) (sqrt (sqrt f)) + rainbow :: Exp Float -> Exp Float -> Exp Colour rainbow p x- = p >* 0 &&* p A.<* 1- ? (lift (x, x*p, constant 0, alpha)- , p A.<* 2 ? (lift (x*(2-p), x, constant 0, alpha)- , p A.<* 3 ? (lift (constant 0, x, x*(p-2), alpha)- , p A.<* 4 ? (lift (constant 0, x*(4-p), x, alpha)- , p A.<* 5 ? (lift (x*(p-4), constant 0, x, alpha)- , p A.<* 6 ? (lift (x, constant 0, x*(6-p), alpha)- , {-else-} (constant (0,0,0,0))))))))+ = p > 0 && p < 1+ ? (rgb x (x*p) 0+ , p < 2 ? (rgb (x*(2-p)) x 0+ , p < 3 ? (rgb 0 x (x*(p-2))+ , p < 4 ? (rgb 0 (x*(4-p)) x+ , p < 5 ? (rgb (x*(p-4)) 0 x+ , p < 6 ? (rgb x 0 (x*(6-p))+ , {-else-} (constant black))))))) + rainbow' :: Exp Float -> Exp Float -> Exp Colour rainbow' p x = let c y = 0.5 * sin (1.7 * cos (pi * (p + y / 3.0 + phase))) + 0.5- in lift (x * c 0, x * c 1, x * c 2, alpha)+ in rgb (x * c 0) (x * c 1) (x * c 2) draw :: Config -> Matrix RGBA32 -> Picture
examples/smoothlife/Main.hs view
@@ -14,15 +14,13 @@ import Data.Array.Accelerate.Examples.Internal as A import Data.Label import Control.Exception-import System.Environment import Graphics.Gloss main :: IO () main = do beginMonitoring- argv <- getArgs- (conf, opts, rest) <- parseArgs options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer let -- visualisation configuration n = get configWindowSize conf
examples/smoothlife/SmoothLife.hs view
@@ -14,7 +14,7 @@ import Config -import Prelude as P+import qualified Prelude as P import Data.Label import Data.Array.Accelerate as A hiding ( size ) import Data.Array.Accelerate.Examples.Internal as A hiding ( nf )@@ -39,13 +39,13 @@ where -- A simulation step --- aaf = fft2D' Forward size size (complex aa)- nf = A.zipWith (*) aaf (use krf')- mf = A.zipWith (*) aaf (use kdf')- n = A.map (\x -> real x / kflr'') (fft2D' Inverse size size nf)- m = A.map (\x -> real x / kfld'') (fft2D' Inverse size size mf)+ aaf = fft2D' Forward sh (complex aa)+ nf = zipWith (*) aaf (use krf')+ mf = zipWith (*) aaf (use kdf')+ n = map (\x -> real x / kflr'') (fft2D' Inverse sh nf)+ m = map (\x -> real x / kfld'') (fft2D' Inverse sh mf) aa' = snm conf sn sm b1 b2 d1 d2 n m- aa'' = clamp $ A.zipWith timestepMode aa' aa+ aa'' = clamp $ zipWith timestepMode aa' aa -- simulation parameters --@@ -59,18 +59,18 @@ timestepMode f g = timestepModes f g P.!! get configTimestepMode conf size = get configWindowSize conf- sh = constant (Z:.size:.size)+ sh = Z:.size:.size -- initial state --- kflr = A.sum kr- kfld = A.sum kd- krf = fft2D' Forward size size (shift2D (complex kr))- kdf = fft2D' Forward size size (shift2D (complex kd))+ kflr = sum kr+ kfld = sum kd+ krf = fft2D' Forward sh (shift2D (complex kr))+ kdf = fft2D' Forward sh (shift2D (complex kd)) - kd = A.generate sh (\ix -> 1 - linear (radius ix) ri b)- kr = A.generate sh (\ix -> let r = radius ix- in linear r ri b * (1 - linear r ra b))+ kd = generate (constant sh) (\ix -> 1 - linear (radius ix) ri b)+ kr = generate (constant sh) (\ix -> let r = radius ix+ in linear r ri b * (1 - linear r ra b)) kflr'' = constant (kflr' `A.indexArray` Z) kfld'' = constant (kfld' `A.indexArray` Z)@@ -82,21 +82,21 @@ get1 f c = constant $ get f c get2 f c = let (x,y) = get f c in (constant x, constant y) - complex = A.map (\x -> lift (x :+ constant 0))+ complex = map (\x -> lift (x :+ constant 0)) radius ix = let Z:.y':.x' = unlift ix :: Z :. Exp Int :. Exp Int- x = A.fromIntegral $ x' - constant (size `div` 2)- y = A.fromIntegral $ y' - constant (size `div` 2)+ x = fromIntegral $ x' - constant (size `div` 2)+ y = fromIntegral $ y' - constant (size `div` 2) in sqrt (x*x + y*y) linear x l u- = x A.<* l-u/2 ? ( 0.0- , x A.>* l+u/2 ? ( 1.0+ = x < l-u/2 ? ( 0.0+ , x > l+u/2 ? ( 1.0 , (x - l + u / 2) / u )) - clamp = A.map+ clamp = map (\x -> min (max x 0.0) 1.0) timestepModes f g@@ -112,7 +112,7 @@ -- snm :: Config -> Exp R -> Exp R -> Exp R -> Exp R -> Exp R -> Exp R -> Acc (Matrix R) -> Acc (Matrix R) -> Acc (Matrix R) snm conf sn sm b1 b2 d1 d2- = A.zipWith sigmode+ = zipWith sigmode where sigtype = getSigmoidFunction (get configSigtype conf) mixtype = getSigmoidFunction (get configMixtype conf)@@ -153,7 +153,7 @@ #endif in case f of- Hard -> x >=* a ? (1, 0)+ Hard -> x >= a ? (1, 0) Smooth -> 1.0/(1.0+cexp(-(x-a)*4.0/ea)) Atan -> atan ((x-a) * pi/ea) / pi + 0.5 Atancos -> 0.5 * (0.5 * atan ((x-a) / ea) / pi * cos ((x-a) * 1.4) * 1.1 + 1.0)@@ -165,6 +165,7 @@ where bounded :: (Exp R -> Exp R -> Exp R -> Exp R) -> Exp R -> Exp R -> Exp R -> Exp R bounded f' x' a' ea'- = x' A.<* a'-ea'/2.0 ? ( 0.0- , x' A.>* a'+ea'/2.0 ? ( 1.0+ = x' < a'-ea'/2.0 ? ( 0.0+ , x' > a'+ea'/2.0 ? ( 1.0 , f' x' a' ea' ))+
examples/smvm/Main.hs view
@@ -3,47 +3,52 @@ import Matrix import Config -import Prelude as P-import Data.Label ( get )-import System.Random.MWC-import System.Exit+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.IO as A++import Data.Label ( get )+import Data.Matrix.MatrixMarket ( readMatrix ) import System.Environment-import Data.Array.Accelerate as A-import Data.Array.Accelerate.Examples.Internal as A-import qualified Data.Vector.Unboxed as V+import System.Exit+import System.Random.MWC+import Text.Printf+import Prelude as P+import qualified Data.Vector.Storable as S main :: IO ()-main = withSystemRandom $ \gen -> do+main = do beginMonitoring - argv <- getArgs- (_, opts, rest) <- parseArgs options defaults header footer argv+ (_, opts, rest) <- parseArgs options defaults header footer fileIn <- case rest of (i:_) -> return i- _ -> parseArgs options defaults [] [] ("--help":argv)+ _ -> withArgs ["--help"] $ parseArgs options defaults [] [] >> exitSuccess -- Read in the matrix file, and generate a random vector to multiply against --- (segd', svec', cols) <- readCSRMatrix gen fileIn- vec' <- uniformVector gen cols+ matrix <- readMatrix fileIn+ csr <- withSystemRandom $ \gen -> matrixToCSR gen matrix+ xs <- withSystemRandom $ \gen -> uniformVector gen (rows csr) :: IO (S.Vector Double) -- Convert to Accelerate arrays --- let vec = fromFunction (Z :. V.length vec') (\(Z:.i) -> vec' V.! i)- segd = fromFunction (Z :. V.length segd') (\(Z:.i) -> segd' V.! i)- svec = fromFunction (Z :. V.length svec') (\(Z:.i) -> svec' V.! i)- smat = lift (use segd, svec)+ let vec = fromVectors (Z :. S.length xs) xs+ segd = fromVectors (Z :. S.length (csr_segd_length csr)) (csr_segd_length csr)+ svec = fromVectors (Z :. nnz csr) (((), csr_indices csr), csr_values csr)+ smat = use (segd, svec) :: Acc (SparseMatrix Double) backend = get optBackend opts - putStrLn $ "Reading matrix: " P.++ fileIn- putStrLn $ " with shape: " P.++ shows (V.length segd') " x " P.++ shows cols " and "- P.++ shows (V.length svec') " entries\n"+ printf "input matrix: %s\n" fileIn+ printf " size: %d x %d\n" (rows csr) (columns csr)+ printf " non-zeros: %d\n\n" (nnz csr) -- Benchmark -- runBenchmarks opts (P.tail rest)- [ bench "smvm" $ whnf (run1 backend (smvm smat)) vec ]+ [ bench "smvm" $ whnf (run1 backend (smvm smat)) vec+ ]
examples/smvm/Matrix.hs view
@@ -1,104 +1,127 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} -module Matrix where+module Matrix ( + CSRMatrix(..),+ matrixToCSR, nnz, rows, columns,++) where+ import Data.Int-import MatrixMarket-import System.Random.MWC+import Data.Matrix.MatrixMarket ( Matrix(..), Structure(..) )+import Data.Scientific+import Data.Vector.Storable ( Vector, Storable ) import System.IO.Unsafe-import Control.Monad.Primitive+import System.Random.MWC+import qualified Data.Vector.Storable as S+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Algorithms.Intro as V -import Data.Vector.Unboxed ( Vector, Unbox )-import qualified Data.Vector.Unboxed as V-import qualified Data.Vector.Unboxed.Mutable as M-import qualified Data.Vector.Algorithms.Intro as V -type CSRMatrix a =- ( Vector Int32 -- segment descriptor- , Vector (Int32, a) -- sparse vector for the (flattened) rows- , Int -- number of columns- )---- Read a sparse matrix from a MatrixMarket file. Pattern matrices are filled--- with random numbers in the range (-1,1).----{-# INLINE readCSRMatrix #-}-readCSRMatrix- :: GenIO- -> FilePath- -> IO (CSRMatrix Float)-readCSRMatrix gen file = do- mtx <- readMatrix file- case mtx of- (RealMatrix dim l vals) -> csr dim l vals- (PatternMatrix dim l ix) -> csr dim l =<< mapM' (\(a,b) -> (a,b,) `fmap` uniformR (-1,1) gen) ix- (IntMatrix _ _ _) -> error "IntMatrix type not supported"- (ComplexMatrix _ _ _) -> error "ComplexMatrix type not supported"+data CSRMatrix a =+ CSRMatrix { csr_segd_length :: !(Vector Int32) -- segment descriptor as row lengths+ , csr_segd_offset :: !(Vector Int32) -- segment descriptor as row offset+ , csr_indices :: !(Vector Int32) -- column indices+ , csr_values :: !(Vector a) -- non-zero values+ , csr_dim :: !(Int,Int) -- matrix dimensions (rows, columns)+ }+ deriving Show --- A randomly generated matrix of given size----{-# INLINE randomCSRMatrix #-}-randomCSRMatrix- :: (PrimMonad m, Variate a, Num a, Unbox a)- => Gen (PrimState m)- -> Int- -> Int- -> m (CSRMatrix a)-randomCSRMatrix gen rows cols = do- segd <- randomVectorR ( 0, fromIntegral cols-1) gen rows- let nnz = fromIntegral $ V.sum segd- inds <- randomVectorR ( 0, fromIntegral cols-1) gen nnz- vals <- randomVectorR (-1,1) gen nnz- return (segd, V.zip inds vals, cols)+nnz :: Storable a => CSRMatrix a -> Int+nnz = S.length . csr_values +rows :: CSRMatrix a -> Int+rows = fst . csr_dim -{-# INLINE randomVectorR #-}-randomVectorR- :: (PrimMonad m, Variate a, Unbox a)- => (a, a)- -> Gen (PrimState m)- -> Int- -> m (Vector a)-randomVectorR r g n = V.replicateM n (uniformR r g)+columns :: CSRMatrix a -> Int+columns = snd . csr_dim --- Read elements into unboxed arrays, convert to zero-indexed compressed sparse--- row format.+-- Convert data read from MatrixMarket format into compressed-sparse-row format+-- with zero-based indexing. ---{-# INLINE csr #-}-csr :: forall a. (Fractional a, Unbox a)- => (Int,Int)- -> Int- -> [(Int32,Int32,a)]- -> IO (Vector Int32, Vector (Int32,a), Int)-csr (m,_n) l elems = do- mu <- M.new l :: IO (M.IOVector (Int32,Int32,a))+-- Note that for [Skew-]Symmetric and Hermitian matrices, only the lower+-- triangle is stored in the file. For those cases this routine fills in the+-- upper triangle positions as well, so that the returned CSR matrix is in+-- general format.+--+matrixToCSR+ :: GenIO+ -> Matrix Scientific+ -> IO (CSRMatrix Double)+matrixToCSR _ (RMatrix dim n structure entries)+ = return+ $ case structure of+ General -> toCSR dim n+ $ flip map entries+ $ \(r,c,v) -> (fromIntegral (r-1), fromIntegral (c-1), toRealFloat v)+ _ -> toCSR dim (n*2)+ $ flip concatMap entries+ $ \(r,c,v) -> let v' = toRealFloat v+ r' = fromIntegral (r-1)+ c' = fromIntegral (c-1)+ in+ if r' == c' then [(r',c',v')]+ else [(r',c',v'), (c',r',v')] - let goe :: Int -> [(Int32,Int32,a)] -> IO ()- goe _ [] = return ()- goe !n (x:xs) = let (i,j,v) = x in M.unsafeWrite mu n (i-1,j-1,v) >> goe (n+1) xs- goe 0 elems+matrixToCSR gen (PatternMatrix dim n structure entries)+ = case structure of+ General -> fmap (toCSR dim n)+ $ forM' entries+ $ \(r,c) -> let r' = fromIntegral (r-1)+ c' = fromIntegral (c-1)+ in do+ v <- uniform gen+ return (r', c', v)+ _ -> fmap (toCSR dim (n*2))+ $ fmap concat+ $ forM' entries+ $ \(r,c) -> let r' = fromIntegral (r-1)+ c' = fromIntegral (c-1)+ in do+ v <- uniform gen+ u <- uniform gen+ if r' == c' then return [(r',c',v)]+ else return [(r',c',v), (c',r',u)] - let cmp (x1,y1,_) (x2,y2,_) | x1 == x2 = compare y1 y2- | otherwise = compare x1 x2- V.sortBy cmp mu+matrixToCSR _ CMatrix{} = error "matrixToCSR: complex matrices not supported"+matrixToCSR _ IntMatrix{} = error "matrixToCSR: integer matrices not supported" - (i,j,v) <- V.unzip3 `fmap` V.unsafeFreeze mu- mseg <- M.new m - let gos :: Int -> Vector Int32 -> IO (Vector Int32)- gos !n rows- | n >= m = V.unsafeFreeze mseg- | otherwise = let (s,ss) = V.span (== fromIntegral n) rows- in M.unsafeWrite mseg n (fromIntegral $ V.length s) >> gos (n+1) ss+-- Convert the given list of (row index, column index, value) triples into a CSR+-- matrix representation.+--+{-# INLINE toCSR #-}+toCSR :: (Int,Int) -- matrix dimensions+ -> Int -- #non-zero elements (hint)+ -> [(Int32,Int32,Double)] -- (row,column,value)+ -> CSRMatrix Double+toCSR dim@(r,_) n entries =+ let cmp (r1,c1,_) (r2,c2,_)+ | r1 == r2 = compare c1 c2+ | otherwise = compare r1 r2 - seg <- gos 0 i- return (seg , V.zip j v, _n)+ sorted = U.create $ do+ x <- U.unsafeThaw (U.fromListN n entries)+ V.sortBy cmp x+ return x + (rx,ix,vs) = U.unzip3 sorted+ segd_len = S.unfoldrN r (\v -> if U.null v+ then Nothing+ else let (h,t) = U.span (== U.unsafeHead v) v+ in Just (fromIntegral (U.length h), t)) rx + segd_off = S.scanl (+) 0 segd_len+ in+ CSRMatrix { csr_segd_length = segd_len+ , csr_segd_offset = segd_off+ , csr_indices = S.convert ix+ , csr_values = S.convert vs+ , csr_dim = dim+ }++ -- Lazier versions of things in Control.Monad -- sequence' :: [IO a] -> IO [a]@@ -107,4 +130,7 @@ mapM' :: (a -> IO b) -> [a] -> IO [b] mapM' f as = sequence' (map f as)++forM' :: [a] -> (a -> IO b) -> IO [b]+forM' = flip mapM'
− examples/smvm/MatrixMarket.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}--module MatrixMarket (Matrix(..), readMatrix) where--import Control.Applicative hiding ( many )--import Data.Int-import Data.Complex-import Data.Attoparsec.ByteString.Char8-import Data.ByteString.Lex.Fractional-import qualified Data.Attoparsec.Lazy as L-import qualified Data.ByteString.Lazy as L----- | Specifies the element type. Pattern matrices do not have any elements,--- only indices, and only make sense for coordinate matrices and vectors.----data Field = Real | Complex | Integer | Pattern- deriving (Eq, Show)---- | Specifies either sparse or dense storage. In sparse (\"coordinate\")--- storage, elements are given in (i,j,x) triplets for matrices (or (i,x) for--- vectors). Indices are 1-based, so that A(1,1) is the first element of a--- matrix, and x(1) is the first element of a vector.------ In dense (\"array\") storage, elements are given in column-major order.------ In both cases, each element is given on a separate line.----data Format = Coordinate | Array- deriving (Eq, Show)---- | Specifies any special structure in the matrix. For symmetric and hermition--- matrices, only the lower-triangular part of the matrix is given. For skew--- matrices, only the entries below the diagonal are stored.----data Structure = General | Symmetric | Hermitian | Skew- deriving (Eq, Show)----- We really want a type parameter to Matrix, but I think that requires some--- kind of dynamic typing so that we can determine (a ~ Integral) or (a ~--- RealFloat), and so forth, depending on the file being read. This will do for--- our purposes...------ Format is: (rows,columns) nnz [(row,column,value)]----data Matrix- = PatternMatrix (Int,Int) Int [(Int32,Int32)]- | IntMatrix (Int,Int) Int [(Int32,Int32,Int)]- | RealMatrix (Int,Int) Int [(Int32,Int32,Float)]- | ComplexMatrix (Int,Int) Int [(Int32,Int32,Complex Float)]- deriving Show-------------------------------------------------------------------------------------- Combinators-----------------------------------------------------------------------------------comment :: Parser ()-comment = char '%' *> skipWhile (not . eol) *> endOfLine- where- eol w = w `elem` ("\n\r" :: String)--floating :: Fractional a => Parser a-floating = do- mv <- readDecimal <$> (skipSpace *> takeTill isSpace) -- readDecimal does the fancy stuff- case mv of- Just (v,_) -> return v- Nothing -> fail "floating-point number"--integral :: Integral a => Parser a-integral = skipSpace *> decimal--format :: Parser Format-format = string "coordinate" *> pure Coordinate- <|> string "array" *> pure Array- <?> "matrix format"--field :: Parser Field-field = string "real" *> pure Real- <|> string "complex" *> pure Complex- <|> string "integer" *> pure Integer- <|> string "pattern" *> pure Pattern- <?> "matrix field"--structure :: Parser Structure-structure = string "general" *> pure General- <|> string "symmetric" *> pure Symmetric- <|> string "hermitian" *> pure Hermitian- <|> string "skew-symmetric" *> pure Skew- <?> "matrix structure"--header :: Parser (Format,Field,Structure)-header = string "%%MatrixMarket matrix"- >> (,,) <$> (skipSpace *> format)- <*> (skipSpace *> field)- <*> (skipSpace *> structure)- <* endOfLine- <?> "MatrixMarket header"--extent :: Parser (Int,Int,Int)-extent = do- [m,n,l] <- skipWhile isSpace *> count 3 integral <* endOfLine- return (m,n,l)--line :: Integral i => Parser a -> Parser (i,i,a)-line f = (,,) <$> integral- <*> integral- <*> f- <* endOfLine------------------------------------------------------------------------------------- Matrix Market-----------------------------------------------------------------------------------matrix :: Parser Matrix-matrix = do- (_,t,_) <- header- (m,n,l) <- skipMany comment *> extent- case t of- Real -> RealMatrix (m,n) l `fmap` many1 (line floating)- Complex -> ComplexMatrix (m,n) l `fmap` many1 (line ((:+) <$> floating <*> floating))- Integer -> IntMatrix (m,n) l `fmap` many1 (line integral)- Pattern -> PatternMatrix (m,n) l `fmap` many1 ((,) <$> integral <*> integral)---readMatrix :: FilePath -> IO Matrix-readMatrix file = do- chunks <- L.readFile file- case L.parse matrix chunks of- L.Fail _ _ msg -> error $ file ++ ": " ++ msg- L.Done _ mtx -> return mtx-
examples/smvm/SMVM.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,7 +14,7 @@ type SparseMatrix e = (Segments Int32, SparseVector e) -smvm :: (Elt a, IsNum a) => Acc (SparseMatrix a) -> Acc (Vector a) -> Acc (Vector a)+smvm :: A.Num a => Acc (SparseMatrix a) -> Acc (Vector a) -> Acc (Vector a) smvm smat vec = let (segd, svec) = unlift smat (inds, vals) = A.unzip svec
+ examples/tunnel/Config.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}++module Config where++import Data.Label+import System.Console.GetOpt++data Config = Config+ {+ _configWidth :: Int+ , _configHeight :: Int+ , _configZoom :: Int+ }+ deriving Show++$(mkLabels [''Config])++defaults :: Config+defaults = Config+ { _configWidth = 320+ , _configHeight = 240+ , _configZoom = 2+ }++options :: [OptDescr (Config -> Config)]+options =+ [ Option [] ["width"] (ReqArg (set configWidth . read) "INT") "visualisation size (320)"+ , Option [] ["height"] (ReqArg (set configHeight . read) "INT") "visualisation size (240)"+ , Option [] ["zoom"] (ReqArg (set configZoom . read) "INT") "pixel replication factor (2)"+ ]++header :: [String]+header =+ [ "accelerate-tunnel (c) [2016] The Accelerate Team"+ , ""+ , "Usage: accelerate-tunnel [OPTIONS]"+ , ""+ ]++footer :: [String]+footer = [ "" ]+
+ examples/tunnel/Main.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ViewPatterns #-}+-- Example of the slit-scan effect.+-- You must provide your own Doctor Who theme music.+--+-- Based on code from:+-- http://roy.red/slitscan-.html+--++module Main where++import Config++import Data.Label++import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A++import Data.Array.Accelerate.Linear.Metric+import Data.Array.Accelerate.Linear.Vector+import Data.Array.Accelerate.Linear.V2+import Data.Array.Accelerate.Linear.V3++import Data.Array.Accelerate.Control.Lens ( (^.) )++import Graphics.Gloss.Accelerate.Raster.Field hiding ( clamp )++import Prelude ( IO, fmap )+++-- Fractional part of a number+--+fract :: Exp Float -> Exp Float+fract x = x - toFloating (A.floor x :: Exp Int)++clamp :: Exp Float -> Exp Float -> Exp Float -> Exp Float+clamp v inf sup = inf `A.max` v `A.min` sup++-- Interpolation using Hermite polynomial after clamping values to a range.+--+smoothstep :: Exp Float -> Exp Float -> Exp Float -> Exp Float+smoothstep edge0 edge1 x =+ let t = clamp ((x-edge0) / (edge1-edge0)) 0.0 1.0+ in t*t*(3 - 2*t)++rand2 :: Exp (V2 Float) -> Exp (V2 Float)+rand2 p =+ let x = constant (V2 127.1 311.7)+ y = constant (V2 269.5 183.3)+ q = lift $ V2 (dot p x) (dot p y)+ in+ lift1 (fmap fract :: V2 (Exp Float) -> V2 (Exp Float))+ $ sin(q) * constant 43758.5453++rand1 :: Exp (V2 Float) -> Exp Float+rand1 p =+ let z = constant (V2 419.2 371.9)+ in fract (sin (dot p z) * 833458.57832)+++-- Procedural pattern generation that generalise cell-noise, perlin-noise, and+-- voronoi tessellation.+--+-- http://iquilezles.org/www/articles/voronoise/voronoise.htm+-- https://www.shadertoy.com/view/Xd23Dh+--+voronoise :: Exp (V2 Float) -> Exp Float -> Exp Float -> Exp Float+voronoise xy irregular smoothness =+ let+ cell = lift1 (fmap A.toFloating :: V2 (Exp Int) -> V2 (Exp Float))+ $ lift1 (fmap A.floor :: V2 (Exp Float) -> V2 (Exp Int)) xy+ cellOffset = lift1 (fmap fract :: V2 (Exp Float) -> V2 (Exp Float)) xy+ sharpness = 1.0 + 63.0 * ((1.0-smoothness) ** 4.0)++ -- -- Sample the surrounding cells from [-2..2].+ -- samples = P.foldr1 (+) [ sample i j | i <- [-2..2], j <- [-2..2] ]+ samples =+ iterFromTo (-2) 2 0 $ \i x ->+ iterFromTo (-2) 2 x $ \j y ->+ y + sample i j++ sample :: Exp Int -> Exp Int -> Exp (V2 Float)+ sample i j =+ let+ samplePos = lift $ V2 (A.fromIntegral i) (A.fromIntegral j)++ -- Centre of the cell is not in the centre of the block for+ -- irregular noise. All coordinates are in block-space coordinates;+ -- 0 is the current block, 1 is one block over, etc...+ centre = rand2 (cell + samplePos) ^* irregular+ centreDist = norm (samplePos - cellOffset + centre)++ -- High sharpness = only extreme values = hard borders = 64+ -- Low sharpness = no extreme values = soft borders = 1+ det = (1.0 - smoothstep 0.0 1.414 centreDist) ** sharpness++ -- A different "colour" (shade of grey) for each cell+ colour = rand1 (cell + samplePos)+ in+ lift $ V2 (colour * det) det+ in+ samples^._x / samples^._y+++iterFromTo :: Elt a => Exp Int -> Exp Int -> Exp a -> (Exp Int -> Exp a -> Exp a) -> Exp a+iterFromTo inf sup x body+ = A.snd+ $ A.while (\ix -> A.fst ix <= sup)+ (\ix -> A.lift (A.fst ix + 1, A.uncurry body ix))+ (lift (inf, x))++v2OfPoint :: Exp Point -> Exp (V2 Float)+v2OfPoint p =+ let (x,y) = xyOfPoint p+ in lift (V2 x y)++-- The time vortex+--+tunnel :: Exp Float -> Exp Point -> Exp Colour+tunnel time (v2OfPoint -> pt1) =+ let+ rInv = 1.0 / norm pt2+ pt2 = 1.2 * pt1+ pt3 = pt2 ^* rInv - lift (V2 (rInv + 2.0 * mod' time 6000.0) 0.0)+ c1 = constant (V3 0.659 0.772 1.000) -- slate-blue-ish+ c2 = c1 ^* ( (voronoise (5.0*pt3) 1.0 1.0) + 0.240*rInv )+ --+ V3 r g b = unlift c2+ in+ rgba r g b 1.0+++main :: IO ()+main = do+ beginMonitoring+ (conf, opts, rest) <- parseArgs options defaults header footer++ let width = get configWidth conf+ height = get configHeight conf+ zoom = get configZoom conf+ backend = get optBackend opts++ frame = run1 backend+ $ makeField width height (\time -> tunnel (the time))++ runBenchmarks opts rest+ [ bench "tunnel" $ whnf frame (A.fromList Z [1.0]) ]++ runInteractive opts rest+ $ animateFieldWith+ (run1 backend)+ (InWindow "Tunnel" (width * zoom, height * zoom) (10, 10))+ (zoom, zoom)+ tunnel+
lib/Data/Array/Accelerate/Examples/Internal.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} -- | -- Module: : Data.Array.Accelerate.Examples.Internal -- Copyright : [2014] Trevor L. McDonell
lib/Data/Array/Accelerate/Examples/Internal/Backend.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} -- |@@ -16,21 +17,22 @@ module Data.Array.Accelerate.Examples.Internal.Backend where +import Prelude as P import Data.Label import System.Console.GetOpt import Data.Array.Accelerate import qualified Data.Array.Accelerate as A import qualified Data.Array.Accelerate.Interpreter as Interp-#ifdef ACCELERATE_CUDA_BACKEND-import qualified Data.Array.Accelerate.CUDA as CUDA-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND import qualified Data.Array.Accelerate.LLVM.Native as CPU #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND import qualified Data.Array.Accelerate.LLVM.PTX as PTX #endif+#ifdef ACCELERATE_CUDA_BACKEND+import qualified Data.Array.Accelerate.CUDA as CUDA+#endif #ifdef ACCELERATE_CILK_BACKEND import qualified Data.Array.Accelerate.Cilk as Cilk #endif@@ -38,60 +40,78 @@ -- | Execute Accelerate expressions --+{-# INLINE run #-} run :: Arrays a => Backend -> Acc a -> a run Interpreter = Interp.run-#ifdef ACCELERATE_CUDA_BACKEND-run CUDA = CUDA.run-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND run CPU = CPU.run #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND run PTX = PTX.run #endif+#ifdef ACCELERATE_CUDA_BACKEND+run CUDA = CUDA.run+#endif #ifdef ACCELERATE_CILK_BACKEND run Cilk = Cilk.run #endif +{-# INLINE run1 #-} run1 :: (Arrays a, Arrays b) => Backend -> (Acc a -> Acc b) -> a -> b run1 Interpreter f = Interp.run1 f-#ifdef ACCELERATE_CUDA_BACKEND-run1 CUDA f = CUDA.run1 f-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND run1 CPU f = CPU.run1 f #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND run1 PTX f = PTX.run1 f #endif+#ifdef ACCELERATE_CUDA_BACKEND+run1 CUDA f = CUDA.run1 f+#endif #ifdef ACCELERATE_CILK_BACKEND run1 Cilk f = Cilk.run . f . use #endif +{-# INLINE run2 #-} run2 :: (Arrays a, Arrays b, Arrays c) => Backend -> (Acc a -> Acc b -> Acc c) -> a -> b -> c-run2 backend f x y = run1 backend (A.uncurry f) (x,y)+run2 backend f x y = go (x,y)+ where+ !go = run1 backend (A.uncurry f) +{-# INLINE run3 #-}+run3 :: (Arrays a, Arrays b, Arrays c, Arrays d) => Backend -> (Acc a -> Acc b -> Acc c -> Acc d) -> a -> b -> c -> d+run3 backend f x y z = go (x,y,z)+ where+ !go = run1 backend (\t -> let (a,b,c) = unlift t in f a b c) ++{-# INLINE run4 #-}+run4 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) => Backend -> (Acc a -> Acc b -> Acc c -> Acc d -> Acc e) -> a -> b -> c -> d -> e+run4 backend f x y z w = go (x,y,z,w)+ where+ !go = run1 backend (\t -> let (a,b,c,d) = unlift t in f a b c d)++ -- | The set of backends available to execute the program. -- data Backend = Interpreter-#ifdef ACCELERATE_CUDA_BACKEND- | CUDA-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND | CPU #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND | PTX #endif+#ifdef ACCELERATE_CUDA_BACKEND+ | CUDA+#endif #ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND | Multi #endif #ifdef ACCELERATE_CILK_BACKEND | Cilk #endif- deriving (Eq, Bounded)+ deriving (P.Eq, P.Enum, P.Bounded) -- The choice of show instance is important because this will be used to@@ -99,15 +119,15 @@ -- instance Show Backend where show Interpreter = "interpreter"-#ifdef ACCELERATE_CUDA_BACKEND- show CUDA = "cuda"-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND show CPU = "llvm-cpu" #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND- show PTX = "llvm-gpu"+ show PTX = "llvm-ptx" #endif+#ifdef ACCELERATE_CUDA_BACKEND+ show CUDA = "cuda"+#endif #ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND show Multi = "llvm-multi" #endif@@ -116,15 +136,14 @@ #endif --- The default backend to use. Currently the only complete accelerated backend--- is CUDA, so default to that if it is available.+-- The default backend to use. Use one of the accelerated backends whenever+-- available. -- defaultBackend :: Backend-#ifdef ACCELERATE_CUDA_BACKEND-defaultBackend = CUDA-#else-defaultBackend = maxBound-#endif+defaultBackend =+ case maxBound of+ Interpreter -> Interpreter+ _ -> succ Interpreter -- The set of available backnds. This will be used for both the command line@@ -136,11 +155,6 @@ (NoArg (set optBackend Interpreter)) "reference implementation (sequential)" -#ifdef ACCELERATE_CUDA_BACKEND- , Option [] [show CUDA]- (NoArg (set optBackend CUDA))- "implementation for NVIDIA GPUs (parallel)"-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND , Option [] [show CPU] (NoArg (set optBackend CPU))@@ -151,6 +165,11 @@ (NoArg (set optBackend PTX)) "LLVM based implementation for NVIDIA GPUs (parallel)" #endif+#ifdef ACCELERATE_CUDA_BACKEND+ , Option [] [show CUDA]+ (NoArg (set optBackend CUDA))+ "CUDA based implementation for NVIDIA GPUs (parallel)"+#endif #ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND , Option [] [show Multi] (NoArg (set optBackend Multi))@@ -179,18 +198,24 @@ -- non-thread-safe backend (perhaps it requires exclusive access to the -- accelerator board) should specify `Just 1`. --+-- Both the LLVM-CPU and LLVM-PTX backends are safe to run concurrently given+-- the same execution context. Although this results in over-subscription,+-- particularly for the CPU backend, it still improves performance because the+-- majority of the time is spent in the reference implementation / checking+-- results, so running multiple tests concurrently is still useful.+-- concurrentBackends :: Backend -> Maybe Int concurrentBackends Interpreter = Nothing-#ifdef ACCELERATE_CUDA_BACKEND-concurrentBackends CUDA = Nothing -- not quite true! D:-#endif #ifdef ACCELERATE_LLVM_NATIVE_BACKEND-concurrentBackends CPU = Just 1+concurrentBackends CPU = Nothing #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND-concurrentBackends PTX = Nothing -- ???+concurrentBackends PTX = Nothing #endif+#ifdef ACCELERATE_CUDA_BACKEND+concurrentBackends CUDA = Just 1 -- not thread safe+#endif #ifdef ACCELERATE_CILK_BACKEND-concurrentBackends Cilk = Just 1+concurrentBackends Cilk = Just 1 -- not thread safe #endif
lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | -- Module: : Data.Array.Accelerate.Examples.Internal.Criterion -- Copyright : [2014] Trevor L. McDonell@@ -64,7 +65,11 @@ exists <- doesFileExist rawFile if exists then either fail return =<< do+#if MIN_VERSION_criterion(1,1,1)+ rs <- readRecords rawFile+#else rs <- readReports rawFile+#endif case get rawDataFile crit of Nothing -> removeFile rawFile >> return rs Just _ -> return rs
lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} -- | -- Module: : Data.Array.Accelerate.Examples.Internal.Monitoring -- Copyright : [2014] Trevor L. McDonell@@ -17,10 +16,7 @@ ) where -#ifdef ACCELERATE_ENABLE_EKG-import Control.Monad-import System.Remote.Monitoring-#endif+import qualified Data.Array.Accelerate.Debug as Debug -- | Launch a monitoring server that will collect statistics on the running@@ -28,11 +24,12 @@ -- program will need to be run with the RTS option -T. -- beginMonitoring :: IO ()+beginMonitoring = #ifdef ACCELERATE_ENABLE_EKG-beginMonitoring = do- putStrLn "EKG monitor started at: http://localhost:8000\n"- void $ forkServer "localhost" 8000+ if Debug.monitoringIsEnabled+ then Debug.beginMonitoring+ else putStrLn "Monitoring is not enabled. Recompile package 'accelerate' with flag '-fekg'" #else-beginMonitoring = return ()+ return () #endif
lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs view
@@ -27,6 +27,7 @@ ) where +import Data.Array.Accelerate.Debug ( accInit ) import Data.Array.Accelerate.Examples.Internal.Backend import qualified Data.Array.Accelerate.Examples.Internal.Criterion.Config as Criterion import qualified Data.Array.Accelerate.Examples.Internal.TestFramework.Config as TestFramework@@ -36,6 +37,7 @@ import Data.Monoid import Control.Monad import System.Exit+import System.Environment import System.Console.GetOpt import Text.PrettyPrint.ANSI.Leijen import Prelude@@ -209,9 +211,11 @@ -> config -- ^ user default option set -> [String] -- ^ header text -> [String] -- ^ footer text- -> [String] -- ^ command line arguments -> IO (config, Options, [String])-parseArgs programOptions programConfig header footer args =+parseArgs programOptions programConfig header footer = do+ accInit+ args <- getArgs+ let -- The option "--list" is ambiguous. It is handled by criterion only when -- benchmarks are being run, but if passed to test framework during option@@ -221,7 +225,7 @@ let (x, y) = span (/= "--") args (ls, x') = partition (== "--list") x in- (x', ls ++ y)+ (x', ls ++ dropWhile (== "--") y) criterionOptions = stripShortOpts $ Criterion.defaultOptions ++ Criterion.extraOptions testframeworkOptions = stripShortOpts $ TestFramework.defaultOptions@@ -242,7 +246,6 @@ , section "Test-Framework options:" testframeworkOptions ] - in do -- In the first round process options for the user program. Processing the -- user options first means that we can still handle any short or long options -- that take arguments but which were not joined with an equals sign; e.g.@@ -275,7 +278,7 @@ -- (c4,u4) <- case getOpt' Permute testframeworkOptions u3 of (opts,_,u,[]) | Just os <- sequence opts- -> return (mconcat os, u)+ -> return (mconcat (TestFramework.defaultConfig (_optBackend c2) : os), u) (_,_,_,err) -> error (helpMsg err) -- Show the help message if that was requested. This is done last so that the
lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs view
@@ -33,12 +33,12 @@ -- | Uniformly distributed random variates. ---uniform :: (Shape sh, Elt e, Variate e) => sh :~> e+uniform :: Variate e => sh :~> e uniform _ = R.uniform -- | Uniformly distributed random variates in a given range. ---uniformR :: (Shape sh, Elt e, Variate e) => (e, e) -> sh :~> e+uniformR :: Variate e => (e, e) -> sh :~> e uniformR bounds _ = R.uniformR bounds
lib/Data/Array/Accelerate/Examples/Internal/Similar.hs view
@@ -18,10 +18,16 @@ ) where -import Prelude as P+import Data.Array.Accelerate ( Z(..), (:.)(..), Array, Shape, arrayShape, toList ) import Data.Complex+import Data.Int+import Data.Word import Foreign.C.Types-import Data.Array.Accelerate+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4+import Prelude as P -- A class of things that support almost-equality, so that we can disregard@@ -74,6 +80,18 @@ (x1, x2, x3, x4, x5, x6, x7, x8, x9) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 +instance Similar a => Similar (V1 a) where+ V1 x ~= V1 y = x ~= y++instance Similar a => Similar (V2 a) where+ V2 x1 x2 ~= V2 y1 y2 = x1 ~= y1 && x2 ~= y2++instance Similar a => Similar (V3 a) where+ V3 x1 x2 x3 ~= V3 y1 y2 y3 = x1 ~= y1 && x2 ~= y2 && x3 ~= y3++instance Similar a => Similar (V4 a) where+ V4 x1 x2 x3 x4 ~= V4 y1 y2 y3 y4 = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4+ instance Similar Z instance (Eq sh, Eq sz) => Similar (sh:.sz) @@ -106,7 +124,7 @@ instance Similar CFloat where (~=) = absRelTol 0.00005 0.005 instance Similar CDouble where (~=) = absRelTol 0.00005 0.005 -instance (Similar e, RealFloat e) => Similar (Complex e) where+instance Similar e => Similar (Complex e) where (r1 :+ i1) ~= (r2 :+ i2) = r1 ~= r2 && i1 ~= i2 @@ -114,23 +132,16 @@ -- relTol :: (Fractional a, Ord a) => a -> a -> a -> Bool -- relTol epsilon x y = abs ((x-y) / (x+y+epsilon)) < epsilon -{-# INLINE absRelTol #-}-absRelTol :: (RealFloat a, Ord a) => a -> a -> a -> a -> Bool+{-# INLINEABLE absRelTol #-}+absRelTol :: RealFloat a => a -> a -> a -> a -> Bool absRelTol epsilonAbs epsilonRel u v | isInfinite u && isInfinite v = True- | P.isNaN u- && P.isNaN v = True+ | isNaN u+ && isNaN v = True | abs (u-v) < epsilonAbs = True | abs u > abs v = abs ((u-v) / u) < epsilonRel | otherwise = abs ((v-u) / v) < epsilonRel--instance (Eq e, Eq sh, Shape sh) => Eq (Array sh e) where- a1 == a2 = arrayShape a1 == arrayShape a2- && toList a1 == toList a2-- a1 /= a2 = arrayShape a1 /= arrayShape a2- || toList a1 /= toList a2 instance (Similar e, Eq sh, Shape sh) => Similar (Array sh e) where a1 ~= a2 = arrayShape a1 == arrayShape a2
lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs view
@@ -20,20 +20,26 @@ import Data.Monoid import Data.Label import Data.Label.Derive-import Test.Framework ( RunnerOptions, RunnerOptions', optionsDescription, SuppliedRunnerOptions )+import Test.Framework ( RunnerOptions, RunnerOptions', TestOptions', optionsDescription, SuppliedRunnerOptions ) import System.Console.GetOpt import Prelude import Data.Array.Accelerate.Examples.Internal.Backend $(mkLabelsNamed id [''RunnerOptions'])+$(mkLabelsNamed id [''TestOptions']) type Config = RunnerOptions defaultConfig :: Backend -> Config-defaultConfig b = set ropt_threads (concurrentBackends b) mempty+defaultConfig b+ = set ropt_threads (concurrentBackends b)+ $ set ropt_test_options+ ( Just $ set topt_maximum_generated_tests (Just 1000)+ $ set topt_maximum_unsuitable_generated_tests (Just 1000)+ $ mempty)+ $ mempty defaultOptions :: [OptDescr SuppliedRunnerOptions] defaultOptions = optionsDescription-
lib/Data/Array/Accelerate/Examples/Internal/Util.hs view
@@ -8,26 +8,34 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.Examples.Internal.Util (-- -- * Miscellaneous- showFFloatSIBase,--) where+module Data.Array.Accelerate.Examples.Internal.Util+ where import Numeric import Data.List +import Data.Array.Accelerate as A ( Z(..), Elt, Scalar, fromList )+import Prelude as P ++infixr 9 $$+($$) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+($$) g f x y = g (f x y)+++scalar :: Elt a => a -> Scalar a+scalar x = fromList Z [x]++ -- | Show a floating point number in scientific notation with a specific base. ---showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS+showFFloatSIBase :: P.RealFloat a => Maybe Int -> a -> a -> ShowS showFFloatSIBase p b n = showString . nubBy (\x y -> x == ' ' && y == ' ') $ showFFloat p n' [ ' ', si_unit ] where- n' = n / (b ^^ (pow-4))- pow = max 0 . min 8 . (+) 4 . floor $ logBase b n- si_unit = "pnµm kMGT" !! pow+ n' = n / (b P.^^ (pow-4))+ pow = P.max 0 . P.min 8 . (+) 4 . P.floor $ P.logBase b n+ si_unit = "pnµm kMGT" P.!! pow