diff --git a/Graphics/Gloss/Accelerate/Raster/Array.hs b/Graphics/Gloss/Accelerate/Raster/Array.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Accelerate/Raster/Array.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Graphics.Gloss.Accelerate.Raster.Array +-- Copyright : [2013..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Rendering of Accelerate arrays as raster images +-- +module Graphics.Gloss.Accelerate.Raster.Array ( + + module Graphics.Gloss.Accelerate.Data.Point, + module Data.Array.Accelerate.Data.Colour.RGBA, + + -- * Display functions + Render, Display(..), + animateArrayWith, + animateArrayIOWith, + playArrayWith, + playArrayIOWith, + + -- * Picture creation + makePicture, + +) where + +-- Friends +import Graphics.Gloss.Accelerate.Render +import Graphics.Gloss.Accelerate.Data.Point +import Graphics.Gloss.Accelerate.Data.Picture +import Data.Array.Accelerate.Data.Colour.RGBA + +-- Standard library +import Prelude as P + +-- Gloss +import Graphics.Gloss.Data.Display ( Display(..) ) +import Graphics.Gloss.Data.Picture ( Picture(..) ) +import Graphics.Gloss.Interface.IO.Animate as G ( animateFixedIO, black ) +import Graphics.Gloss.Interface.Pure.Game as G ( Event, play ) +import Graphics.Gloss.Interface.IO.Game as G ( playIO ) + +-- Accelerate +import Data.Array.Accelerate as A + + +-- Animate -------------------------------------------------------------------- +-- ------- + +-- | Animate a bitmap generated by an Accelerate computation, specifying the +-- backend used to render the image. +-- +animateArrayWith + :: Render -- ^ Method to render the array (backend 'run1' function to use) + -> Display -- ^ Display mode + -> (Int, Int) -- ^ Number of pixels to draw per point + -> (Exp Float -> Acc (Array DIM2 Colour)) + -- ^ A function to construct an array of colours. The function + -- should return an array of the same extent every time it is + -- applied. + -- + -- It is passed the time in seconds since the program started. + -> IO () +animateArrayWith render display (zoomX, zoomY) makeArray + | zoomX P.< 1 P.|| zoomY P.< 1 + = error "Graphics.Gloss.Raster: invalid pixel scalar factor" + + | otherwise + = let picture = makePicture render zoomX zoomY (makeArray . the) + . fromList Z + . return + in +#if MIN_VERSION_gloss(1,10,0) + animateFixedIO display G.black (return . picture) (\_ -> return ()) +#else + animateFixedIO display G.black (return . picture) +#endif + + +-- | Animate a bitmap generated by an Accelerate computation and IO actions, specifying the +-- backend used to render the image. +-- +animateArrayIOWith + :: Arrays world + => Render -- ^ Method to render the array (backend 'run1' function) + -> Display -- ^ Display mode + -> (Int, Int) -- ^ Number of pixels to draw per point + -> (Float -> IO world) -- ^ Extract world from time in seconds + -- since the program started + -> (Acc world -> Acc (Array DIM2 Colour)) + -- ^ A function to construct an array of colours. The function + -- should return an array of the same extent every time it is + -- applied. + -- + -- It is passed the world + -> IO () +animateArrayIOWith render display (zoomX, zoomY) makeWorld makeArray + | zoomX P.< 1 P.|| zoomY P.< 1 + = error "Graphics.Gloss.Raster: invalid pixel scalar factor" + + | otherwise + = let picture = fmap (makePicture render zoomX zoomY makeArray) + . makeWorld + in +#if MIN_VERSION_gloss(1,10,0) + animateFixedIO display G.black picture (\_ -> return ()) +#else + animateFixedIO display G.black picture +#endif + + +-- | Play with a bitmap generated by an Accelerate computation, specifying the +-- method used to render the world. +-- +playArrayWith + :: Arrays world + => Render -- ^ Method to render the world (backend 'run1' function) + -> 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 + -> state -- ^ The initial state + -> (state -> world) -- ^ Extract the world state + -> (Acc world -> Acc (Array DIM2 Colour)) + -- ^ Compute the colour of the world + -> (Event -> state -> state) + -- ^ Handle input events + -> (Float -> state -> state) + -- ^ Step the world one iteration. + -- It is passed the time in seconds since the program started. + -> IO () +playArrayWith render display (zoomX, zoomY) stepRate + initState makeWorld makeArray handleEvent stepState + | zoomX P.< 1 P.|| zoomY P.< 1 + = error "Graphics.Gloss.Raster: invalid pixel scalar factor" + + | otherwise + = let picture = makePicture render zoomX zoomY makeArray + . makeWorld + in + play display G.black stepRate initState picture handleEvent stepState + + +-- | Play with a bitmap generated by an Accelerate computation and IO actions, specifying the +-- method used to render the world. +-- +playArrayIOWith + :: Arrays world + => Render -- ^ Method to render the world (backend 'run1' function) + -> 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 + -> state -- ^ The initial state + -> (state -> IO world) -- ^ Extract the world state + -> (Acc world -> Acc (Array DIM2 Colour)) + -- ^ Compute the colour of the world + -> (Event -> state -> IO state) + -- ^ Handle input events + -> (Float -> state -> IO state) + -- ^ Step the world one iteration. + -- It is passed the time in seconds since the program started. + -> IO () +playArrayIOWith render display (zoomX, zoomY) stepRate + initState makeWorld makeArray handleEvent stepState + | zoomX P.< 1 P.|| zoomY P.< 1 + = error "Graphics.Gloss.Raster: invalid pixel scalar factor" + + | otherwise + = let picture = fmap (makePicture render zoomX zoomY makeArray) + . makeWorld + in + G.playIO display G.black stepRate initState picture handleEvent stepState + + +-- Internals +-- --------- + +-- | Lift an Accelerate computation from a 'world' to an image into a real +-- Haskell-land function that executes the computation of the image and wraps +-- it as a Gloss picture ready for display. +-- +makePicture + :: Arrays world + => Render -- ^ method to compute the image + -> Int -- ^ pixel width + -> Int -- ^ pixel height + -> (Acc world -> Acc (Array DIM2 Colour)) -- ^ function to create the image + -> (world -> Picture) -- ^ new function that generates the picture +makePicture render zoomX zoomY makeArray + = let -- compute the image + -- assume the host is a little-endian architecture + pixels = render (A.map (packRGBA . opaque) . makeArray) + + -- Turn the array into a Gloss picture + picture world = bitmapOfArray (pixels world) False + in + Scale (P.fromIntegral zoomX) (P.fromIntegral zoomY) . picture + diff --git a/Graphics/Gloss/Accelerate/Raster/Field.hs b/Graphics/Gloss/Accelerate/Raster/Field.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Accelerate/Raster/Field.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Graphics.Gloss.Accelerate.Raster.Field +-- Copyright : [2013..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Rendering of 2D functions as raster fields +-- +module Graphics.Gloss.Accelerate.Raster.Field ( + + module Graphics.Gloss.Accelerate.Data.Point, + module Data.Array.Accelerate.Data.Colour.RGBA, + + -- * Display functions + Render, Display(..), + animateFieldWith, + animateFieldIOWith, + playFieldWith, + playFieldIOWith, + + -- * Field creation + makeField, + +) where + +-- Friends +import Graphics.Gloss.Accelerate.Render +import Graphics.Gloss.Accelerate.Data.Point +import Graphics.Gloss.Accelerate.Raster.Array +import Data.Array.Accelerate.Data.Colour.RGBA + +-- Standard library +import Prelude as P +#if MIN_VERSION_gloss(1,11,0) +import System.IO.Unsafe +#endif + +-- Gloss +import Graphics.Gloss.Interface.Pure.Game ( Event ) +#if MIN_VERSION_gloss(1,11,0) +import Graphics.Gloss.Interface.Environment +#endif + +-- Accelerate +import Data.Array.Accelerate as A + + +-- Animate -------------------------------------------------------------------- +-- ------- + +-- | Animate a continuous 2D function, specifying the backend used to render +-- the field. +-- +animateFieldWith + :: Render -- ^ Method to render the field + -> Display -- ^ Display mode + -> (Int, Int) -- ^ Number of pixels to draw per point + -> (Exp Float -> Exp Point -> Exp Colour) + -- ^ A function to compute the colour 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 () +animateFieldWith render display zoom@(zoomX, zoomY) makePixel + = let -- size of the window + (winSizeX, winSizeY) = sizeOfDisplay display + + -- size of the raw image to render + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + in + animateArrayWith + render + display + zoom + (makeField sizeX sizeY makePixel) + + +-- | Animate a continuous 2D function using IO actions, specifying the backend used to render +-- the field. +-- +animateFieldIOWith + :: Arrays world + => Render -- ^ Method to render the field + -> Display -- ^ Display mode + -> (Int, Int) -- ^ Number of pixels to draw per point + -> (Float -> IO world) -- ^ Extract world from time in seconds + -- since the program started + -> (Acc world -> Exp Point -> Exp Colour) + -- ^ A function to compute the colour at a particular point. + -- + -- It is passed the world, and + -- a point between (-1,1) and (+1,1). + -> IO () +animateFieldIOWith render display zoom@(zoomX, zoomY) makeWorld makePixel + = let -- size of the window + (winSizeX, winSizeY) = sizeOfDisplay display + + -- size of the raw image to render + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + in + animateArrayIOWith + render + display + zoom + makeWorld + (makeField sizeX sizeY makePixel) + + +-- | Play a game with a continuous 2D function, specifying the method used to +-- render the field. +-- +playFieldWith + :: Arrays world + => Render -- ^ Method to render the field + -> 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 + -> state -- ^ The initial state + -> (state -> world) -- ^ Extract the world state + -> (Acc world -> Exp Point -> Exp Colour) + -- ^ Compute the colour of the world at a given point + -> (Event -> state -> state) + -- ^ Handle input events + -> (Float -> state -> state) + -- ^ Step the world one iteration. + -- It is passed the time in seconds since the program started. + -> IO () +playFieldWith render display zoom@(zoomX, zoomY) stepRate + initState makeWorld makePixel handleEvent stepState + = let -- size of the window + (winSizeX, winSizeY) = sizeOfDisplay display + + -- size of the raw image to render + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + in + playArrayWith + render + display + zoom + stepRate + initState + makeWorld + (makeField sizeX sizeY makePixel) + handleEvent + stepState + +-- | Play a game with a continuous 2D function using IO actions, specifying the method used to +-- render the field. +-- +playFieldIOWith + :: Arrays world + => Render -- ^ Method to render the field + -> 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 + -> state -- ^ The initial state + -> (state -> IO world) -- ^ Extract the world state + -> (Acc world -> Exp Point -> Exp Colour) + -- ^ Compute the colour of the world at a given point + -> (Event -> state -> IO state) + -- ^ Handle input events + -> (Float -> state -> IO state) + -- ^ Step the world one iteration. + -- It is passed the time in seconds since the program started. + -> IO () +playFieldIOWith render display zoom@(zoomX, zoomY) stepRate + initState makeWorld makePixel handleEvent stepState + = let -- size of the window + (winSizeX, winSizeY) = sizeOfDisplay display + + -- size of the raw image to render + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + in + playArrayIOWith + render + display + zoom + stepRate + initState + makeWorld + (makeField sizeX sizeY makePixel) + handleEvent + stepState + + +-- Internals +-- --------- + +sizeOfDisplay :: Display -> (Int, Int) +sizeOfDisplay display + = case display of + InWindow _ s _ -> s +#if MIN_VERSION_gloss(1,11,0) + FullScreen -> unsafePerformIO getScreenSize +#else + FullScreen s -> s +#endif + + +-- | Lift a point-wise colouring function into an image creation function. +-- +-- The parameter 'world' at this point can be arbitrary. However if you use +-- this function standalone, you will probably at some point want the result +-- of this function to plug into 'makePicture' and thus 'Render', and thus be +-- a unary function from 'Arrays' to 'Arrays'. +-- +makeField + :: Int -- ^ image width + -> Int -- ^ image height + -> (world -> Exp Point -> Exp Colour) -- ^ function to apply at each point + -> (world -> Acc (Array DIM2 Colour)) -- ^ new function that generates the field +makeField sizeX sizeY makePixel world + = A.generate (constant (Z :. sizeY :. sizeX)) + (makePixel world . pointOfIndex sizeX sizeY) + diff --git a/Graphics/Gloss/Accelerate/Render.hs b/Graphics/Gloss/Accelerate/Render.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Accelerate/Render.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Graphics.Gloss.Accelerate.Render +-- Copyright : [2013..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Graphics.Gloss.Accelerate.Render + where + +import Data.Array.Accelerate + + +-- | The type for executing Accelerate computations. This matches the 'run1' +-- style of executing programs. +-- +-- Some variants of the display functions take an argument of this type, which +-- determine how computations are executed. +-- +type Render = forall a b. (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Trevor L. McDonell + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Trevor L. McDonell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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-accelerate.cabal b/gloss-raster-accelerate.cabal new file mode 100644 --- /dev/null +++ b/gloss-raster-accelerate.cabal @@ -0,0 +1,42 @@ +Name: gloss-raster-accelerate +Version: 0.2.0.0 +Synopsis: Parallel rendering of raster images using Accelerate +Description: Parallel rendering of raster images using Accelerate +License: BSD3 +License-file: LICENSE +Author: Trevor L. McDonell +Maintainer: Trevor L. McDonell +Category: Graphics +Build-type: Simple +Cabal-version: >=1.10 + + +Library + Exposed-modules: + Graphics.Gloss.Accelerate.Render + Graphics.Gloss.Accelerate.Raster.Array + Graphics.Gloss.Accelerate.Raster.Field + + build-depends: + base >= 4.6 && < 4.10 + , accelerate >= 0.16 + , colour-accelerate >= 0.1 + , gloss >= 1.9 + , gloss-accelerate >= 0.2 + + ghc-options: + -Wall -O2 + + default-language: + Haskell2010 + +source-repository head + type: git + location: https://github.com/tmcdonell/gloss-raster-accelerate + +source-repository this + type: git + tag: 0.2.0.0 + location: https://github.com/tmcdonell/gloss-raster-accelerate + +-- vim: nospell