diff --git a/examples/Blur/src-repa/Main.hs b/examples/Blur/src-repa/Main.hs --- a/examples/Blur/src-repa/Main.hs +++ b/examples/Blur/src-repa/Main.hs @@ -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 " ] +usage = putStr $ unlines + [ "repa-blur " ] -- | 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 #-} - + diff --git a/examples/Canny/src-repa/Main.hs b/examples/Canny/src-repa/Main.hs --- a/examples/Canny/src-repa/Main.hs +++ b/examples/Canny/src-repa/Main.hs @@ -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 [ ]" , " " ] 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 #-} diff --git a/examples/FFT/FFT2d/src-repa/Main.hs b/examples/FFT/FFT2d/src-repa/Main.hs --- a/examples/FFT/FFT2d/src-repa/Main.hs +++ b/examples/FFT/FFT2d/src-repa/Main.hs @@ -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 " - , " " - , " 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 " + , " " + , " 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 diff --git a/examples/FFT/HighPass2d/src-repa/Main.hs b/examples/FFT/HighPass2d/src-repa/Main.hs --- a/examples/FFT/HighPass2d/src-repa/Main.hs +++ b/examples/FFT/HighPass2d/src-repa/Main.hs @@ -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 " - , "" - , " Image dimensions must be powers of two, eg 128x512 or 64x256" - , "" ] - - + [ "Usage: repa-fft-highpass " + , "" + , " 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 diff --git a/examples/FFT/HighPass3d/src-repa/Main.hs b/examples/FFT/HighPass3d/src-repa/Main.hs --- a/examples/FFT/HighPass3d/src-repa/Main.hs +++ b/examples/FFT/HighPass3d/src-repa/Main.hs @@ -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 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 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 diff --git a/examples/Laplace/src-repa/Main.hs b/examples/Laplace/src-repa/Main.hs --- a/examples/Laplace/src-repa/Main.hs +++ b/examples/Laplace/src-repa/Main.hs @@ -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 " - , "" - , " 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 " + , "" + , " 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) diff --git a/examples/Laplace/src-repa/SolverGet.hs b/examples/Laplace/src-repa/SolverGet.hs --- a/examples/Laplace/src-repa/SolverGet.hs +++ b/examples/Laplace/src-repa/SolverGet.hs @@ -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 #-} diff --git a/examples/Laplace/src-repa/SolverStencil.hs b/examples/Laplace/src-repa/SolverStencil.hs --- a/examples/Laplace/src-repa/SolverStencil.hs +++ b/examples/Laplace/src-repa/SolverStencil.hs @@ -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' diff --git a/examples/MMult/src-repa/Main.hs b/examples/MMult/src-repa/Main.hs --- a/examples/MMult/src-repa/Main.hs +++ b/examples/MMult/src-repa/Main.hs @@ -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 Use a random matrix of this size." - , " -file Read a matrix from this file." - , " -out Write resulting matrix to this file." - , "" - , " Format of matrix file:" - , " MATRIX" - , " " - , " " - , "" ] + = putStr + $ unlines + [ "Usage: mmult [args..]" + , "" + , " -random Use a random matrix of this size." + , " -file Read a matrix from this file." + , " -out Write resulting matrix to this file." + , "" + , " Format of matrix file:" + , " MATRIX" + , " " + , " " + , "" ] -- | 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 diff --git a/examples/Sobel/src-repa/Main.hs b/examples/Sobel/src-repa/Main.hs --- a/examples/Sobel/src-repa/Main.hs +++ b/examples/Sobel/src-repa/Main.hs @@ -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 " + = do args <- getArgs + case args of + [iterations, fileIn, fileOut] + -> run (read iterations) fileIn fileOut + _ -> putStrLn "Usage: sobel " 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. diff --git a/examples/Sobel/src-repa/Solver.hs b/examples/Sobel/src-repa/Solver.hs --- a/examples/Sobel/src-repa/Solver.hs +++ b/examples/Sobel/src-repa/Solver.hs @@ -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 #-} diff --git a/examples/UnitTesting/UnitTesting.hs b/examples/UnitTesting/UnitTesting.hs --- a/examples/UnitTesting/UnitTesting.hs +++ b/examples/UnitTesting/UnitTesting.hs @@ -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) diff --git a/examples/Volume/Main.hs b/examples/Volume/Main.hs --- a/examples/Volume/Main.hs +++ b/examples/Volume/Main.hs @@ -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) diff --git a/repa-examples.cabal b/repa-examples.cabal --- a/repa-examples.cabal +++ b/repa-examples.cabal @@ -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 +