diff --git a/accelerate-examples.cabal b/accelerate-examples.cabal --- a/accelerate-examples.cabal +++ b/accelerate-examples.cabal @@ -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 diff --git a/data/hashcat/README.md b/data/hashcat/README.md deleted file mode 100644 --- a/data/hashcat/README.md +++ /dev/null @@ -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 - diff --git a/examples/canny/README.md b/examples/canny/README.md new file mode 100644 --- /dev/null +++ b/examples/canny/README.md @@ -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 + diff --git a/examples/canny/src-acc/Canny.hs b/examples/canny/src-acc/Canny.hs --- a/examples/canny/src-acc/Canny.hs +++ b/examples/canny/src-acc/Canny.hs @@ -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 diff --git a/examples/canny/src-acc/Main.hs b/examples/canny/src-acc/Main.hs --- a/examples/canny/src-acc/Main.hs +++ b/examples/canny/src-acc/Main.hs @@ -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 diff --git a/examples/crystal/Main.hs b/examples/crystal/Main.hs --- a/examples/crystal/Main.hs +++ b/examples/crystal/Main.hs @@ -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 diff --git a/examples/fft/src-acc/FFT.hs b/examples/fft/src-acc/FFT.hs --- a/examples/fft/src-acc/FFT.hs +++ b/examples/fft/src-acc/FFT.hs @@ -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 diff --git a/examples/fft/src-acc/HighPass.hs b/examples/fft/src-acc/HighPass.hs --- a/examples/fft/src-acc/HighPass.hs +++ b/examples/fft/src-acc/HighPass.hs @@ -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 diff --git a/examples/fft/src-acc/Main.hs b/examples/fft/src-acc/Main.hs --- a/examples/fft/src-acc/Main.hs +++ b/examples/fft/src-acc/Main.hs @@ -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 ] diff --git a/examples/fluid/README.md b/examples/fluid/README.md new file mode 100644 --- /dev/null +++ b/examples/fluid/README.md @@ -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: + + +An implementation using Repa can be found as part of the gloss-examples package. + + + diff --git a/examples/fluid/src-acc/Config.hs b/examples/fluid/src-acc/Config.hs --- a/examples/fluid/src-acc/Config.hs +++ b/examples/fluid/src-acc/Config.hs @@ -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) diff --git a/examples/fluid/src-acc/Event.hs b/examples/fluid/src-acc/Event.hs --- a/examples/fluid/src-acc/Event.hs +++ b/examples/fluid/src-acc/Event.hs @@ -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. -- diff --git a/examples/fluid/src-acc/Fluid.hs b/examples/fluid/src-acc/Fluid.hs --- a/examples/fluid/src-acc/Fluid.hs +++ b/examples/fluid/src-acc/Fluid.hs @@ -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) diff --git a/examples/fluid/src-acc/Main.hs b/examples/fluid/src-acc/Main.hs --- a/examples/fluid/src-acc/Main.hs +++ b/examples/fluid/src-acc/Main.hs @@ -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 diff --git a/examples/fluid/src-acc/Type.hs b/examples/fluid/src-acc/Type.hs --- a/examples/fluid/src-acc/Type.hs +++ b/examples/fluid/src-acc/Type.hs @@ -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 diff --git a/examples/fluid/src-acc/World.hs b/examples/fluid/src-acc/World.hs --- a/examples/fluid/src-acc/World.hs +++ b/examples/fluid/src-acc/World.hs @@ -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 diff --git a/examples/hashcat/Config.hs b/examples/hashcat/Config.hs --- a/examples/hashcat/Config.hs +++ b/examples/hashcat/Config.hs @@ -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" ] diff --git a/examples/hashcat/MD5.hs b/examples/hashcat/MD5.hs --- a/examples/hashcat/MD5.hs +++ b/examples/hashcat/MD5.hs @@ -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 - diff --git a/examples/hashcat/Main.hs b/examples/hashcat/Main.hs --- a/examples/hashcat/Main.hs +++ b/examples/hashcat/Main.hs @@ -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 diff --git a/examples/hashcat/README.md b/examples/hashcat/README.md new file mode 100644 --- /dev/null +++ b/examples/hashcat/README.md @@ -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 + diff --git a/examples/kmeans/Kmeans.hs b/examples/kmeans/Kmeans.hs --- a/examples/kmeans/Kmeans.hs +++ b/examples/kmeans/Kmeans.hs @@ -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 diff --git a/examples/kmeans/Main.hs b/examples/kmeans/Main.hs --- a/examples/kmeans/Main.hs +++ b/examples/kmeans/Main.hs @@ -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 -- diff --git a/examples/kmeans/README.md b/examples/kmeans/README.md new file mode 100644 --- /dev/null +++ b/examples/kmeans/README.md @@ -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 + diff --git a/examples/mandelbrot/Config.hs b/examples/mandelbrot/Config.hs --- a/examples/mandelbrot/Config.hs +++ b/examples/mandelbrot/Config.hs @@ -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" , "" ] diff --git a/examples/mandelbrot/Main.hs b/examples/mandelbrot/Main.hs --- a/examples/mandelbrot/Main.hs +++ b/examples/mandelbrot/Main.hs @@ -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 diff --git a/examples/mandelbrot/Mandel.hs b/examples/mandelbrot/Mandel.hs --- a/examples/mandelbrot/Mandel.hs +++ b/examples/mandelbrot/Mandel.hs @@ -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: +-- -- -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 ---} diff --git a/examples/mandelbrot/README.md b/examples/mandelbrot/README.md new file mode 100644 --- /dev/null +++ b/examples/mandelbrot/README.md @@ -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 + diff --git a/examples/mandelbrot/World.hs b/examples/mandelbrot/World.hs --- a/examples/mandelbrot/World.hs +++ b/examples/mandelbrot/World.hs @@ -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) + ] diff --git a/examples/n-body/Common/Body.hs b/examples/n-body/Common/Body.hs --- a/examples/n-body/Common/Body.hs +++ b/examples/n-body/Common/Body.hs @@ -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 diff --git a/examples/n-body/Common/Type.hs b/examples/n-body/Common/Type.hs --- a/examples/n-body/Common/Type.hs +++ b/examples/n-body/Common/Type.hs @@ -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 diff --git a/examples/n-body/Common/Util.hs b/examples/n-body/Common/Util.hs deleted file mode 100644 --- a/examples/n-body/Common/Util.hs +++ /dev/null @@ -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) - diff --git a/examples/n-body/Common/World.hs b/examples/n-body/Common/World.hs --- a/examples/n-body/Common/World.hs +++ b/examples/n-body/Common/World.hs @@ -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 diff --git a/examples/n-body/Gloss/Draw.hs b/examples/n-body/Gloss/Draw.hs --- a/examples/n-body/Gloss/Draw.hs +++ b/examples/n-body/Gloss/Draw.hs @@ -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 diff --git a/examples/n-body/Main.hs b/examples/n-body/Main.hs --- a/examples/n-body/Main.hs +++ b/examples/n-body/Main.hs @@ -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 diff --git a/examples/n-body/Random/Position.hs b/examples/n-body/Random/Position.hs --- a/examples/n-body/Random/Position.hs +++ b/examples/n-body/Random/Position.hs @@ -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 diff --git a/examples/n-body/Solver/Naive1.hs b/examples/n-body/Solver/Naive1.hs --- a/examples/n-body/Solver/Naive1.hs +++ b/examples/n-body/Solver/Naive1.hs @@ -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 diff --git a/examples/n-body/Solver/Naive2.hs b/examples/n-body/Solver/Naive2.hs --- a/examples/n-body/Solver/Naive2.hs +++ b/examples/n-body/Solver/Naive2.hs @@ -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 diff --git a/examples/n-body/Test.hs b/examples/n-body/Test.hs --- a/examples/n-body/Test.hs +++ b/examples/n-body/Test.hs @@ -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))] diff --git a/examples/nofib/Config.hs b/examples/nofib/Config.hs --- a/examples/nofib/Config.hs +++ b/examples/nofib/Config.hs @@ -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 diff --git a/examples/nofib/Main.hs b/examples/nofib/Main.hs --- a/examples/nofib/Main.hs +++ b/examples/nofib/Main.hs @@ -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 diff --git a/examples/nofib/QuickCheck/Arbitrary/Array.hs b/examples/nofib/QuickCheck/Arbitrary/Array.hs --- a/examples/nofib/QuickCheck/Arbitrary/Array.hs +++ b/examples/nofib/QuickCheck/Arbitrary/Array.hs @@ -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 ] diff --git a/examples/nofib/QuickCheck/Arbitrary/Shape.hs b/examples/nofib/QuickCheck/Arbitrary/Shape.hs --- a/examples/nofib/QuickCheck/Arbitrary/Shape.hs +++ b/examples/nofib/QuickCheck/Arbitrary/Shape.hs @@ -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 diff --git a/examples/nofib/Test/Base.hs b/examples/nofib/Test/Base.hs --- a/examples/nofib/Test/Base.hs +++ b/examples/nofib/Test/Base.hs @@ -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 diff --git a/examples/nofib/Test/FFT.hs b/examples/nofib/Test/FFT.hs --- a/examples/nofib/Test/FFT.hs +++ b/examples/nofib/Test/FFT.hs @@ -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 diff --git a/examples/nofib/Test/Foreign/CUDA.hs b/examples/nofib/Test/Foreign/CUDA.hs --- a/examples/nofib/Test/Foreign/CUDA.hs +++ b/examples/nofib/Test/Foreign/CUDA.hs @@ -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 diff --git a/examples/nofib/Test/IO/Ptr.hs b/examples/nofib/Test/IO/Ptr.hs --- a/examples/nofib/Test/IO/Ptr.hs +++ b/examples/nofib/Test/IO/Ptr.hs @@ -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 diff --git a/examples/nofib/Test/IO/Vector.hs b/examples/nofib/Test/IO/Vector.hs --- a/examples/nofib/Test/IO/Vector.hs +++ b/examples/nofib/Test/IO/Vector.hs @@ -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 diff --git a/examples/nofib/Test/Imaginary/DotP.hs b/examples/nofib/Test/Imaginary/DotP.hs --- a/examples/nofib/Test/Imaginary/DotP.hs +++ b/examples/nofib/Test/Imaginary/DotP.hs @@ -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) diff --git a/examples/nofib/Test/Imaginary/SASUM.hs b/examples/nofib/Test/Imaginary/SASUM.hs --- a/examples/nofib/Test/Imaginary/SASUM.hs +++ b/examples/nofib/Test/Imaginary/SASUM.hs @@ -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 diff --git a/examples/nofib/Test/Imaginary/SAXPY.hs b/examples/nofib/Test/Imaginary/SAXPY.hs --- a/examples/nofib/Test/Imaginary/SAXPY.hs +++ b/examples/nofib/Test/Imaginary/SAXPY.hs @@ -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) diff --git a/examples/nofib/Test/Issues.hs b/examples/nofib/Test/Issues.hs --- a/examples/nofib/Test/Issues.hs +++ b/examples/nofib/Test/Issues.hs @@ -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 ] diff --git a/examples/nofib/Test/Issues/Issue102.hs b/examples/nofib/Test/Issues/Issue102.hs --- a/examples/nofib/Test/Issues/Issue102.hs +++ b/examples/nofib/Test/Issues/Issue102.hs @@ -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) diff --git a/examples/nofib/Test/Issues/Issue137.hs b/examples/nofib/Test/Issues/Issue137.hs --- a/examples/nofib/Test/Issues/Issue137.hs +++ b/examples/nofib/Test/Issues/Issue137.hs @@ -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)) diff --git a/examples/nofib/Test/Issues/Issue184.hs b/examples/nofib/Test/Issues/Issue184.hs --- a/examples/nofib/Test/Issues/Issue184.hs +++ b/examples/nofib/Test/Issues/Issue184.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue185.hs b/examples/nofib/Test/Issues/Issue185.hs --- a/examples/nofib/Test/Issues/Issue185.hs +++ b/examples/nofib/Test/Issues/Issue185.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue187.hs b/examples/nofib/Test/Issues/Issue187.hs --- a/examples/nofib/Test/Issues/Issue187.hs +++ b/examples/nofib/Test/Issues/Issue187.hs @@ -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) diff --git a/examples/nofib/Test/Issues/Issue228.hs b/examples/nofib/Test/Issues/Issue228.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue228.hs @@ -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 + diff --git a/examples/nofib/Test/Issues/Issue255.hs b/examples/nofib/Test/Issues/Issue255.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue255.hs @@ -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 () + diff --git a/examples/nofib/Test/Issues/Issue264.hs b/examples/nofib/Test/Issues/Issue264.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue264.hs @@ -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)) + diff --git a/examples/nofib/Test/Issues/Issue286.hs b/examples/nofib/Test/Issues/Issue286.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue286.hs @@ -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 + diff --git a/examples/nofib/Test/Issues/Issue287.hs b/examples/nofib/Test/Issues/Issue287.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue287.hs @@ -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 + diff --git a/examples/nofib/Test/Issues/Issue288.hs b/examples/nofib/Test/Issues/Issue288.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue288.hs @@ -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..]) + diff --git a/examples/nofib/Test/Issues/Issue362.hs b/examples/nofib/Test/Issues/Issue362.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Issues/Issue362.hs @@ -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) + diff --git a/examples/nofib/Test/Prelude.hs b/examples/nofib/Test/Prelude.hs --- a/examples/nofib/Test/Prelude.hs +++ b/examples/nofib/Test/Prelude.hs @@ -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 ] - diff --git a/examples/nofib/Test/Prelude/Backpermute.hs b/examples/nofib/Test/Prelude/Backpermute.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Backpermute.hs @@ -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 ] + diff --git a/examples/nofib/Test/Prelude/Filter.hs b/examples/nofib/Test/Prelude/Filter.hs --- a/examples/nofib/Test/Prelude/Filter.hs +++ b/examples/nofib/Test/Prelude/Filter.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/Fold.hs b/examples/nofib/Test/Prelude/Fold.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Fold.hs @@ -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 + diff --git a/examples/nofib/Test/Prelude/IndexSpace.hs b/examples/nofib/Test/Prelude/IndexSpace.hs deleted file mode 100644 --- a/examples/nofib/Test/Prelude/IndexSpace.hs +++ /dev/null @@ -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 - diff --git a/examples/nofib/Test/Prelude/Map.hs b/examples/nofib/Test/Prelude/Map.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Map.hs @@ -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 + diff --git a/examples/nofib/Test/Prelude/Mapping.hs b/examples/nofib/Test/Prelude/Mapping.hs deleted file mode 100644 --- a/examples/nofib/Test/Prelude/Mapping.hs +++ /dev/null @@ -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)) - diff --git a/examples/nofib/Test/Prelude/Permute.hs b/examples/nofib/Test/Prelude/Permute.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Permute.hs @@ -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 + diff --git a/examples/nofib/Test/Prelude/PrefixSum.hs b/examples/nofib/Test/Prelude/PrefixSum.hs deleted file mode 100644 --- a/examples/nofib/Test/Prelude/PrefixSum.hs +++ /dev/null @@ -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 ) - diff --git a/examples/nofib/Test/Prelude/Reduction.hs b/examples/nofib/Test/Prelude/Reduction.hs deleted file mode 100644 --- a/examples/nofib/Test/Prelude/Reduction.hs +++ /dev/null @@ -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) - diff --git a/examples/nofib/Test/Prelude/Replicate.hs b/examples/nofib/Test/Prelude/Replicate.hs --- a/examples/nofib/Test/Prelude/Replicate.hs +++ b/examples/nofib/Test/Prelude/Replicate.hs @@ -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))) diff --git a/examples/nofib/Test/Prelude/Scan.hs b/examples/nofib/Test/Prelude/Scan.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Scan.hs @@ -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) ) + diff --git a/examples/nofib/Test/Prelude/Stencil.hs b/examples/nofib/Test/Prelude/Stencil.hs --- a/examples/nofib/Test/Prelude/Stencil.hs +++ b/examples/nofib/Test/Prelude/Stencil.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/ZipWith.hs b/examples/nofib/Test/Prelude/ZipWith.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/ZipWith.hs @@ -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)) + diff --git a/examples/nofib/Test/Sharing.hs b/examples/nofib/Test/Sharing.hs --- a/examples/nofib/Test/Sharing.hs +++ b/examples/nofib/Test/Sharing.hs @@ -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) diff --git a/examples/nofib/Test/Spectral/BlackScholes.hs b/examples/nofib/Test/Spectral/BlackScholes.hs --- a/examples/nofib/Test/Spectral/BlackScholes.hs +++ b/examples/nofib/Test/Spectral/BlackScholes.hs @@ -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)) diff --git a/examples/nofib/Test/Spectral/RadixSort.hs b/examples/nofib/Test/Spectral/RadixSort.hs --- a/examples/nofib/Test/Spectral/RadixSort.hs +++ b/examples/nofib/Test/Spectral/RadixSort.hs @@ -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 diff --git a/examples/nofib/Test/Spectral/SMVM.hs b/examples/nofib/Test/Spectral/SMVM.hs --- a/examples/nofib/Test/Spectral/SMVM.hs +++ b/examples/nofib/Test/Spectral/SMVM.hs @@ -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 diff --git a/examples/pagerank/Config.hs b/examples/pagerank/Config.hs --- a/examples/pagerank/Config.hs +++ b/examples/pagerank/Config.hs @@ -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" ] diff --git a/examples/pagerank/Load.hs b/examples/pagerank/Load.hs --- a/examples/pagerank/Load.hs +++ b/examples/pagerank/Load.hs @@ -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" diff --git a/examples/pagerank/Main.hs b/examples/pagerank/Main.hs --- a/examples/pagerank/Main.hs +++ b/examples/pagerank/Main.hs @@ -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 diff --git a/examples/pagerank/Page.hs b/examples/pagerank/Page.hs --- a/examples/pagerank/Page.hs +++ b/examples/pagerank/Page.hs @@ -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 + diff --git a/examples/pagerank/README.md b/examples/pagerank/README.md new file mode 100644 --- /dev/null +++ b/examples/pagerank/README.md @@ -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 diff --git a/examples/pagerank/Rank.hs b/examples/pagerank/Rank.hs --- a/examples/pagerank/Rank.hs +++ b/examples/pagerank/Rank.hs @@ -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)) + diff --git a/examples/pagerank/Step.hs b/examples/pagerank/Step.hs --- a/examples/pagerank/Step.hs +++ b/examples/pagerank/Step.hs @@ -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) diff --git a/examples/ray/Common/Type.hs b/examples/ray/Common/Type.hs new file mode 100644 --- /dev/null +++ b/examples/ray/Common/Type.hs @@ -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) + diff --git a/examples/ray/Gloss/Draw.hs b/examples/ray/Gloss/Draw.hs --- a/examples/ray/Gloss/Draw.hs +++ b/examples/ray/Gloss/Draw.hs @@ -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 diff --git a/examples/ray/Gloss/Event.hs b/examples/ray/Gloss/Event.hs --- a/examples/ray/Gloss/Event.hs +++ b/examples/ray/Gloss/Event.hs @@ -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 diff --git a/examples/ray/Main.hs b/examples/ray/Main.hs --- a/examples/ray/Main.hs +++ b/examples/ray/Main.hs @@ -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 diff --git a/examples/ray/README.md b/examples/ray/README.md new file mode 100644 --- /dev/null +++ b/examples/ray/README.md @@ -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 + diff --git a/examples/ray/Ray/Intersect.hs b/examples/ray/Ray/Intersect.hs --- a/examples/ray/Ray/Intersect.hs +++ b/examples/ray/Ray/Intersect.hs @@ -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)) diff --git a/examples/ray/Ray/Trace.hs b/examples/ray/Ray/Trace.hs --- a/examples/ray/Ray/Trace.hs +++ b/examples/ray/Ray/Trace.hs @@ -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) diff --git a/examples/ray/Scene/Light.hs b/examples/ray/Scene/Light.hs --- a/examples/ray/Scene/Light.hs +++ b/examples/ray/Scene/Light.hs @@ -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 diff --git a/examples/ray/Scene/Object.hs b/examples/ray/Scene/Object.hs --- a/examples/ray/Scene/Object.hs +++ b/examples/ray/Scene/Object.hs @@ -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) diff --git a/examples/ray/Scene/State.hs b/examples/ray/Scene/State.hs --- a/examples/ray/Scene/State.hs +++ b/examples/ray/Scene/State.hs @@ -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 diff --git a/examples/ray/Scene/World.hs b/examples/ray/Scene/World.hs --- a/examples/ray/Scene/World.hs +++ b/examples/ray/Scene/World.hs @@ -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 ] diff --git a/examples/ray/Vec3.hs b/examples/ray/Vec3.hs deleted file mode 100644 --- a/examples/ray/Vec3.hs +++ /dev/null @@ -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)) - diff --git a/examples/smoothlife/Config.hs b/examples/smoothlife/Config.hs --- a/examples/smoothlife/Config.hs +++ b/examples/smoothlife/Config.hs @@ -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 diff --git a/examples/smoothlife/Gloss/Draw.hs b/examples/smoothlife/Gloss/Draw.hs --- a/examples/smoothlife/Gloss/Draw.hs +++ b/examples/smoothlife/Gloss/Draw.hs @@ -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 diff --git a/examples/smoothlife/Main.hs b/examples/smoothlife/Main.hs --- a/examples/smoothlife/Main.hs +++ b/examples/smoothlife/Main.hs @@ -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 diff --git a/examples/smoothlife/SmoothLife.hs b/examples/smoothlife/SmoothLife.hs --- a/examples/smoothlife/SmoothLife.hs +++ b/examples/smoothlife/SmoothLife.hs @@ -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' )) + diff --git a/examples/smvm/Main.hs b/examples/smvm/Main.hs --- a/examples/smvm/Main.hs +++ b/examples/smvm/Main.hs @@ -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 + ] diff --git a/examples/smvm/Matrix.hs b/examples/smvm/Matrix.hs --- a/examples/smvm/Matrix.hs +++ b/examples/smvm/Matrix.hs @@ -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' diff --git a/examples/smvm/MatrixMarket.hs b/examples/smvm/MatrixMarket.hs deleted file mode 100644 --- a/examples/smvm/MatrixMarket.hs +++ /dev/null @@ -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 - diff --git a/examples/smvm/SMVM.hs b/examples/smvm/SMVM.hs --- a/examples/smvm/SMVM.hs +++ b/examples/smvm/SMVM.hs @@ -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 diff --git a/examples/tunnel/Config.hs b/examples/tunnel/Config.hs new file mode 100644 --- /dev/null +++ b/examples/tunnel/Config.hs @@ -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 = [ "" ] + diff --git a/examples/tunnel/Main.hs b/examples/tunnel/Main.hs new file mode 100644 --- /dev/null +++ b/examples/tunnel/Main.hs @@ -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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal.hs b/lib/Data/Array/Accelerate/Examples/Internal.hs --- a/lib/Data/Array/Accelerate/Examples/Internal.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} -- | -- Module: : Data.Array.Accelerate.Examples.Internal -- Copyright : [2014] Trevor L. McDonell diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs b/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs b/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs b/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs b/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs b/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs b/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs b/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs @@ -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 - diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Util.hs b/lib/Data/Array/Accelerate/Examples/Internal/Util.hs --- a/lib/Data/Array/Accelerate/Examples/Internal/Util.hs +++ b/lib/Data/Array/Accelerate/Examples/Internal/Util.hs @@ -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