gloss-raster-1.9.2.1: Graphics/Gloss/Raster/Array.hs
{-# 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, rgbI, rgb8w
, rgb', rgbI'
-- * Display functions
, Display (..)
, animateArray
, playArray
, animateArrayIO
, playArrayIO)
where
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Data.Display
import Graphics.Gloss.Data.Bitmap
import Graphics.Gloss.Interface.Pure.Game
import Graphics.Gloss.Interface.IO.Animate
import Graphics.Gloss.Interface.IO.Game
import Graphics.Gloss.Rendering
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 clamped 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 clamped to the range [0..255]
rgbI :: Int -> Int -> Int -> Color
rgbI r g b = makeColorI r g b 255
{-# INLINE rgbI #-}
-- | Construct a color from red, green, blue components.
rgb8w :: Word8 -> Word8 -> Word8 -> Color
rgb8w r g b = makeRawColorI (fromIntegral r) (fromIntegral g) (fromIntegral b) 255
{-# INLINE rgb8w #-}
-- | Like `rgb`, but take pre-clamped components for speed.
--
-- If you're building a new color for every pixel then use this version,
-- however if your components are out of range then the picture you get will
-- be implementation dependent.
rgb' :: Float -> Float -> Float -> Color
rgb' r g b = makeRawColor r g b 1.0
{-# INLINE rgb' #-}
-- | Like `rgbI`, but take pre-clamped components for speed.
--
-- If you're building a new color for every pixel then use this version,
-- however if your components are out of range then the picture you get will
-- be implementation dependent.
rgbI' :: Int -> Int -> Int -> Color
rgbI' r g b = makeRawColorI r g b 255
{-# INLINE rgbI' #-}
-- 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.
-- AnimateIO --------------------------------------------------------------------
-- | Animate a bitmap generated from a Repa array, via the IO monad.
animateArrayIO
:: Display
-- ^ Display mode.
-> (Int, Int)
-- ^ Number of pixels to draw per element.
-> (Float -> IO (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 ()
animateArrayIO 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 = fmap (makeFrame scale) (makeArray time)
in animateFixedIO display black frame
{-# INLINE animateArrayIO #-}
-- 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 #-}
-- PlayIO -----------------------------------------------------------------------
-- | Play with a bitmap generated from a Repa array, via the IO monad.
playArrayIO
:: 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 -> IO (Array D DIM2 Color))
-- ^ Function to convert the world to an array.
-> (Event -> world -> IO world)
-- ^ Function to handle input events.
-> (Float -> world -> IO world)
-- ^ Function to step the world one iteration.
-- It is passed the time in seconds since the program started.
-> IO ()
playArrayIO !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 = fmap (makeFrame scale) (makeArray world)
in playIO display black
stepRate
initWorld
frame
handleEvent
stepWorld
{-# INLINE playArrayIO #-}
-- Frame ----------------------------------------------------------------------
makeFrame :: (Int, Int) -> Array D DIM2 Color -> Picture
makeFrame (scaleX, scaleY) !array
= let -- Size of the array
_ :. sizeY :. sizeX
= R.extent array
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
{-# INLINE convColor #-}
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
{-# INLINE makeFrame #-}
-- | Float to Word8 conversion because the one in the GHC libraries
-- doesn't have enout specialisations and goes via Integer.
word8OfFloat :: Float -> Word8
word8OfFloat f
= fromIntegral (truncate f :: Int)
{-# INLINE word8OfFloat #-}
unpackColor :: Color -> (Word8, Word8, Word8)
unpackColor c
| (r, g, b, _) <- rgbaOfColor c
= ( word8OfFloat (r * 255)
, word8OfFloat (g * 255)
, word8OfFloat (b * 255))
{-# INLINE unpackColor #-}
sizeOfDisplay :: Display -> (Int, Int)
sizeOfDisplay display
= case display of
InWindow _ s _ -> s
FullScreen s -> s
{-# INLINE sizeOfDisplay #-}