{-# LANGUAGE BangPatterns, MagicHash, PatternGuards, ScopedTypeVariables #-} -- | Rendering of continuous 2D functions as raster fields. -- -- 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.Field ( -- * Color module Graphics.Gloss.Data.Color , rgb, rgb8, rgb8w -- * Display functions , Display (..) , Point , animateField , playField -- * Frame creation , makePicture , makeFrame) 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 Data.Array.Repa.Repr.HintInterleave 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 continuous 2D function. animateField :: Display -- ^ Display mode. -> (Int, Int) -- ^ Number of pixels to draw per point. -> (Float -> Point -> Color) -- ^ Function to compute the color at a particular point. -- -- It is passed the time in seconds since the program started, -- and a point between (-1, -1) and (+1, +1). -> IO () animateField display (zoomX, zoomY) makePixel = 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 = return $ makePicture winSizeX winSizeY zoomX zoomY (makePixel time) in animateFixedIO display black frame {-# 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) -- ^ Number of pixels to draw per point. -> Int -- ^ Number of simulation steps to take -- for each second of real time -> world -- ^ The initial world. -> (world -> Point -> Color) -- ^ Function to compute the color of the world at the given point. -> (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 () 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 scale factor " P.++ show (zoomX, zoomY) else let (winSizeX, winSizeY) = sizeOfDisplay display in winSizeX `seq` winSizeY `seq` play display black stepRate initWorld (\world -> world `seq` makePicture winSizeX winSizeY zoomX zoomY (makePixel world)) handleEvent stepWorld {-# INLINE playField #-} sizeOfDisplay :: Display -> (Int, Int) sizeOfDisplay display = case display of InWindow _ s _ -> s FullScreen s -> s {-# INLINE sizeOfDisplay #-} -- Picture -------------------------------------------------------------------- makePicture :: Int -- Window Size X -> Int -- Window Size Y -> Int -- Pixels X -> Int -- Pixels Y -> (Point -> Color) -> Picture makePicture !winSizeX !winSizeY !zoomX !zoomY !makePixel = let -- Size of the raw image to render. sizeX = winSizeX `div` zoomX sizeY = winSizeY `div` zoomY {-# INLINE conv #-} conv (r, g, b) = let 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[makePicture]: start frame evaluation." (arrRGB :: Array F DIM2 Word32) <- R.computeP $ R.map conv $ makeFrame sizeX sizeY makePixel traceEventIO "Gloss.Raster[makePicture]: done, returning picture." -- Wrap the ForeignPtr from the Array as a gloss picture. let picture = Scale (fromIntegral zoomX) (fromIntegral zoomY) $ bitmapOfForeignPtr sizeX sizeY -- raw image size (R.toForeignPtr $ unsafeCoerce arrRGB) -- the image data. False -- don't cache this in texture memory. return picture {-# INLINE makePicture #-} -- Frame ---------------------------------------------------------------------- makeFrame :: Int -- Array Size X -> Int -- Array Size Y -> (Point -> Color) -> Array (I D) DIM2 (Word8, Word8, Word8) makeFrame !sizeX !sizeY !makePixel = let -- Size of the raw image to render. fsizeX, fsizeY :: Float !fsizeX = fromIntegral sizeX !fsizeY = fromIntegral sizeY fsizeX2, fsizeY2 :: Float !fsizeX2 = fsizeX / 2 !fsizeY2 = fsizeY / 2 -- Midpoint of image. midX, midY :: Int !midX = sizeX `div` 2 !midY = sizeY `div` 2 {-# INLINE pixelOfIndex #-} pixelOfIndex (Z :. y :. x) = let x' = fromIntegral (x - midX) / fsizeX2 y' = fromIntegral (y - midY) / fsizeY2 in makePixel (x', y') in R.hintInterleave $ R.map unpackColor $ R.fromFunction (Z :. sizeY :. sizeX) $ pixelOfIndex {-# 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 #-}