diff --git a/Graphics/Gloss/Raster/Field.hs b/Graphics/Gloss/Raster/Field.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Raster/Field.hs @@ -0,0 +1,216 @@ +{-# 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) +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 continuous 2D function. +animateField + :: Display + -- ^ Display mode. + -> (Int, Int) + -- ^ Pixels 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 + = let (winSizeX, winSizeY) = sizeOfDisplay display + + {-# INLINE frame #-} + frame !time + = return + $ makeFrame 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) + -- ^ Pixels 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 multiplication " + P.++ show (zoomX, zoomY) + else let (winSizeX, winSizeY) = sizeOfDisplay display + in winSizeX `seq` winSizeY `seq` + play display black stepRate + initWorld + (\world -> + world `seq` + makeFrame winSizeX winSizeY zoomX zoomY (makePixel world)) + handleEvent + stepWorld +{-# INLINE playField #-} + + +-- Frame ---------------------------------------------------------------------- +{-# INLINE sizeOfDisplay #-} +sizeOfDisplay :: Display -> (Int, Int) +sizeOfDisplay display + = case display of + InWindow _ s _ -> s + FullScreen s -> s + +{-# INLINE makeFrame #-} +makeFrame + :: Int -> Int -> Int -> Int + -> (Point -> Color) -> Picture +makeFrame !winSizeX !winSizeY !zoomX !zoomY !makePixel + = let -- Size of the raw image to render. + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + + 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') + + {-# 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[makeFrame]: start frame evaluation." + (arrRGB :: Array F DIM2 Word32) + <- R.computeP + $ R.map conv + $ R.map unpackColor + $ R.fromFunction (Z :. sizeY :. sizeX) + $ pixelOfIndex + traceEventIO "Gloss.Raster[makeFrame]: 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 + + +-- | 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)) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2011-2012 Benjamin Lippmeier + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + condition: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gloss-raster.cabal b/gloss-raster.cabal new file mode 100644 --- /dev/null +++ b/gloss-raster.cabal @@ -0,0 +1,34 @@ +Name: gloss-raster +Version: 1.7.2.1 +License: MIT +License-file: LICENSE +Author: Ben Lippmeier +Maintainer: benl@ouroborus.net +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: provisional +Category: Graphics +Homepage: http://gloss.ouroborus.net +Bug-reports: gloss@ouroborus.net +Description: + Parallel rendering of raster images. + +Synopsis: + Parallel rendering of raster images. + +Tested-with: GHC == 6.12.1, GHC == 7.0.1 + +Library + Build-Depends: + base == 4.*, + ghc-prim == 0.2.*, + containers >= 0.3.0 && < 0.5.0, + gloss == 1.7.2.*, + repa == 3.1.* + + ghc-options: -Odph -fno-liberate-case -fllvm -optlo-O3 + + Exposed-modules: + Graphics.Gloss.Raster.Field + +