repa-examples 3.3.1.1 → 3.4.0.1
raw patch · 14 files changed
+715/−686 lines, 14 filesdep ~QuickCheckdep ~basedep ~random
Dependency ranges changed: QuickCheck, base, random, repa, repa-algorithms, repa-io, template-haskell
Files
- examples/Blur/src-repa/Main.hs +35/−35
- examples/Canny/src-repa/Main.hs +186/−186
- examples/FFT/FFT2d/src-repa/Main.hs +36/−36
- examples/FFT/HighPass2d/src-repa/Main.hs +65/−65
- examples/FFT/HighPass3d/src-repa/Main.hs +58/−57
- examples/Laplace/src-repa/Main.hs +77/−77
- examples/Laplace/src-repa/SolverGet.hs +41/−41
- examples/Laplace/src-repa/SolverStencil.hs +16/−15
- examples/MMult/src-repa/Main.hs +65/−65
- examples/Sobel/src-repa/Main.hs +25/−25
- examples/Sobel/src-repa/Solver.hs +15/−15
- examples/UnitTesting/UnitTesting.hs +1/−1
- examples/Volume/Main.hs +11/−11
- repa-examples.cabal +84/−57
examples/Blur/src-repa/Main.hs view
@@ -7,73 +7,73 @@ import Data.Word import Data.Array.Repa.IO.BMP import Data.Array.Repa.IO.Timing-import Data.Array.Repa as A+import Data.Array.Repa as A import qualified Data.Array.Repa.Repr.Unboxed as U-import Data.Array.Repa.Stencil as A-import Data.Array.Repa.Stencil.Dim2 as A-import Prelude as P+import Data.Array.Repa.Stencil as A+import Data.Array.Repa.Stencil.Dim2 as A+import Prelude as P main - = do args <- getArgs- case args of- [iterations, fileIn, fileOut] -> run (read iterations) fileIn fileOut- _ -> usage+ = do args <- getArgs+ case args of+ [iterations, fileIn, fileOut] -> run (read iterations) fileIn fileOut+ _ -> usage -usage = putStr $ unlines- [ "repa-blur <iterations::Int> <fileIn.bmp> <fileOut.bmp>" ]+usage = putStr $ unlines+ [ "repa-blur <iterations::Int> <fileIn.bmp> <fileOut.bmp>" ] -- | Perform the blur. run :: Int -> FilePath -> FilePath -> IO () run iterations fileIn fileOut- = do arrRGB <- liftM (either (error . show) id) - $ readImageFromBMP fileIn+ = do arrRGB <- liftM (either (error . show) id) + $ readImageFromBMP fileIn - arrRGB `deepSeqArray` return ()- let (arrRed, arrGreen, arrBlue) = U.unzip3 arrRGB- let comps = [arrRed, arrGreen, arrBlue]- - (comps', tElapsed)- <- time $ P.mapM (process iterations) comps- - putStr $ prettyTime tElapsed+ arrRGB `deepSeqArray` return ()+ let (arrRed, arrGreen, arrBlue) = U.unzip3 arrRGB+ let comps = [arrRed, arrGreen, arrBlue]+ + (comps', tElapsed)+ <- time $ P.mapM (process iterations) comps+ + putStr $ prettyTime tElapsed let [arrRed', arrGreen', arrBlue'] = comps'- writeImageToBMP fileOut- (U.zip3 arrRed' arrGreen' arrBlue')+ writeImageToBMP fileOut+ (U.zip3 arrRed' arrGreen' arrBlue') -process :: Monad m => Int -> Array U DIM2 Word8 -> m (Array U DIM2 Word8)+process :: Monad m => Int -> Array U DIM2 Word8 -> m (Array U DIM2 Word8) process iterations = promote >=> blur iterations >=> demote {-# NOINLINE process #-} - -promote :: Monad m => Array U DIM2 Word8 -> m (Array U DIM2 Double)+ +promote :: Monad m => Array U DIM2 Word8 -> m (Array U DIM2 Double) promote arr = computeP $ A.map ffs arr- where {-# INLINE ffs #-}- ffs :: Word8 -> Double- ffs x = fromIntegral (fromIntegral x :: Int)+ where {-# INLINE ffs #-}+ ffs :: Word8 -> Double+ ffs x = fromIntegral (fromIntegral x :: Int) {-# NOINLINE promote #-} -demote :: Monad m => Array U DIM2 Double -> m (Array U DIM2 Word8)+demote :: Monad m => Array U DIM2 Double -> m (Array U DIM2 Word8) demote arr = computeP $ A.map ffs arr - where {-# INLINE ffs #-}- ffs :: Double -> Word8- ffs x = fromIntegral (truncate x :: Int)+ where {-# INLINE ffs #-}+ ffs :: Double -> Word8+ ffs x = fromIntegral (truncate x :: Int) {-# NOINLINE demote #-} -blur :: Monad m => Int -> Array U DIM2 Double -> m (Array U DIM2 Double)+blur :: Monad m => Int -> Array U DIM2 Double -> m (Array U DIM2 Double) blur !iterations arrInit = go iterations arrInit where go !0 !arr = return arr go !n !arr - = do arr' <- computeP+ = do arr' <- computeP $ A.smap (/ 159) $ forStencil2 BoundClamp arr [stencil2| 2 4 5 4 2@@ -83,4 +83,4 @@ 2 4 5 4 2 |] go (n-1) arr' {-# NOINLINE blur #-}- +
examples/Canny/src-repa/Main.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PackageImports, BangPatterns, QuasiQuotes, PatternGuards, - MagicHash, ScopedTypeVariables #-}+ MagicHash, ScopedTypeVariables, TypeFamilies #-} {-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-incomplete-patterns #-} -- | Canny edge detector.@@ -13,7 +13,7 @@ import Data.Int import Control.Monad import System.Environment-import Data.Array.Repa as R+import Data.Array.Repa as R import Data.Array.Repa.Repr.Unboxed as U import Data.Array.Repa.Repr.Cursored as C import Data.Array.Repa.Stencil@@ -24,55 +24,55 @@ import Data.Array.Repa.IO.Timing import Debug.Trace import GHC.Exts-import qualified Data.Vector.Unboxed.Mutable as VM-import qualified Data.Vector.Unboxed as V-import qualified Prelude as P+import qualified Data.Vector.Unboxed.Mutable as VM+import qualified Data.Vector.Unboxed as V+import qualified Prelude as P import Prelude hiding (compare) -type Image a = Array U DIM2 a+type Image a = Array U DIM2 a -- Constants -------------------------------------------------------------------orientUndef = 0 :: Word8-orientPosDiag = 64 :: Word8-orientVert = 128 :: Word8-orientNegDiag = 192 :: Word8-orientHoriz = 255 :: Word8+orientUndef = 0 :: Word8+orientPosDiag = 64 :: Word8+orientVert = 128 :: Word8+orientNegDiag = 192 :: Word8+orientHoriz = 255 :: Word8 -data Edge = None | Weak | Strong-edge None = 0 :: Word8-edge Weak = 128 :: Word8-edge Strong = 255 :: Word8+data Edge = None | Weak | Strong+edge None = 0 :: Word8+edge Weak = 128 :: Word8+edge Strong = 255 :: Word8 -- Main routine --------------------------------------------------------------- main - = do args <- getArgs- case args of- [fileIn, fileOut] - -> run 0 50 100 fileIn fileOut+ = do args <- getArgs+ case args of+ [fileIn, fileOut] + -> run 0 50 100 fileIn fileOut - [loops, threshLow, threshHigh, fileIn, fileOut]- -> run (read loops) (read threshLow) (read threshHigh) fileIn fileOut+ [loops, threshLow, threshHigh, fileIn, fileOut]+ -> run (read loops) (read threshLow) (read threshHigh) fileIn fileOut - _ -> putStrLn + _ -> putStrLn $ concat [ "repa-canny [<loops::Int> <threshLow::Int> <threshHigh::Int>]" , " <fileIn.bmp> <fileOut.bmp>" ] run loops threshLow threshHigh fileIn fileOut- = do arrInput <- liftM (either (error . show) id) - $ readImageFromBMP fileIn+ = do arrInput <- liftM (either (error . show) id) + $ readImageFromBMP fileIn - (arrResult, tTotal)- <- time $ process loops threshLow threshHigh arrInput+ (arrResult, tTotal)+ <- time $ process loops threshLow threshHigh arrInput - when (loops >= 1)- $ putStrLn $ "\nTOTAL\n"- - putStr $ prettyTime tTotal- - writeImageToBMP fileOut (U.zip3 arrResult arrResult arrResult)+ when (loops >= 1)+ $ putStrLn $ "\nTOTAL\n"+ + putStr $ prettyTime tTotal+ + writeImageToBMP fileOut (U.zip3 arrResult arrResult arrResult) process loops threshLow threshHigh arrInput@@ -109,32 +109,32 @@ -- | Wrapper to time each stage of the algorithm. timeStage- :: (Shape sh, Unbox a)- => Int- -> String - -> IO (Array U sh a)- -> IO (Array U sh a)+ :: (Shape sh, Unbox a)+ => Int+ -> String + -> IO (Array U sh a)+ -> IO (Array U sh a) timeStage loops name fn- = do + = do let burn !n- = do !arr <- fn- if n <= 1 then return arr- else burn (n - 1)+ = do !arr <- fn+ if n <= 1 then return arr+ else burn (n - 1) - traceEventIO $ "**** Stage " P.++ name P.++ " begin."- - (arrResult, t)- <- time $ do !arrResult' <- burn loops- return arrResult'+ traceEventIO $ "**** Stage " P.++ name P.++ " begin."+ + (arrResult, t)+ <- time $ do !arrResult' <- burn loops+ return arrResult' traceEventIO $ "**** Stage " P.++ name P.++ " end." - when (loops >= 1) - $ putStr $ name P.++ "\n"- P.++ unlines [ " " P.++ l | l <- lines $ prettyTime t ]+ when (loops >= 1) + $ putStr $ name P.++ "\n"+ P.++ unlines [ " " P.++ l | l <- lines $ prettyTime t ] - return arrResult+ return arrResult {-# NOINLINE timeStage #-} @@ -153,43 +153,43 @@ blurSepX arr = computeP $ forStencil2 BoundClamp arr- [stencil2| 1 4 6 4 1 |] + [stencil2| 1 4 6 4 1 |] {-# NOINLINE blurSepX #-} -- | Separable Gaussian blur in the Y direction. blurSepY :: Image Float -> IO (Image Float) blurSepY arr- = computeP- $ R.smap (/ 256)- $ forStencil2 BoundClamp arr- [stencil2| 1- 4- 6- 4- 1 |]+ = computeP+ $ R.smap (/ 256)+ $ forStencil2 BoundClamp arr+ [stencil2| 1+ 4+ 6+ 4+ 1 |] {-# NOINLINE blurSepY #-} -- | Compute gradient in the X direction. gradientX :: Image Float -> IO (Image Float) gradientX img- = computeP- $ forStencil2 BoundClamp img- [stencil2| -1 0 1- -2 0 2- -1 0 1 |]+ = computeP+ $ forStencil2 BoundClamp img+ [stencil2| -1 0 1+ -2 0 2+ -1 0 1 |] {-# NOINLINE gradientX #-} -- | Compute gradient in the Y direction. gradientY :: Image Float -> IO (Image Float) gradientY img- = computeP- $ forStencil2 BoundClamp img- [stencil2| 1 2 1- 0 0 0- -1 -2 -1 |] + = computeP+ $ forStencil2 BoundClamp img+ [stencil2| 1 2 1+ 0 0 0+ -1 -2 -1 |] {-# NOINLINE gradientY #-} @@ -201,54 +201,54 @@ = computeP $ R.zipWith magOrient dX dY - where magOrient :: Float -> Float -> (Float, Word8)- magOrient !x !y- = (magnitude x y, orientation x y)- {-# INLINE magOrient #-}+ where magOrient :: Float -> Float -> (Float, Word8)+ magOrient !x !y+ = (magnitude x y, orientation x y)+ {-# INLINE magOrient #-} - magnitude :: Float -> Float -> Float- magnitude !x !y- = sqrt (x * x + y * y)+ magnitude :: Float -> Float -> Float+ magnitude !x !y+ = sqrt (x * x + y * y) {-# INLINE magnitude #-}- + {-# INLINE orientation #-}- orientation :: Float -> Float -> Word8- orientation !x !y+ orientation :: Float -> Float -> Word8+ orientation !x !y - -- Don't bother computing orientation if vector is below threshold.- | x >= negate threshLow, x < threshLow- , y >= negate threshLow, y < threshLow- = orientUndef + -- Don't bother computing orientation if vector is below threshold.+ | x >= negate threshLow, x < threshLow+ , y >= negate threshLow, y < threshLow+ = orientUndef - | otherwise- = let -- Determine the angle of the vector and rotate it around a bit- -- to make the segments easier to classify.- !d = atan2 y x - !dRot = (d - (pi/8)) * (4/pi)- - -- Normalise angle to beween 0..8- !dNorm = if dRot < 0 then dRot + 8 else dRot+ | otherwise+ = let -- Determine the angle of the vector and rotate it around a bit+ -- to make the segments easier to classify.+ !d = atan2 y x + !dRot = (d - (pi/8)) * (4/pi)+ + -- Normalise angle to beween 0..8+ !dNorm = if dRot < 0 then dRot + 8 else dRot - -- Doing explicit tests seems to be faster than using the FP floor function.- in fromIntegral + -- Doing explicit tests seems to be faster than using the FP floor function.+ in fromIntegral $ I# (if dNorm >= 4- then if dNorm >= 6- then if dNorm >= 7- then 255# -- 7- else 192# -- 6+ then if dNorm >= 6+ then if dNorm >= 7+ then 255# -- 7+ else 192# -- 6 - else if dNorm >= 5- then 128# -- 5- else 64# -- 4+ else if dNorm >= 5+ then 128# -- 5+ else 64# -- 4 - else if dNorm >= 2- then if dNorm >= 3- then 255# -- 3- else 192# -- 2+ else if dNorm >= 2+ then if dNorm >= 3+ then 255# -- 3+ else 192# -- 2 - else if dNorm >= 1- then 128# -- 1- else 64#) -- 0+ else if dNorm >= 1+ then 128# -- 1+ else 64#) -- 0 {-# NOINLINE gradientMagOrient #-} @@ -259,32 +259,32 @@ = computeP $ makeBordered2 (extent dMagOrient) 1 - (makeCursored (extent dMagOrient) id addDim comparePts)- (fromFunction (extent dMagOrient) (const 0))+ (makeCursored (extent dMagOrient) id addDim comparePts)+ (fromFunction (extent dMagOrient) (const 0)) - where {-# INLINE comparePts #-}- comparePts d@(sh :. i :. j)- | o == orientUndef = edge None- | o == orientHoriz = isMax (getMag (sh :. i :. j-1)) (getMag (sh :. i :. j+1)) - | o == orientVert = isMax (getMag (sh :. i-1 :. j)) (getMag (sh :. i+1 :. j)) + where {-# INLINE comparePts #-}+ comparePts d@(sh :. i :. j)+ | o == orientUndef = edge None+ | o == orientHoriz = isMax (getMag (sh :. i :. j-1)) (getMag (sh :. i :. j+1)) + | o == orientVert = isMax (getMag (sh :. i-1 :. j)) (getMag (sh :. i+1 :. j)) | o == orientNegDiag = isMax (getMag (sh :. i-1 :. j-1)) (getMag (sh :. i+1 :. j+1)) | o == orientPosDiag = isMax (getMag (sh :. i-1 :. j+1)) (getMag (sh :. i+1 :. j-1)) | otherwise = edge None where- !o = getOrient d - !m = getMag (Z :. i :. j)+ !o = getOrient d + !m = getMag (Z :. i :. j) - getMag = fst . (R.unsafeIndex dMagOrient)- getOrient = snd . (R.unsafeIndex dMagOrient)+ getMag = fst . (R.unsafeIndex dMagOrient)+ getOrient = snd . (R.unsafeIndex dMagOrient) - {-# INLINE isMax #-}+ {-# INLINE isMax #-} isMax !intensity1 !intensity2- | m < threshLow = edge None- | m < intensity1 = edge None- | m < intensity2 = edge None- | m < threshHigh = edge Weak- | otherwise = edge Strong+ | m < threshLow = edge None+ | m < intensity1 = edge None+ | m < intensity2 = edge None+ | m < threshHigh = edge Weak+ | otherwise = edge Strong {-# NOINLINE suppress #-} @@ -294,88 +294,88 @@ -- doesn't provide a fused mapFilter primitive yet. selectStrong :: Image Word8 -> IO (Array U DIM1 Int) selectStrong img- = let vec = toUnboxed img+ = let vec = toUnboxed img - match ix = vec `V.unsafeIndex` ix == edge Strong+ match ix = vec `V.unsafeIndex` ix == edge Strong {-# INLINE match #-} - process' ix = ix+ process' ix = ix {-# INLINE process' #-}- - in selectP match process' (size $ extent img)+ + in selectP match process' (size $ extent img) {-# NOINLINE selectStrong #-} -- | Trace out strong edges in the final image. -- Also trace out weak edges that are connected to strong edges. wildfire - :: Image Word8 -- ^ Image with strong and weak edges set.- -> Array U DIM1 Int -- ^ Array containing flat indices of strong edges.- -> IO (Image Word8)+ :: Image Word8 -- ^ Image with strong and weak edges set.+ -> Array U DIM1 Int -- ^ Array containing flat indices of strong edges.+ -> IO (Image Word8) wildfire img arrStrong- = do (sh, vec) <- wildfireIO - return $ sh `seq` vec `seq` fromUnboxed sh vec+ = do (sh, vec) <- wildfireIO + return $ sh `seq` vec `seq` fromUnboxed sh vec - where lenImg = R.size $ R.extent img- lenStrong = R.size $ R.extent arrStrong- vStrong = toUnboxed arrStrong- - wildfireIO- = do -- Stack of image indices we still need to consider.- vStrong' <- V.thaw vStrong- vStack <- VM.grow vStrong' (lenImg - lenStrong)- - -- Burn in new edges.- vImg <- VM.unsafeNew lenImg- VM.set vImg 0- burn vImg vStack lenStrong- vImg' <- V.unsafeFreeze vImg- return (extent img, vImg')+ where lenImg = R.size $ R.extent img+ lenStrong = R.size $ R.extent arrStrong+ vStrong = toUnboxed arrStrong+ + wildfireIO+ = do -- Stack of image indices we still need to consider.+ vStrong' <- V.thaw vStrong+ vStack <- VM.grow vStrong' (lenImg - lenStrong)+ + -- Burn in new edges.+ vImg <- VM.unsafeNew lenImg+ VM.set vImg 0+ burn vImg vStack lenStrong+ vImg' <- V.unsafeFreeze vImg+ return (extent img, vImg') - - burn :: VM.IOVector Word8 -> VM.IOVector Int -> Int -> IO ()- burn !vImg !vStack !top- | top == 0- = return ()- - | otherwise- = do let !top' = top - 1- n <- VM.unsafeRead vStack top'- let (Z :. y :. x) = fromIndex (R.extent img) n+ + burn :: VM.IOVector Word8 -> VM.IOVector Int -> Int -> IO ()+ burn !vImg !vStack !top+ | top == 0+ = return ()+ + | otherwise+ = do let !top' = top - 1+ n <- VM.unsafeRead vStack top'+ let (Z :. y :. x) = fromIndex (R.extent img) n - let {-# INLINE push #-}- push t = pushWeak vImg vStack t- - VM.write vImg n (edge Strong)- >> push (Z :. y - 1 :. x - 1) top'- >>= push (Z :. y - 1 :. x )- >>= push (Z :. y - 1 :. x + 1)+ let {-# INLINE push #-}+ push t = pushWeak vImg vStack t+ + VM.write vImg n (edge Strong)+ >> push (Z :. y - 1 :. x - 1) top'+ >>= push (Z :. y - 1 :. x )+ >>= push (Z :. y - 1 :. x + 1) - >>= push (Z :. y :. x - 1)- >>= push (Z :. y :. x + 1)+ >>= push (Z :. y :. x - 1)+ >>= push (Z :. y :. x + 1) - >>= push (Z :. y + 1 :. x - 1)- >>= push (Z :. y + 1 :. x )- >>= push (Z :. y + 1 :. x + 1)+ >>= push (Z :. y + 1 :. x - 1)+ >>= push (Z :. y + 1 :. x )+ >>= push (Z :. y + 1 :. x + 1) - >>= burn vImg vStack+ >>= burn vImg vStack - -- If this ix is weak in the source then set it to strong in the- -- result and push the ix onto the stack.- {-# INLINE pushWeak #-}- pushWeak vImg vStack ix top- = do let n = toIndex (extent img) ix- xDst <- VM.unsafeRead vImg n- let xSrc = img `R.unsafeIndex` ix+ -- If this ix is weak in the source then set it to strong in the+ -- result and push the ix onto the stack.+ {-# INLINE pushWeak #-}+ pushWeak vImg vStack ix top+ = do let n = toIndex (extent img) ix+ xDst <- VM.unsafeRead vImg n+ let xSrc = img `R.unsafeIndex` ix - if xDst == edge None - && xSrc == edge Weak- then do- VM.unsafeWrite vStack top (toIndex (extent img) ix)- return (top + 1)- - else return top+ if xDst == edge None + && xSrc == edge Weak+ then do+ VM.unsafeWrite vStack top (toIndex (extent img) ix)+ return (top + 1)+ + else return top {-# NOINLINE wildfire #-}
examples/FFT/FFT2d/src-repa/Main.hs view
@@ -14,55 +14,55 @@ main :: IO () main - = do args <- getArgs- case args of- [fileIn, clipMag, fileMag, filePhase]- -> mainWithArgs fileIn (read clipMag) fileMag filePhase+ = do args <- getArgs+ case args of+ [fileIn, clipMag, fileMag, filePhase]+ -> mainWithArgs fileIn (read clipMag) fileMag filePhase _ -> putStr $ unlines- [ "Usage: repa-fft2d <fileIn.bmp> <clip mag :: Int> <fileOutMag.bmp> <fileOutPhase.bmp>"- , " "- , " Image dimensions must be powers of two, eg 128x512 or 64x256"- , ""- , " The output magnitude has a high dynamic range. We need to clip it otherwise"- , " most of the pixels in the output BMP will be black. Start with a value equal"- , " to about the width of the image (eg 512)"- , "" ]+ [ "Usage: repa-fft2d <fileIn.bmp> <clip mag :: Int> <fileOutMag.bmp> <fileOutPhase.bmp>"+ , " "+ , " Image dimensions must be powers of two, eg 128x512 or 64x256"+ , ""+ , " The output magnitude has a high dynamic range. We need to clip it otherwise"+ , " most of the pixels in the output BMP will be black. Start with a value equal"+ , " to about the width of the image (eg 512)"+ , "" ] - + mainWithArgs fileIn (clipMag :: Double) fileMag filePhase- = do - -- Load in the matrix.+ = do + -- Load in the matrix. arrRGB <- liftM (either (\e -> error $ show e) id)- $ readImageFromBMP fileIn+ $ readImageFromBMP fileIn - arrComplex <- computeUnboxedP- $ R.map (\r -> (r, 0 :: Double)) - $ R.map doubleLuminanceOfRGB8 arrRGB+ arrComplex <- computeUnboxedP+ $ R.map (\r -> (r, 0 :: Double)) + $ R.map doubleLuminanceOfRGB8 arrRGB - -- Apply the centering transform so that the output has the zero- -- frequency in the middle of the image.- arrCentered <- computeUnboxedP- $ center2d arrComplex- - -- Do the 2d transform.- arrFreq <- fft2dP Forward arrCentered- - -- Write out the magnitude of the transformed array, - -- clipping it at the given value.- let clip m = if m >= clipMag then 1 else (m / clipMag)- arrMag <- computeUnboxedP + -- Apply the centering transform so that the output has the zero+ -- frequency in the middle of the image.+ arrCentered <- computeUnboxedP+ $ center2d arrComplex+ + -- Do the 2d transform.+ arrFreq <- fft2dP Forward arrCentered+ + -- Write out the magnitude of the transformed array, + -- clipping it at the given value.+ let clip m = if m >= clipMag then 1 else (m / clipMag)+ arrMag <- computeUnboxedP $ R.map (rgb8OfGreyDouble . clip . mag) $ arrFreq writeImageToBMP fileMag arrMag - -- Write out the phase of the transformed array, - -- scaling it to make full use of the 8 bit greyscale.- let scaledArg x = (arg x + pi) / (2 * pi)- arrPhase <- computeUnboxedP + -- Write out the phase of the transformed array, + -- scaling it to make full use of the 8 bit greyscale.+ let scaledArg x = (arg x + pi) / (2 * pi)+ arrPhase <- computeUnboxedP $ R.map (rgb8OfGreyDouble . scaledArg) arrFreq - writeImageToBMP filePhase arrPhase+ writeImageToBMP filePhase arrPhase
examples/FFT/HighPass2d/src-repa/Main.hs view
@@ -1,86 +1,86 @@ {-# LANGUAGE PatternGuards #-} -- | Perform high pass filtering on a BMP image.-import Data.Array.Repa.Algorithms.FFT-import Data.Array.Repa.Algorithms.DFT.Center-import Data.Array.Repa.Algorithms.Complex-import Data.Array.Repa.IO.BMP-import Data.Array.Repa.IO.Timing+import Data.Array.Repa.Algorithms.FFT as R+import Data.Array.Repa.Algorithms.DFT.Center as R+import Data.Array.Repa.Algorithms.Complex as R+import Data.Array.Repa.IO.BMP as R+import Data.Array.Repa.IO.Timing as R+import Data.Array.Repa as R+import qualified Data.Array.Repa.Repr.Unboxed as U import System.Environment import Control.Monad import Data.Word-import Data.Array.Repa as R-import qualified Data.Array.Repa.Repr.Unboxed as U main :: IO () main - = do args <- getArgs- case args of- [cutoff, fileIn, fileOut]- -> mainWithArgs (read cutoff) fileIn fileOut+ = do args <- getArgs+ case args of+ [cutoff, fileIn, fileOut]+ -> mainWithArgs (read cutoff) fileIn fileOut _ -> putStr $ unlines- [ "Usage: repa-fft-highpass <cutoff::Int> <fileIn.bmp> <fileOut.bmp>"- , ""- , " Image dimensions must be powers of two, eg 128x512 or 64x256"- , "" ]- - + [ "Usage: repa-fft-highpass <cutoff::Int> <fileIn.bmp> <fileOut.bmp>"+ , ""+ , " Image dimensions must be powers of two, eg 128x512 or 64x256"+ , "" ]+ + mainWithArgs cutoff fileIn fileOut- = do - -- Load in the matrix.- arrRGB <- liftM (either (\e -> error $ show e) id)- $ readImageFromBMP fileIn- - let (arrRed, arrGreen, arrBlue)- = U.unzip3 arrRGB- - -- Do the transform on each component individually- ((arrRed', arrGreen', arrBlue'), t)- <- time- $ do arrRed' <- transformP cutoff arrRed- arrGreen' <- transformP cutoff arrGreen- arrBlue' <- transformP cutoff arrBlue+ = do + -- Load in the matrix.+ arrRGB <- liftM (either (\e -> error $ show e) id)+ $ readImageFromBMP fileIn+ + let (arrRed, arrGreen, arrBlue)+ = U.unzip3 arrRGB+ + -- Do the transform on each component individually+ ((arrRed', arrGreen', arrBlue'), t)+ <- time+ $ do arrRed' <- transformP cutoff arrRed+ arrGreen' <- transformP cutoff arrGreen+ arrBlue' <- transformP cutoff arrBlue return (arrRed', arrGreen', arrBlue')- - putStr (prettyTime t)- - -- Write it back to file.- writeImageToBMP fileOut- (U.zip3 arrRed' arrGreen' arrBlue')- + + putStr (prettyTime t)+ + -- Write it back to file.+ writeImageToBMP fileOut+ (U.zip3 arrRed' arrGreen' arrBlue')+ -- | Perform high-pass filtering on a rank-2 array. transformP :: Monad m => Int -> Array U DIM2 Word8 -> m (Array U DIM2 Word8) transformP cutoff arrReal- = do let arrComplex = R.map (\r -> (fromIntegral r, 0)) arrReal- - -- Do the 2d transform.- arrCentered <- computeUnboxedP $ center2d arrComplex- arrFreq <- fft2dP Forward arrCentered+ = do let arrComplex = R.map (\r -> (fromIntegral r, 0)) arrReal+ + -- Do the 2d transform.+ arrCentered <- computeUnboxedP $ center2d arrComplex+ arrFreq <- fft2dP Forward arrCentered - -- Zap out the low frequency components.- let _ :. height :. width = extent arrFreq- let centerX = width `div` 2- let centerY = height `div` 2- - let {-# INLINE highpass #-}- highpass get ix@(_ :. y :. x)- | x > centerX + cutoff- || x < centerX - cutoff- || y > centerY + cutoff- || y < centerY - cutoff- = get ix- - | otherwise- = 0- - arrFilt <- computeUnboxedP $ traverse arrFreq id highpass+ -- Zap out the low frequency components.+ let _ :. height :. width = extent arrFreq+ let centerX = width `div` 2+ let centerY = height `div` 2+ + let {-# INLINE highpass #-}+ highpass get ix@(_ :. y :. x)+ | x > centerX + cutoff+ || x < centerX - cutoff+ || y > centerY + cutoff+ || y < centerY - cutoff+ = get ix+ + | otherwise+ = 0+ + arrFilt <- computeUnboxedP $ R.traverse arrFreq id highpass - -- Do the inverse transform to get back to image space.- arrInv <- fft2dP Inverse arrFilt- - -- Get the magnitude of the transformed array, - computeUnboxedP $ R.map (truncate . mag) arrInv+ -- Do the inverse transform to get back to image space.+ arrInv <- fft2dP Inverse arrFilt+ + -- Get the magnitude of the transformed array, + computeUnboxedP $ R.map (truncate . mag) arrInv
examples/FFT/HighPass3d/src-repa/Main.hs view
@@ -1,85 +1,86 @@ {-# LANGUAGE PatternGuards #-} -import Data.Array.Repa.Algorithms.FFT-import Data.Array.Repa.Algorithms.DFT.Center-import Data.Array.Repa.Algorithms.Complex-import Data.Array.Repa.Algorithms.ColorRamp-import Data.Array.Repa.IO.BMP-import Data.Array.Repa.IO.Timing-import Data.Array.Repa as R+import Data.Array.Repa.Algorithms.FFT as R+import Data.Array.Repa.Algorithms.DFT.Center as R+import Data.Array.Repa.Algorithms.Complex as R+import Data.Array.Repa.Algorithms.ColorRamp as R+import Data.Array.Repa.IO.BMP as R+import Data.Array.Repa.IO.Timing as R+import Data.Array.Repa as R+import Prelude as P+import qualified Data.Array.Repa.Repr.Unboxed as U import Data.Word import System.Environment import Control.Monad-import Prelude as P-import qualified Data.Array.Repa.Repr.Unboxed as U + main :: IO () main - = do args <- getArgs- case args of- [size, prefix] -> mainWithArgs (read size) prefix+ = do args <- getArgs+ case args of+ [size, prefix] -> mainWithArgs (read size) prefix _ -> putStr $ unlines- [ "Usage: repa-fft3d-highpass <size::Int> <prefix>"- , ""- , " Size must be a power of two."- , " You get a stack of prefix###.bmp files resulting from high-pass filtering a cube."- , "" ]- - + [ "Usage: repa-fft3d-highpass <size::Int> <prefix>"+ , ""+ , " Size must be a power of two."+ , " You get a stack of prefix###.bmp files resulting from high-pass filtering a cube."+ , "" ]+ + mainWithArgs size prefixOut = do- -- Generate a cube for initial data.- let shape = Z :. size :. size :. size- let cubeSize = size `div` 4- let center = size `div` 2- let cutoff = 4+ -- Generate a cube for initial data.+ let shape = Z :. size :. size :. size+ let cubeSize = size `div` 4+ let center = size `div` 2+ let cutoff = 4 - arrInit <- computeP+ arrInit <- computeP $ fromFunction shape - (\ix -> if isInCenteredCube center cubeSize ix - then (1, 0) else (0, 0))+ (\ix -> if isInCenteredCube center cubeSize ix + then (1, 0) else (0, 0)) - (arrFinal, t) <- time $ transformP arrInit center cutoff- putStr (prettyTime t)+ (arrFinal, t) <- time $ transformP arrInit center cutoff+ putStr (prettyTime t) - mapM_ (dumpSlice prefixOut arrFinal) [0..size - 1]+ mapM_ (dumpSlice prefixOut arrFinal) [0..size - 1] -- | To the high pass transform. transformP- :: Monad m+ :: Monad m => Array U DIM3 Complex- -> Int- -> Int- -> m (Array U DIM3 Complex)+ -> Int+ -> Int+ -> m (Array U DIM3 Complex) transformP arrInit center cutoff- = do -- Transform to frequency space.- let arrCentered = center3d arrInit- arrFreq <- fft3dP Forward arrCentered- - -- Zap out the high frequency components- let arrFilt = traverse arrFreq id (highpass center cutoff)- - -- Do the inverse transform to get back to image space.- fft3dP Inverse arrFilt+ = do -- Transform to frequency space.+ let arrCentered = center3d arrInit+ arrFreq <- fft3dP Forward arrCentered+ + -- Zap out the high frequency components+ let arrFilt = R.traverse arrFreq id (highpass center cutoff)+ + -- Do the inverse transform to get back to image space.+ fft3dP Inverse arrFilt -- | Dump a numbered slice of this array to a BMP file. dumpSlice - :: FilePath- -> Array U DIM3 Complex- -> Int- -> IO ()+ :: FilePath+ -> Array U DIM3 Complex+ -> Int+ -> IO () dumpSlice prefix arr sliceNum- = do let arrSlice = slice arr (Any :. sliceNum :. All)- arrGrey <- computeUnboxedP $ R.map (truncate . (* 255) . mag) arrSlice- let fileName = prefix P.++ (pad0 3 (show sliceNum)) P.++ ".bmp"+ = do let arrSlice = slice arr (Any :. sliceNum :. All)+ arrGrey <- computeUnboxedP $ R.map (truncate . (* 255) . mag) arrSlice+ let fileName = prefix P.++ (pad0 3 (show sliceNum)) P.++ ".bmp" - writeImageToBMP fileName- (U.zip3 arrGrey arrGrey arrGrey)+ writeImageToBMP fileName+ (U.zip3 arrGrey arrGrey arrGrey) pad0 n str = P.replicate (n - length str) '0' P.++ str@@ -87,15 +88,15 @@ {-# INLINE isInCenteredCube #-} isInCenteredCube center cutoff ix@(_ :. z :. y :. x)- = let high = center + cutoff- low = center - cutoff- in x >= low && x <= high+ = let high = center + cutoff+ low = center - cutoff+ in x >= low && x <= high && y >= low && y <= high && z >= low && z <= high {-# INLINE highpass #-} highpass center cutoff get ix- | isInCenteredCube center cutoff ix = 0- | otherwise = get ix+ | isInCenteredCube center cutoff ix = 0+ | otherwise = get ix
examples/Laplace/src-repa/Main.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE BangPatterns, RankNTypes, FlexibleContexts #-} -- | Solver for the Laplace equation--- You supply a BMP files specifying the boundary conditions.--- The output is written back to another BMP file.+-- You supply a BMP files specifying the boundary conditions.+-- The output is written back to another BMP file. -- import Data.Array.Repa.Algorithms.Pixel import Data.Array.Repa.Algorithms.ColorRamp-import Data.Array.Repa.IO.BMP +import Data.Array.Repa.IO.BMP import Data.Array.Repa.IO.Timing import System.Environment import Data.Word@@ -16,112 +16,112 @@ import Prelude as P type Solver m - = Monad m- => Int -- ^ Number of iterations to use.- -> Array U DIM2 Double -- ^ Boundary value mask.- -> Array U DIM2 Double -- ^ Boundary values.- -> Array U DIM2 Double -- ^ Initial state.- -> m (Array U DIM2 Double)+ = Monad m+ => Int -- ^ Number of iterations to use.+ -> Array U DIM2 Double -- ^ Boundary value mask.+ -> Array U DIM2 Double -- ^ Boundary values.+ -> Array U DIM2 Double -- ^ Initial state.+ -> m (Array U DIM2 Double) solvers - = [ ("get", SG.solveLaplace)- , ("stencil", SS.solveLaplace) ]+ = [ ("get", SG.solveLaplace)+ , ("stencil", SS.solveLaplace) ] main :: IO () main - = do args <- getArgs- case args of- [strSolver, steps, fileInput, fileOutput] - -> let Just solver = lookup strSolver solvers- in laplace solver (read steps) fileInput fileOutput+ = do args <- getArgs+ case args of+ [strSolver, steps, fileInput, fileOutput] + -> let Just solver = lookup strSolver solvers+ in laplace solver (read steps) fileInput fileOutput - _ -> do- putStr usage- return ()+ _ -> do+ putStr usage+ return () -- | Command line usage information.-usage :: String-usage = unlines- [ "Usage: laplace <solver> <iterations> <input.bmp> <output.bmp>"- , ""- , " iterations :: Int Number of iterations to use in the solver."- , " input.bmp :: FileName Uncompressed RGB24 or RGBA32 BMP file for initial and boundary values."- , " output.bmp :: FileName BMP file to write output to."- , "" - , " solver = one of " P.++ show (P.map fst solvers)- , ""- , " Format of input file:"- , " Boundary values are indicated in greyscale,"- , " ie from the list [(x, x, x) | x <- [0 .. 255]]"- , " Non-boundary values are indicated in blue,"- , " ie (0, 0, 255)"- , " Any other pixel value is an error." - , ""- , " NOTE: For GHC 7.0.3, this runs better when you turn off the parallel"- , " garbage collector. Run with +RTS -qg"- , "" ]- +usage :: String+usage = unlines+ [ "Usage: laplace <solver> <iterations> <input.bmp> <output.bmp>"+ , ""+ , " iterations :: Int Number of iterations to use in the solver."+ , " input.bmp :: FileName Uncompressed RGB24 or RGBA32 BMP file for initial and boundary values."+ , " output.bmp :: FileName BMP file to write output to."+ , "" + , " solver = one of " P.++ show (P.map fst solvers)+ , ""+ , " Format of input file:"+ , " Boundary values are indicated in greyscale,"+ , " ie from the list [(x, x, x) | x <- [0 .. 255]]"+ , " Non-boundary values are indicated in blue,"+ , " ie (0, 0, 255)"+ , " Any other pixel value is an error." + , ""+ , " NOTE: For GHC 7.0.3, this runs better when you turn off the parallel"+ , " garbage collector. Run with +RTS -qg"+ , "" ]+ -- | Solve it. laplace :: Solver IO- -> Int -- ^ Number of iterations to use.- -> FilePath -- ^ Input file.- -> FilePath -- ^ Output file- -> IO ()+ -> Int -- ^ Number of iterations to use.+ -> FilePath -- ^ Input file.+ -> FilePath -- ^ Output file+ -> IO () laplace solve steps fileInput fileOutput = do- -- Load up the file containing boundary conditions.- arrImage <- liftM (either (error . show) id)- $ readImageFromBMP fileInput+ -- Load up the file containing boundary conditions.+ arrImage <- liftM (either (error . show) id)+ $ readImageFromBMP fileInput - arrBoundValue <- computeP $ R.map slurpBoundValue arrImage- arrBoundMask <- computeP $ R.map slurpBoundMask arrImage- let arrInitial = arrBoundValue - - -- Run the Laplace solver and print how long it took.- (arrFinal, t) <- time $ solve steps arrBoundMask arrBoundValue arrInitial+ arrBoundValue <- computeP $ R.map slurpBoundValue arrImage+ arrBoundMask <- computeP $ R.map slurpBoundMask arrImage+ let arrInitial = arrBoundValue + + -- Run the Laplace solver and print how long it took.+ (arrFinal, t) <- time $ solve steps arrBoundMask arrBoundValue arrInitial - putStr (prettyTime t)+ putStr (prettyTime t) - -- Write out the result to a file.- arrImageOut <- computeP- $ R.map rgb8OfDouble- $ R.map (rampColorHotToCold 0.0 1.0) arrFinal+ -- Write out the result to a file.+ arrImageOut <- computeP+ $ R.map rgb8OfDouble+ $ R.map (rampColorHotToCold 0.0 1.0) arrFinal - writeImageToBMP fileOutput arrImageOut+ writeImageToBMP fileOutput arrImageOut -- | Extract the boundary value from a RGB triple. slurpBoundValue :: (Word8, Word8, Word8) -> Double {-# INLINE slurpBoundValue #-} slurpBoundValue (!r, !g, !b)- -- A non-boundary value.- | r == 0 && g == 0 && b == 255 - = 0+ -- A non-boundary value.+ | r == 0 && g == 0 && b == 255 + = 0 - -- A boundary value.- | (r == g) && (r == b) - = fromIntegral (fromIntegral r :: Int) / 255- - | otherwise- = error $ "Unhandled pixel value in input " P.++ show (r, g, b)+ -- A boundary value.+ | (r == g) && (r == b) + = fromIntegral (fromIntegral r :: Int) / 255+ + | otherwise+ = error $ "Unhandled pixel value in input " P.++ show (r, g, b) -- | Extract boundary mask from a RGB triple. slurpBoundMask :: (Word8, Word8, Word8) -> Double {-# INLINE slurpBoundMask #-} slurpBoundMask (!r, !g, !b)- -- A non-boundary value.- | r == 0 && g == 0 && b == 255 - = 1+ -- A non-boundary value.+ | r == 0 && g == 0 && b == 255 + = 1 - -- A boundary value.- | (r == g) && (r == b) - = 0- - | otherwise- = error $ "Unhandled pixel value in input " P.++ show (r, g, b)+ -- A boundary value.+ | (r == g) && (r == b) + = 0+ + | otherwise+ = error $ "Unhandled pixel value in input " P.++ show (r, g, b)
examples/Laplace/src-repa/SolverGet.hs view
@@ -1,51 +1,51 @@ {-# LANGUAGE BangPatterns #-} module SolverGet- (solveLaplace)-where -import Data.Array.Repa as R+ (solveLaplace)+where +import Data.Array.Repa as R import Data.Array.Repa.Unsafe as R-import qualified Data.Array.Repa.Shape as S+import qualified Data.Array.Repa.Shape as S -- | Solver for the Laplace equation. solveLaplace- :: Monad m- => Int -- ^ Number of iterations to use.- -> Array U DIM2 Double -- ^ Boundary value mask.- -> Array U DIM2 Double -- ^ Boundary values.- -> Array U DIM2 Double -- ^ Initial state.- -> m (Array U DIM2 Double)+ :: Monad m+ => Int -- ^ Number of iterations to use.+ -> Array U DIM2 Double -- ^ Boundary value mask.+ -> Array U DIM2 Double -- ^ Boundary values.+ -> Array U DIM2 Double -- ^ Initial state.+ -> m (Array U DIM2 Double) solveLaplace steps arrBoundMask arrBoundValue arrInit = go steps arrInit- where go !i !arr- | i == 0 + where go !i !arr+ | i == 0 = return arr - | otherwise - = do arr' <- relaxLaplace arrBoundMask arrBoundValue arr+ | otherwise + = do arr' <- relaxLaplace arrBoundMask arrBoundValue arr go (i - 1) arr' {-# NOINLINE solveLaplace #-} -- | Perform matrix relaxation for the Laplace equation,--- using a stencil function.+-- using a stencil function. -- -- Computation fn is--- u'(i,j) = (u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1)) / 4+-- u'(i,j) = (u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1)) / 4 -- -- Apply the boundary conditions to this matrix.--- The mask matrix has 0 in places where boundary conditions hold--- and 1 otherwise.+-- The mask matrix has 0 in places where boundary conditions hold+-- and 1 otherwise. ----- The value matrix has the boundary condition value in places where it holds,--- and 0 otherwise.+-- The value matrix has the boundary condition value in places where it holds,+-- and 0 otherwise. -- relaxLaplace- :: Monad m- => Array U DIM2 Double -- ^ Boundary condition mask- -> Array U DIM2 Double -- ^ Boundary condition values- -> Array U DIM2 Double -- ^ Initial matrix- -> m (Array U DIM2 Double)+ :: Monad m+ => Array U DIM2 Double -- ^ Boundary condition mask+ -> Array U DIM2 Double -- ^ Boundary condition values+ -> Array U DIM2 Double -- ^ Initial matrix+ -> m (Array U DIM2 Double) relaxLaplace arrBoundMask arrBoundValue arr = computeP@@ -53,24 +53,24 @@ $ R.zipWith (*) arrBoundMask $ unsafeTraverse arr id elemFn where- _ :. height :. width - = extent arr+ _ :. height :. width + = extent arr - {-# INLINE elemFn #-}- elemFn !get !d@(sh :. i :. j)- = if isBorder i j- then get d- else (get (sh :. (i-1) :. j)- + get (sh :. i :. (j-1))- + get (sh :. (i+1) :. j)- + get (sh :. i :. (j+1))) / 4+ {-# INLINE elemFn #-}+ elemFn !get !d@(sh :. i :. j)+ = if isBorder i j+ then get d+ else (get (sh :. (i-1) :. j)+ + get (sh :. i :. (j-1))+ + get (sh :. (i+1) :. j)+ + get (sh :. i :. (j+1))) / 4 - -- Check if this element is on the border of the matrix.- -- If so we can't apply the stencil because we don't have all the neighbours.- {-# INLINE isBorder #-}- isBorder !i !j- = (i == 0) || (i >= width - 1) - || (j == 0) || (j >= height - 1) + -- Check if this element is on the border of the matrix.+ -- If so we can't apply the stencil because we don't have all the neighbours.+ {-# INLINE isBorder #-}+ isBorder !i !j+ = (i == 0) || (i >= width - 1) + || (j == 0) || (j >= height - 1) {-# INLINE relaxLaplace #-}
examples/Laplace/src-repa/SolverStencil.hs view
@@ -1,27 +1,28 @@-{-# LANGUAGE BangPatterns, TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE BangPatterns, TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module SolverStencil- (solveLaplace)-where -import Data.Array.Repa as A-import Data.Array.Repa.Stencil as A-import Data.Array.Repa.Stencil.Dim2 as A-import qualified Data.Array.Repa.Shape as S+ (solveLaplace)+where +import Data.Array.Repa as A+import Data.Array.Repa.Stencil as A+import Data.Array.Repa.Stencil.Dim2 as A+import qualified Data.Array.Repa.Shape as S import Language.Haskell.TH import Language.Haskell.TH.Quote + -- | Solver for the Laplace equation. solveLaplace- :: Monad m- => Int -- ^ Number of iterations to use.- -> Array U DIM2 Double -- ^ Boundary value mask.- -> Array U DIM2 Double -- ^ Boundary values.- -> Array U DIM2 Double -- ^ Initial state.- -> m (Array U DIM2 Double)+ :: Monad m+ => Int -- ^ Number of iterations to use.+ -> Array U DIM2 Double -- ^ Boundary value mask.+ -> Array U DIM2 Double -- ^ Boundary values.+ -> Array U DIM2 Double -- ^ Initial state.+ -> m (Array U DIM2 Double) solveLaplace !steps !arrBoundMask !arrBoundValue !arrInit = go steps arrInit- where go 0 !arr = return arr- go n !arr + where go 0 !arr = return arr+ go n !arr = do arr' <- relaxLaplace arr go (n - 1) arr'
examples/MMult/src-repa/Main.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards, PackageImports #-} import Solver-import Data.Array.Repa as A+import Data.Array.Repa as A import Data.Array.Repa.IO.Matrix import Data.Array.Repa.IO.Timing import Data.Array.Repa.Algorithms.Randomish@@ -9,98 +9,98 @@ import System.Environment import Control.Monad import System.Random-import Prelude as P+import Prelude as P -- Arg Parsing ---------------------------------------------------------------- data Arg- = ArgSolver String- | ArgMatrixRandom Int Int- | ArgMatrixFile FilePath- | ArgOutFile FilePath- deriving Show+ = ArgSolver String+ | ArgMatrixRandom Int Int+ | ArgMatrixFile FilePath+ | ArgOutFile FilePath+ deriving Show isArgMatrix arg = case arg of- ArgMatrixRandom{} -> True- ArgMatrixFile{} -> True- _ -> False+ ArgMatrixRandom{} -> True+ ArgMatrixFile{} -> True+ _ -> False -parseArgs [] = []+parseArgs [] = [] parseArgs (flag:xx)- | "-file" <- flag- , f:rest <- xx- = ArgMatrixFile f : parseArgs rest+ | "-file" <- flag+ , f:rest <- xx+ = ArgMatrixFile f : parseArgs rest - | "-out" <- flag- , f:rest <- xx- = ArgOutFile f : parseArgs rest- - | "-random" <- flag- , x:y:rest <- xx- = ArgMatrixRandom (read x) (read y) : parseArgs rest- - | otherwise - = error $ "bad arg " P.++ flag P.++ "\n"+ | "-out" <- flag+ , f:rest <- xx+ = ArgOutFile f : parseArgs rest+ + | "-random" <- flag+ , x:y:rest <- xx+ = ArgMatrixRandom (read x) (read y) : parseArgs rest+ + | otherwise + = error $ "bad arg " P.++ flag P.++ "\n" printHelp- = putStr - $ unlines- [ "Usage: mmult [args..]"- , ""- , " -random <height> <width> Use a random matrix of this size."- , " -file <filename> Read a matrix from this file."- , " -out <filename> Write resulting matrix to this file."- , ""- , " Format of matrix file:"- , " MATRIX"- , " <width> <height>"- , " <whitespace separated values..>"- , "" ]+ = putStr + $ unlines+ [ "Usage: mmult [args..]"+ , ""+ , " -random <height> <width> Use a random matrix of this size."+ , " -file <filename> Read a matrix from this file."+ , " -out <filename> Write resulting matrix to this file."+ , ""+ , " Format of matrix file:"+ , " MATRIX"+ , " <width> <height>"+ , " <whitespace separated values..>"+ , "" ] -- | Get a matrix from a file, or generate a random one. getMatrix :: Arg -> IO (Array U DIM2 Double) getMatrix arg = case arg of- ArgMatrixFile fileName - -> readMatrixFromTextFile fileName+ ArgMatrixFile fileName + -> readMatrixFromTextFile fileName - ArgMatrixRandom height width - -> return $ randomishDoubleArray (Z :. height :. width) (-100) 100 12345+ ArgMatrixRandom height width + -> return $ randomishDoubleArray (Z :. height :. width) (-100) 100 12345 -- Main ----------------------------------------------------------------------- main :: IO () main - = do args <- liftM parseArgs $ getArgs- main' args+ = do args <- liftM parseArgs $ getArgs+ main' args main' args- | [argMat1, argMat2] <- filter isArgMatrix args- , mArgOut <- listToMaybe [s | ArgOutFile s <- args]- = do - -- Get matrices from files, - -- or generate random ones we were asked to.- mat1 <- getMatrix argMat1- mat2 <- getMatrix argMat2+ | [argMat1, argMat2] <- filter isArgMatrix args+ , mArgOut <- listToMaybe [s | ArgOutFile s <- args]+ = do + -- Get matrices from files, + -- or generate random ones we were asked to.+ mat1 <- getMatrix argMat1+ mat2 <- getMatrix argMat2 - mat1 `deepSeqArray` mat2 `deepSeqArray` return ()- - -- Run the solver.- (matResult, t) <- time $ mmultP mat1 mat2+ mat1 `deepSeqArray` mat2 `deepSeqArray` return ()+ + -- Run the solver.+ (matResult, t) <- time $ mmultP mat1 mat2 - -- Print how long it took.- putStr (prettyTime t)+ -- Print how long it took.+ putStr (prettyTime t) - -- Print a checksum of all the elements+ -- Print a checksum of all the elements checkSum <- A.sumAllP matResult- putStrLn $ "checkSum = " P.++ show checkSum+ putStrLn $ "checkSum = " P.++ show checkSum - -- Write the output to file if requested.- case mArgOut of - Nothing -> return ()- Just fileOut -> writeMatrixToTextFile fileOut matResult- - | otherwise- = printHelp+ -- Write the output to file if requested.+ case mArgOut of + Nothing -> return ()+ Just fileOut -> writeMatrixToTextFile fileOut matResult+ + | otherwise+ = printHelp
examples/Sobel/src-repa/Main.hs view
@@ -3,52 +3,52 @@ -- | Apply Sobel operators to an image. import System.Environment-import Data.Array.Repa as R+import Data.Array.Repa as R import Data.Array.Repa.Algorithms.Pixel as R import Data.Array.Repa.IO.BMP import Data.Array.Repa.IO.Timing-import Prelude hiding (compare)+import Prelude hiding (compare) import Control.Monad import Solver import Debug.Trace main - = do args <- getArgs- case args of- [iterations, fileIn, fileOut] - -> run (read iterations) fileIn fileOut- _ -> putStrLn "Usage: sobel <iterations::Int> <fileIn.bmp> <fileOut.bmp>"+ = do args <- getArgs+ case args of+ [iterations, fileIn, fileOut] + -> run (read iterations) fileIn fileOut+ _ -> putStrLn "Usage: sobel <iterations::Int> <fileIn.bmp> <fileOut.bmp>" run iterations fileIn fileOut- = do -- Load the source image and convert it to greyscale+ = do -- Load the source image and convert it to greyscale traceEventIO "******** Sobel Read Image"- inputImage <- liftM (either (error . show) id) - $ readImageFromBMP fileIn+ inputImage <- liftM (either (error . show) id) + $ readImageFromBMP fileIn traceEventIO "******** Sobel Luminance" (greyImage :: Array U DIM2 Float) <- computeP $ R.map floatLuminanceOfRGB8 inputImage- + -- Run the filter. traceEventIO "******** Sobel Loop Start"- ((gX, gY), tElapsed)- <- time $ loop iterations greyImage+ ((gX, gY), tElapsed)+ <- time $ loop iterations greyImage traceEventIO "******** Sobel Loop End"- putStr $ prettyTime tElapsed- - -- Write out the magnitute of the vector gradient as the result image.+ putStr $ prettyTime tElapsed+ + -- Write out the magnitute of the vector gradient as the result image. traceEventIO "******** Sobel Magnitude"- outImage <- computeUnboxedP- $ R.map rgb8OfGreyFloat + outImage <- computeUnboxedP+ $ R.map rgb8OfGreyFloat $ R.map (/ 3)- $ R.zipWith magnitude gX gY + $ R.zipWith magnitude gX gY traceEventIO "******** Sobel Write Image"- writeImageToBMP fileOut outImage+ writeImageToBMP fileOut outImage loop :: Int -> Image -> IO (Image, Image)@@ -58,11 +58,11 @@ then return (img, img) else do traceEventIO $ "******** Sobel Loop " Prelude.++ show n- gX <- gradientX img- gY <- gradientY img - if (n == 1) - then return (gX, gY)- else loop (n - 1) img+ gX <- gradientX img+ gY <- gradientY img + if (n == 1) + then return (gX, gY)+ else loop (n - 1) img -- | Determine the squared magnitude of a vector.
examples/Sobel/src-repa/Solver.hs view
@@ -2,33 +2,33 @@ {-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-incomplete-patterns #-} module Solver - ( Image- , gradientX- , gradientY )+ ( Image+ , gradientX+ , gradientY ) where-import Data.Array.Repa as R+import Data.Array.Repa as R import Data.Array.Repa.Stencil as R import Data.Array.Repa.Stencil.Dim2 as R -type Image = Array U DIM2 Float+type Image = Array U DIM2 Float gradientX :: Monad m => Image -> m Image gradientX img- = computeP- $ forStencil2 (BoundConst 0) img- [stencil2| -1 0 1- -2 0 2- -1 0 1 |]+ = computeP+ $ forStencil2 (BoundConst 0) img+ [stencil2| -1 0 1+ -2 0 2+ -1 0 1 |] {-# NOINLINE gradientX #-} gradientY :: Monad m => Image -> m Image gradientY img- = computeP- $ forStencil2 (BoundConst 0) img- [stencil2| 1 2 1- 0 0 0- -1 -2 -1 |] + = computeP+ $ forStencil2 (BoundConst 0) img+ [stencil2| 1 2 1+ 0 0 0+ -1 -2 -1 |] {-# NOINLINE gradientY #-}
examples/UnitTesting/UnitTesting.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} module Main where import Data.Array.Repa import Data.Array.Repa.Arbitrary(forAll2UShaped, forAll2VShaped)
examples/Volume/Main.hs view
@@ -42,20 +42,20 @@ -- | Dump a numbered slice of this array to a BMP file. dumpSlice - :: FilePath -- output base name- -> Array F DIM3 Word16 -- source data- -> Int -- array slice number- -> Int -- low value for color ramp- -> Int -- high value for color ramp- -> IO ()+ :: FilePath -- output base name+ -> Array F DIM3 Word16 -- source data+ -> Int -- array slice number+ -> Int -- low value for color ramp+ -> Int -- high value for color ramp+ -> IO () dumpSlice fileBase arr sliceNum low high- = do -- slice out the part that we want from the cube - let arrSlice = slice arr (Any :. sliceNum :. All :. All)+ = do -- slice out the part that we want from the cube + let arrSlice = slice arr (Any :. sliceNum :. All :. All) -- select a part of the large dynamic range- let arrBrack :: Array D DIM2 Word16- arrBrack = R.map (bracket low high . fromIntegral . flip16) arrSlice+ let arrBrack :: Array D DIM2 Word16+ arrBrack = R.map (bracket low high . fromIntegral . flip16) arrSlice -- invert the y coordinate so the image is the correct way around let (Z :. height :. _) = R.extent arrSlice@@ -63,7 +63,7 @@ (\get (Z :. y :. x) -> get (Z :. (height - 1) - y :. x)) -- dump the slice back as word16- R.writeArrayToStorableFile (fileBase P.++ ".w16") arrInv+ R.writeArrayToStorableFile (fileBase P.++ ".w16") arrInv -- colorise and write to BMP file let arrColor :: Array D DIM2 (Double, Double, Double)
repa-examples.cabal view
@@ -1,5 +1,5 @@ Name: repa-examples-Version: 3.3.1.1+Version: 3.4.0.1 License: BSD3 License-file: LICENSE Author: The DPH Team@@ -16,12 +16,18 @@ Synopsis: Examples using the Repa array library. +Flag llvm+ Description: Compile via LLVM. This produces much better object code,+ but you need to have the LLVM compiler installed. + Default: False++ Executable repa-canny Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-algorithms == 3.3.1.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-algorithms == 3.4.0.* Main-is: examples/Canny/src-repa/Main.hs hs-source-dirs: examples/Canny/src-repa .@@ -29,17 +35,19 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-mmult Build-depends: - base == 4.7.*,- random == 1.0.*,- repa == 3.3.1.*,- repa-io == 3.3.1.*,- repa-algorithms == 3.3.1.*+ base == 4.8.*,+ random == 1.1.*,+ repa == 3.4.0.*,+ repa-io == 3.4.0.*,+ repa-algorithms == 3.4.0.* Main-is: examples/MMult/src-repa/Main.hs other-modules: Solver@@ -48,18 +56,20 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-laplace Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-io == 3.3.1.*,- template-haskell == 2.9.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-io == 3.4.0.*,+ template-haskell == 2.10.* Main-is: examples/Laplace/src-repa/Main.hs other-modules: SolverGet SolverStencil@@ -68,16 +78,18 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-fft2d Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-algorithms == 3.3.1.*,- repa-io == 3.3.1.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-algorithms == 3.4.0.*,+ repa-io == 3.4.0.* Main-is: examples/FFT/FFT2d/src-repa/Main.hs hs-source-dirs: examples/FFT/FFT2d/src-repa .@@ -85,18 +97,20 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-fft2d-highpass Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-algorithms == 3.3.1.*,- repa-io == 3.3.1.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-algorithms == 3.4.0.*,+ repa-io == 3.4.0.* Main-is: examples/FFT/HighPass2d/src-repa/Main.hs hs-source-dirs: examples/FFT/HighPass2d/src-repa .@@ -104,18 +118,19 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100-+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-fft3d-highpass Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-algorithms == 3.3.1.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-algorithms == 3.4.0.* Main-is: examples/FFT/HighPass3d/src-repa/Main.hs hs-source-dirs: examples/FFT/HighPass3d/src-repa .@@ -123,18 +138,20 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-blur Build-depends: - base == 4.7.*,+ base == 4.8.*, vector == 0.10.*,- repa == 3.3.1.*,- repa-algorithms == 3.3.1.*+ repa == 3.4.0.*,+ repa-algorithms == 3.4.0.* Main-is: examples/Blur/src-repa/Main.hs hs-source-dirs: examples/Blur/src-repa .@@ -142,17 +159,19 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-sobel Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-algorithms == 3.3.1.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-algorithms == 3.4.0.* Main-is: examples/Sobel/src-repa/Main.hs other-modules: Solver@@ -161,33 +180,38 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 Executable repa-volume Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- repa-io == 3.3.1.*+ base == 4.8.*,+ repa == 3.4.0.*,+ repa-io == 3.4.0.* Main-is: examples/Volume/Main.hs ghc-options: -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3 + Executable repa-unit-test Build-depends: - base == 4.7.*,- repa == 3.3.1.*,- QuickCheck == 2.7.*+ base == 4.8.*,+ repa == 3.4.0.*,+ QuickCheck == 2.8.* Main-is: examples/UnitTesting/UnitTesting.hs hs-source-dirs: examples/UnitTesting .@@ -195,8 +219,11 @@ -rtsopts -threaded -eventlog- -Odph -fllvm -optlo-O3- -fno-liberate-case+ -Odph -fno-liberate-case -funfolding-use-threshold100 -funfolding-keeness-factor100+ if flag(llvm)+ ghc-options:+ -fllvm -optlo-O3+