diff --git a/Graphics/Gloss/Raster/Array.hs b/Graphics/Gloss/Raster/Array.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Raster/Array.hs @@ -0,0 +1,195 @@ + +{-# LANGUAGE BangPatterns, MagicHash, PatternGuards, ScopedTypeVariables #-} + +-- | Rendering of Repa arrays as raster images. +-- +-- Gloss programs should be compiled with @-threaded@, otherwise the GHC runtime +-- will limit the frame-rate to around 20Hz. +-- +-- The performance of programs using this interface is sensitive to how much +-- boxing and unboxing the GHC simplifier manages to eliminate. For the best +-- result add INLINE pragmas to all of your numeric functions and use the following +-- compile options. +-- +-- @-threaded -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -fllvm -optlo-O3@ +-- +-- See the examples the @raster@ directory of the @gloss-examples@ package +-- for more details. +-- +module Graphics.Gloss.Raster.Array + ( -- * Color + module Graphics.Gloss.Data.Color + , rgb, rgb8, rgb8w + + -- * Display functions + , Display (..) + , animateArray + , playArray) +where +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Interface.Pure.Game +import Graphics.Gloss.Interface.IO.Animate +import Data.Word +import System.IO.Unsafe +import Unsafe.Coerce +import Debug.Trace +import Data.Bits +import Data.Array.Repa as R +import Data.Array.Repa.Repr.ForeignPtr as R +import Prelude as P + +-- Color ---------------------------------------------------------------------- +-- | Construct a color from red, green, blue components. +-- +-- Each component is clipped to the range [0..1] +rgb :: Float -> Float -> Float -> Color +rgb r g b = makeColor r g b 1.0 +{-# INLINE rgb #-} + + +-- | Construct a color from red, green, blue components. +-- +-- Each component is clipped to the range [0..255] +rgb8 :: Int -> Int -> Int -> Color +rgb8 r g b = makeColor8 r g b 255 +{-# INLINE rgb8 #-} + + +-- | Construct a color from red, green, blue components. +rgb8w :: Word8 -> Word8 -> Word8 -> Color +rgb8w r g b = makeColor8 (fromIntegral r) (fromIntegral g) (fromIntegral b) 255 +{-# INLINE rgb8w #-} + + +-- Animate -------------------------------------------------------------------- +-- | Animate a bitmap generated from a Repa array. +animateArray + :: Display + -- ^ Display mode. + -> (Int, Int) + -- ^ Number of pixels to draw per element. + -> (Float -> Array D DIM2 Color) + -- ^ A function to construct a delayed array for the given time. + -- The function should return an array of the same extent each + -- time it is applied. + -- + -- It is passed the time in seconds since the program started. + -> IO () + +animateArray display scale@(scaleX, scaleY) makeArray + = scaleX `seq` scaleY `seq` + if scaleX < 1 || scaleY < 1 + then error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor " + P.++ show (scaleX, scaleY) + else let {-# INLINE frame #-} + frame !time = return $ makeFrame scale (makeArray time) + in animateFixedIO display black frame +{-# INLINE animateArray #-} +-- INLINE so the repa functions fuse with the users client functions. + + +-- Play ----------------------------------------------------------------------- +-- | Play with a bitmap generated from a Repa array. +playArray + :: Display + -- ^ Display mode. + -> (Int, Int) + -- ^ Number of pixels to draw per element. + -> Int -- ^ Number of simulation steps to take + -- for each second of real time + -> world + -- ^ The initial world. + -> (world -> Array D DIM2 Color) + -- ^ Function to convert the world to an array. + -> (Event -> world -> world) + -- ^ Function to handle input events. + -> (Float -> world -> world) + -- ^ Function to step the world one iteration. + -- It is passed the time in seconds since the program started. + -> IO () +playArray !display scale@(scaleX, scaleY) !stepRate !initWorld !makeArray !handleEvent !stepWorld + = scaleX `seq` scaleY `seq` + if scaleX < 1 || scaleY < 1 + then error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor " + P.++ show scale + else let {-# INLINE frame #-} + frame !world = makeFrame scale (makeArray world) + + in play display black + stepRate + initWorld + frame + handleEvent + stepWorld +{-# INLINE playArray #-} + + +-- Frame ---------------------------------------------------------------------- +{-# INLINE makeFrame #-} +makeFrame :: (Int, Int) -> Array D DIM2 Color -> Picture +makeFrame (scaleX, scaleY) !array + = let -- Size of the array + _ :. sizeY :. sizeX + = R.extent array + + {-# INLINE convColor #-} + convColor :: Color -> Word32 + convColor color + = let (r, g, b) = unpackColor color + r' = fromIntegral r + g' = fromIntegral g + b' = fromIntegral b + a = 255 + + !w = unsafeShiftL r' 24 + .|. unsafeShiftL g' 16 + .|. unsafeShiftL b' 8 + .|. a + in w + + in unsafePerformIO $ do + + -- Define the image, and extract out just the RGB color components. + -- We don't need the alpha because we're only drawing one image. + traceEventIO "Gloss.Raster[makeFrame]: start frame evaluation." + (arrRGB :: Array F DIM2 Word32) + <- R.computeP $ R.map convColor array + traceEventIO "Gloss.Raster[makeFrame]: done, returning picture." + + -- Wrap the ForeignPtr from the Array as a gloss picture. + let picture + = Scale (fromIntegral scaleX) (fromIntegral scaleY) + $ bitmapOfForeignPtr + sizeX sizeY -- raw image size + (R.toForeignPtr $ unsafeCoerce arrRGB) + -- the image data. + False -- don't cache this in texture memory. + + return picture + + +-- | Float to Word8 conversion because the one in the GHC libraries +-- doesn't have enout specialisations and goes via Integer. +{-# INLINE word8OfFloat #-} +word8OfFloat :: Float -> Word8 +word8OfFloat f + = fromIntegral (truncate f :: Int) + + +{-# INLINE unpackColor #-} +unpackColor :: Color -> (Word8, Word8, Word8) +unpackColor c + | (r, g, b, _) <- rgbaOfColor c + = ( word8OfFloat (r * 255) + , word8OfFloat (g * 255) + , word8OfFloat (b * 255)) + +{-# INLINE sizeOfDisplay #-} +sizeOfDisplay :: Display -> (Int, Int) +sizeOfDisplay display + = case display of + InWindow _ s _ -> s + FullScreen s -> s + diff --git a/Graphics/Gloss/Raster/Field.hs b/Graphics/Gloss/Raster/Field.hs --- a/Graphics/Gloss/Raster/Field.hs +++ b/Graphics/Gloss/Raster/Field.hs @@ -69,7 +69,7 @@ :: Display -- ^ Display mode. -> (Int, Int) - -- ^ Pixels per point. + -- ^ Number of pixels to draw per point. -> (Float -> Point -> Color) -- ^ Function to compute the color at a particular point. -- @@ -78,7 +78,12 @@ -> IO () animateField display (zoomX, zoomY) makePixel - = let (winSizeX, winSizeY) = sizeOfDisplay display + = zoomX `seq` zoomY `seq` + if zoomX < 1 || zoomY < 1 + then error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor " + P.++ show (zoomX, zoomY) + else + let (winSizeX, winSizeY) = sizeOfDisplay display {-# INLINE frame #-} frame !time @@ -89,14 +94,13 @@ {-# INLINE animateField #-} -- INLINE so the repa functions fuse with the users client functions. - -- Play ----------------------------------------------------------------------- -- | Play a game with a continous 2D function. playField :: Display -- ^ Display mode. -> (Int, Int) - -- ^ Pixels per point. + -- ^ Number of pixels to draw per point. -> Int -- ^ Number of simulation steps to take -- for each second of real time -> world @@ -112,7 +116,7 @@ playField !display (zoomX, zoomY) !stepRate !initWorld !makePixel !handleEvent !stepWorld = zoomX `seq` zoomY `seq` if zoomX < 1 || zoomY < 1 - then error $ "Graphics.Gloss.Raster.Field: invalid pixel multiplication " + then error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor " P.++ show (zoomX, zoomY) else let (winSizeX, winSizeY) = sizeOfDisplay display in winSizeX `seq` winSizeY `seq` diff --git a/gloss-raster.cabal b/gloss-raster.cabal --- a/gloss-raster.cabal +++ b/gloss-raster.cabal @@ -1,5 +1,5 @@ Name: gloss-raster -Version: 1.7.2.1 +Version: 1.7.4.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -22,13 +22,13 @@ Build-Depends: base == 4.*, ghc-prim == 0.2.*, - containers >= 0.3.0 && < 0.5.0, - gloss == 1.7.2.*, - repa == 3.1.* + containers >= 0.3.0 && < 0.5.0, + gloss == 1.7.4.*, + repa >= 3.1.2.1 && < 3.2 ghc-options: -Odph -fno-liberate-case -fllvm -optlo-O3 Exposed-modules: Graphics.Gloss.Raster.Field - + Graphics.Gloss.Raster.Array