accelerate-examples 0.12.0.0 → 0.12.1.0
raw patch · 8 files changed
+350/−18 lines, 8 filesdep ~glossnew-component:exe:accelerate-mandelbrot
Dependency ranges changed: gloss
Files
- accelerate-examples.cabal +39/−1
- examples/crystal/Config.hs +4/−0
- examples/crystal/Main.hs +6/−2
- examples/fluid/src/Config.hs +4/−0
- examples/fluid/src/Main.hs +13/−1
- examples/mandelbrot/Config.hs +96/−0
- examples/mandelbrot/Main.hs +174/−0
- examples/tests/simple/BlackScholes.hs +14/−14
accelerate-examples.cabal view
@@ -1,5 +1,5 @@ Name: accelerate-examples-Version: 0.12.0.0+Version: 0.12.1.0 License: BSD3 License-file: LICENSE Author: The Accelerate Team@@ -29,6 +29,11 @@ * io: Extra tests for reading and writing arrays in various formats . +Flag gui+ Description: Enable gloss-based GUIs, where applicable. If not+ enabled, the application always runs in benchmark mode.+ Default: True+ Flag cuda Description: Enable the CUDA parallel backend for NVIDIA GPUs Default: True@@ -161,6 +166,9 @@ if impl(ghc >= 7.0) ghc-options: -rtsopts + if flag(gui)+ CPP-options: -DACCELERATE_ENABLE_GUI+ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND build-depends: accelerate-cuda >= 0.12@@ -175,7 +183,34 @@ fclabels >= 1.0, gloss >= 1.5 +-- A simple mandelbrot generator +Executable accelerate-mandelbrot+ hs-source-dirs: examples/mandelbrot+ Main-is: Main.hs+ other-modules: Config+ ghc-options: -O2 -Wall+ if impl(ghc >= 7.0)+ ghc-options: -rtsopts++ if flag(gui)+ CPP-options: -DACCELERATE_ENABLE_GUI++ if flag(cuda)+ CPP-options: -DACCELERATE_CUDA_BACKEND+ build-depends: accelerate-cuda >= 0.12++ if flag(opencl)+ CPP-options: -DACCELERATE_OPENCL_BACKEND+ build-depends: accelerate-opencl == 0.1.*++ build-depends: accelerate >= 0.12,+ base == 4.*,+ criterion >= 0.5,+ fclabels >= 1.0,+ gloss >= 1.5++ -- A stable fluid simulation -- Executable accelerate-fluid@@ -188,6 +223,9 @@ World ghc-options: -O2 -Wall++ if flag(gui)+ CPP-options: -DACCELERATE_ENABLE_GUI if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND
examples/crystal/Config.hs view
@@ -43,7 +43,11 @@ , _optZoom = 3 , _optScale = 30 , _optDegree = 5+#ifdef ACCELERATE_ENABLE_GUI , _optBench = False+#else+ , _optBench = True+#endif , _optHelp = False }
examples/crystal/Main.hs view
@@ -173,14 +173,18 @@ scale = get optScale config degree = get optDegree config render = run config $ makeImage size scale degree+ force arr = A.indexArray arr (Z:.0:.0) `seq` arr void . evaluate $ render (A.fromList Z [0]) if get optBench config then withArgs nops $ defaultMain- [ bench "crystal" $ whnf render (A.fromList Z [1.0]) ]+ [ bench "crystal" $ whnf (force . render) (A.fromList Z [1.0]) ] -#if MIN_VERSION_gloss(1,6,0)+#ifndef ACCELERATE_ENABLE_GUI+ else return ()++#elif MIN_VERSION_gloss(1,6,0) else G.animate (G.InWindow "Quasicrystals" (size * zoom, size * zoom) (10, 10)) (G.black)
examples/fluid/src/Config.hs view
@@ -66,7 +66,11 @@ , _displayFramerate = 20 , _optBackend = maxBound+#ifdef ACCELERATE_ENABLE_GUI , _optBench = False+#else+ , _optBench = True+#endif , _optHelp = False }
examples/fluid/src/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- -- A stable fluid simulation --@@ -36,6 +37,12 @@ sh = Z :. length ix in ( A.fromList sh ix, A.fromList sh ss ) + -- for benchmarking+ --+ force world =+ indexArray (densityField world) (Z:.0:.0) `seq`+ indexArray (velocityField world) (Z:.0:.0) `seq` ()+ -- Prepare to execute the next step of the simulation. -- -- Critically, we use the run1 execution form to ensure we bypass all@@ -58,8 +65,12 @@ if get optBench opt -- benchmark then withArgs noms $ defaultMain- [ bench "fluid" $ whnfIO (simulate 1.0 initialWorld) ]+ [ bench "fluid" $ whnfIO (force `fmap` simulate 1.0 initialWorld) ] +#ifndef ACCELERATE_ENABLE_GUI+ else return ()++#else -- simulate else playIO (InWindow "accelerate-fluid" (width, height) (10, 20))@@ -69,4 +80,5 @@ (render opt) -- render world state into a picture (react opt) -- handle user events simulate -- one step of the simulation+#endif
+ examples/mandelbrot/Config.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}++module Config (++ Options, optBackend, optSize, optLimit, optBench,+ processArgs, run, run1++) where++import Data.Label+import System.Exit+import System.Console.GetOpt+import Data.Array.Accelerate ( Arrays, Acc )+import qualified Data.Array.Accelerate.Interpreter as Interp+#ifdef ACCELERATE_CUDA_BACKEND+import qualified Data.Array.Accelerate.CUDA as CUDA+#endif++data Backend = Interpreter+#ifdef ACCELERATE_CUDA_BACKEND+ | CUDA+#endif+ deriving (Bounded, Show)++data Options = Options+ {+ _optBackend :: Backend+ , _optSize :: Int+ , _optLimit :: Int+ , _optBench :: Bool+ , _optHelp :: Bool+ }+ deriving Show++$(mkLabels [''Options])++defaultOptions :: Options+defaultOptions = Options+ { _optBackend = maxBound+ , _optSize = 512+ , _optLimit = 255+#ifdef ACCELERATE_ENABLE_GUI+ , _optBench = False+#else+ , _optBench = True+#endif+ , _optHelp = False+ }+++run :: Arrays a => Options -> Acc a -> a+run opts = case _optBackend opts of+ Interpreter -> Interp.run+#ifdef ACCELERATE_CUDA_BACKEND+ CUDA -> CUDA.run+#endif++run1 :: (Arrays a, Arrays b) => Options -> (Acc a -> Acc b) -> a -> b+run1 opts f = case _optBackend opts of+ Interpreter -> head . Interp.stream f . return+#ifdef ACCELERATE_CUDA_BACKEND+ CUDA -> CUDA.run1 f+#endif+++options :: [OptDescr (Options -> Options)]+options =+ [ Option [] ["interpreter"] (NoArg (set optBackend Interpreter)) "reference implementation (sequential)"+#ifdef ACCELERATE_CUDA_BACKEND+ , Option [] ["cuda"] (NoArg (set optBackend CUDA)) "implementation for NVIDIA GPUs (parallel)"+#endif+ , Option [] ["size"] (ReqArg (set optSize . read) "INT") "visualisation size (512)"+ , Option [] ["limit"] (ReqArg (set optLimit . read) "INT") "iteration limit for escape (255)"+ , Option [] ["benchmark"] (NoArg (set optBench True)) "benchmark instead of displaying animation (False)"+ , Option "h?" ["help"] (NoArg (set optHelp True)) "show help message"+ ]+++processArgs :: [String] -> IO (Options, [String])+processArgs argv =+ case getOpt' Permute options argv of+ (o,_,n,[]) -> case foldl (flip id) defaultOptions o of+ opts | False <- get optHelp opts -> return (opts, n)+ opts | True <- get optBench opts -> return (opts, "--help":n)+ _ -> putStrLn (helpMsg []) >> exitSuccess+ (_,_,_,err) -> error (helpMsg err)+ where+ helpMsg err = concat err ++ usageInfo header options+ header = unlines+ [ "accelerate-mandelbrot (c) [2011..2012] The Accelerate Team"+ , ""+ , "Usage: accelerate-mandelbrot [OPTIONS]"+ ]+
+ examples/mandelbrot/Main.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-}+--+-- A Mandelbrot set generator. Submitted by Simon Marlow as part of Issue #49.+--+++import Config+import Data.Label+import Control.Monad+import Control.Exception+import Foreign.Ptr+import Foreign.ForeignPtr+import System.IO.Unsafe+import System.Environment+import Criterion.Main ( defaultMain, bench, whnf )+import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData )+import Data.Array.Accelerate.Array.Sugar ( Array(..) )++import Prelude as P+import Data.Array.Accelerate as A hiding ( size )+import qualified Graphics.Gloss as G+++-- Mandelbrot Set --------------------------------------------------------------++type F = Float -- Double not supported on all devices++type Complex = (F,F)+type ComplexPlane = Array DIM2 Complex++mandelbrot :: F -> F -> F -> F -> Int -> Int -> Int -> Acc (Array DIM2 (F,F,Int))+mandelbrot x y x' y' screenX screenY depth+ = foldl (flip ($)) zs0 (P.take depth (repeat go))+ where+ cs = genPlane x y x' y' screenX screenY+ zs0 = mkinit cs++ go :: Acc (Array DIM2 (F,F,Int)) -> Acc (Array DIM2 (F,F,Int))+ go = A.zipWith iter cs+++genPlane :: F -> F+ -> F -> F+ -> Int+ -> Int+ -> Acc ComplexPlane+genPlane lowx lowy highx highy viewx viewy+ = generate (constant (Z:.viewy:.viewx))+ (\ix -> let pr = unindex2 ix+ x = A.fromIntegral (A.fst pr)+ y = A.fromIntegral (A.snd pr)+ in+ lift ( elowx + (x * exsize) / eviewx+ , elowy + (y * eysize) / eviewy))+ where+ elowx, elowy, exsize, eysize, eviewx, eviewy :: Exp F++ elowx = constant lowx+ elowy = constant lowy++ exsize = constant (highx - lowx)+ eysize = constant (highy - lowy)++ eviewx = constant (P.fromIntegral viewx)+ eviewy = constant (P.fromIntegral viewy)+++next :: Exp Complex -> Exp Complex -> Exp Complex+next c z = c `plus` (z `times` z)+++plus :: Exp Complex -> Exp Complex -> Exp Complex+plus = lift2 f+ where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F)+ f (x1,y1) (x2,y2) = (x1+x2,y1+y2)++times :: Exp Complex -> Exp Complex -> Exp Complex+times = lift2 f+ where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F)+ f (x,y) (x',y') = (x*x'-y*y', x*y'+y*x')++dot :: Exp Complex -> Exp F+dot = lift1 f+ where f :: (Exp F, Exp F) -> Exp F+ f (x,y) = x*x + y*y+++iter :: Exp Complex -> Exp (F,F,Int) -> Exp (F,F,Int)+iter c z = f (unlift z)+ where+ f :: (Exp F, Exp F, Exp Int) -> Exp (F,F,Int)+ f (x,y,i) =+ (dot z' >* 4.0) ? ( lift (x,y,i)+ , lift (A.fst z', A.snd z', i+1) )+ where z' = A.curry (next c) x y+++mkinit :: Acc ComplexPlane -> Acc (Array DIM2 (F,F,Int))+mkinit cs = A.map (lift1 f) cs+ where f :: (Exp F, Exp F) -> (Exp F, Exp F, Exp Int)+ f (x,y) = (x,y,0)+++-- Rendering -------------------------------------------------------------------++type RGBA = Word32++prettyRGBA :: Exp Int -> Exp (F, F, Int) -> Exp RGBA+prettyRGBA lIMIT s' = r + g + b + a+ where+ (_, _, s) = unlift s' :: (Exp F, Exp F, Exp Int)+ t = A.fromIntegral $ ((lIMIT - s) * 255) `quot` lIMIT+ r = (t `mod` 128 + 64) * 0x1000000+ g = (t * 2 `mod` 128 + 64) * 0x10000+ b = (t * 3 `mod` 256 ) * 0x100+ a = 0xFF+++makePicture :: Options -> Int -> Acc (Array DIM2 (F, F, Int)) -> G.Picture+makePicture opt limit zs = pic+ where+ arrPixels = run opt $ A.map (prettyRGBA (constant limit)) zs+ (Z:.h:.w) = arrayShape arrPixels++ {-# NOINLINE rawData #-}+ rawData = let (Array _ adata) = arrPixels+ ((), ptr) = ptrsOfArrayData adata+ in+ unsafePerformIO $ newForeignPtr_ (castPtr ptr)++ pic = G.bitmapOfForeignPtr h w rawData False+++-- Main ------------------------------------------------------------------------++main :: IO ()+main+ = do (config, nops) <- processArgs =<< getArgs+ let size = get optSize config+ limit = get optLimit config+ --+ x = -0.25 -- should get this from command line as well+ y = -1.0+ x' = 0.0+ y' = -0.75+ --+ force arr = indexArray arr (Z:.0:.0) `seq` arr+ image = makePicture config limit+ $ mandelbrot x y x' y' size size limit++ void $ evaluate image++ if get optBench config+ then withArgs nops $ defaultMain+ [ bench "mandelbrot" $+ whnf (force . run config . mandelbrot x y x' y' size size) limit ]++#ifndef ACCELERATE_ENABLE_GUI+ else return ()++#elif MIN_VERSION_gloss(1,6,0)+ else G.display+ (G.InWindow "Mandelbrot" (size, size) (10, 10))+ G.black+ image+#else+ else G.displayInWindow+ "Mandelbrot"+ (size, size)+ (10, 10)+ G.black+ image+#endif+
examples/tests/simple/BlackScholes.hs view
@@ -17,14 +17,14 @@ ------------------------------- horner :: Num a => [a] -> a -> a-horner coeff x = foldr1 madd coeff+horner coeff x = x * foldr1 madd coeff where- madd a b = b*x + a+ madd a b = a + x*b cnd' :: Floating a => a -> a cnd' d = let poly = horner coeff- coeff = [0.0,0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429]+ coeff = [0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429] rsqrt2pi = 0.39894228040143267793994605993438 k = 1.0 / (1.0 + 0.2316419 * abs d) in@@ -36,18 +36,18 @@ where go x = let (price, strike, years) = Acc.unlift x- r = Acc.constant riskfree- v = Acc.constant volatility- sqrtT = sqrt years- d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / (v * sqrtT)- d2 = d1 - v * sqrtT- cnd d = d >* 0 ? (1.0 - cnd' d, cnd' d)- cndD1 = cnd d1- cndD2 = cnd d2- expRT = exp (-r * years)+ r = Acc.constant riskfree+ v = Acc.constant volatility+ 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)+ cndD1 = cnd d1+ cndD2 = cnd d2+ x_expRT = strike * exp (-r * years) in- Acc.lift ( price * cndD1 - strike * expRT * cndD2- , strike * expRT * (1.0 - cndD2) - price * (1.0 - cndD1))+ Acc.lift ( price * cndD1 - x_expRT * cndD2+ , x_expRT * (1.0 - cndD2) - price * (1.0 - cndD1)) blackscholesRef :: IArray.Array Int (Float,Float,Float) -> IArray.Array Int (Float,Float)