diff --git a/Graphics/Gloss/Raster/Array.hs b/Graphics/Gloss/Raster/Array.hs --- a/Graphics/Gloss/Raster/Array.hs +++ b/Graphics/Gloss/Raster/Array.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns, MagicHash, PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Rendering of Repa arrays as raster images. -- -- Gloss programs should be compiled with @-threaded@, otherwise the GHC runtime @@ -7,17 +10,19 @@ -- 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. +-- compile options. -- --- @-threaded -Odph -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -fllvm -optlo-O3@ +-- @-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 +-- 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 + , rgb, rgbI, rgb8w + , rgb', rgbI' -- * Display functions , Display (..) @@ -29,9 +34,12 @@ 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.Interface.Environment +import Graphics.Gloss.Rendering import Data.Word import System.IO.Unsafe import Unsafe.Coerce @@ -44,8 +52,8 @@ -- Color ---------------------------------------------------------------------- -- | Construct a color from red, green, blue components. --- --- Each component is clipped to the range [0..1] +-- +-- 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 #-} @@ -53,33 +61,53 @@ -- | 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 #-} +-- 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 = makeColor8 (fromIntegral r) (fromIntegral g) (fromIntegral b) 255 +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 -- ^ 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 + -- 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 @@ -87,7 +115,7 @@ P.++ show (scaleX, scaleY) else let {-# INLINE frame #-} frame !time = return $ makeFrame scale (makeArray time) - in animateFixedIO display black frame + in animateFixedIO display black frame (const $ return ()) {-# INLINE animateArray #-} -- INLINE so the repa functions fuse with the users client functions. @@ -95,18 +123,18 @@ -- AnimateIO -------------------------------------------------------------------- -- | Animate a bitmap generated from a Repa array, via the IO monad. animateArrayIO - :: Display + :: 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 + -- 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 @@ -114,7 +142,7 @@ P.++ show (scaleX, scaleY) else let {-# INLINE frame #-} frame !time = fmap (makeFrame scale) (makeArray time) - in animateFixedIO display black frame + in animateFixedIO display black frame (const $ return ()) {-# INLINE animateArrayIO #-} -- INLINE so the repa functions fuse with the users client functions. @@ -122,19 +150,19 @@ -- Play ----------------------------------------------------------------------- -- | Play with a bitmap generated from a Repa array. playArray - :: Display + :: Display -- ^ Display mode. - -> (Int, Int) + -> (Int, Int) -- ^ Number of pixels to draw per element. -> Int -- ^ Number of simulation steps to take -- for each second of real time - -> world + -> world -- ^ The initial world. -> (world -> Array D DIM2 Color) -- ^ Function to convert the world to an array. - -> (Event -> world -> world) + -> (Event -> world -> world) -- ^ Function to handle input events. - -> (Float -> world -> world) + -> (Float -> world -> world) -- ^ Function to step the world one iteration. -- It is passed the time in seconds since the program started. -> IO () @@ -142,13 +170,13 @@ !initWorld !makeArray !handleEvent !stepWorld = scaleX `seq` scaleY `seq` if scaleX < 1 || scaleY < 1 - then error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor " + 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 + stepRate initWorld frame handleEvent @@ -159,19 +187,19 @@ -- PlayIO ----------------------------------------------------------------------- -- | Play with a bitmap generated from a Repa array, via the IO monad. playArrayIO - :: Display + :: Display -- ^ Display mode. - -> (Int, Int) + -> (Int, Int) -- ^ Number of pixels to draw per element. -> Int -- ^ Number of simulation steps to take -- for each second of real time - -> world + -> world -- ^ The initial world. -> (world -> IO (Array D DIM2 Color)) -- ^ Function to convert the world to an array. - -> (Event -> world -> IO world) + -> (Event -> world -> IO world) -- ^ Function to handle input events. - -> (Float -> world -> IO world) + -> (Float -> world -> IO world) -- ^ Function to step the world one iteration. -- It is passed the time in seconds since the program started. -> IO () @@ -179,13 +207,13 @@ !initWorld !makeArray !handleEvent !stepWorld = scaleX `seq` scaleY `seq` if scaleX < 1 || scaleY < 1 - then error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor " + 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 + stepRate initWorld frame handleEvent @@ -197,7 +225,7 @@ makeFrame :: (Int, Int) -> Array D DIM2 Color -> Picture makeFrame (scaleX, scaleY) !array = let -- Size of the array - _ :. sizeY :. sizeX + _ :. sizeY :. sizeX = R.extent array convColor :: Color -> Word32 @@ -206,14 +234,14 @@ r' = fromIntegral r g' = fromIntegral g b' = fromIntegral b - a = 255 + a = 255 !w = unsafeShiftL r' 24 .|. unsafeShiftL g' 16 .|. unsafeShiftL b' 8 .|. a in w - {-# INLINE convColor #-} + {-# INLINE convColor #-} in unsafePerformIO $ do @@ -225,11 +253,12 @@ traceEventIO "Gloss.Raster[makeFrame]: done, returning picture." -- Wrap the ForeignPtr from the Array as a gloss picture. - let picture + let picture = Scale (fromIntegral scaleX) (fromIntegral scaleY) $ bitmapOfForeignPtr sizeX sizeY -- raw image size - (R.toForeignPtr $ unsafeCoerce arrRGB) + (BitmapFormat BottomToTop PxABGR) + (R.toForeignPtr $ unsafeCoerce arrRGB) -- the image data. False -- don't cache this in texture memory. @@ -241,7 +270,7 @@ -- doesn't have enout specialisations and goes via Integer. word8OfFloat :: Float -> Word8 word8OfFloat f - = fromIntegral (truncate f :: Int) + = fromIntegral (truncate f :: Int) {-# INLINE word8OfFloat #-} @@ -254,10 +283,10 @@ {-# INLINE unpackColor #-} -sizeOfDisplay :: Display -> (Int, Int) +sizeOfDisplay :: Display -> IO (Int, Int) sizeOfDisplay display = case display of - InWindow _ s _ -> s - FullScreen s -> s + InWindow _ s _ -> return s + FullScreen -> getScreenSize {-# INLINE sizeOfDisplay #-} 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 @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns, MagicHash, PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Rendering of continuous 2D functions as raster fields. -- @@ -8,23 +11,26 @@ -- 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. +-- 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 +-- 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 + , rgb, rgbI, rgb8w + , rgb', rgbI' -- * Display functions , Display (..) , Point , animateField + , animateFieldIO , playField + , playFieldIO -- * Frame creation , makePicture @@ -33,8 +39,11 @@ 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.Interface.Environment import Data.Word import System.IO.Unsafe import Unsafe.Coerce @@ -47,8 +56,8 @@ -- Color ---------------------------------------------------------------------- -- | Construct a color from red, green, blue components. --- --- Each component is clipped to the range [0..1] +-- +-- 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 #-} @@ -56,65 +65,114 @@ -- | 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 #-} +-- 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 = makeColor8 (fromIntegral r) (fromIntegral g) (fromIntegral b) 255 +rgb8w r g b = makeColorI (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 = makeColor 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 = makeColorI r g b 255 +{-# INLINE rgbI' #-} + + -- Animate -------------------------------------------------------------------- -- | Animate a continuous 2D function. animateField - :: Display + :: Display -- ^ Display mode. - -> (Int, Int) + -> (Int, Int) -- ^ Number of pixels to draw per point. - -> (Float -> Point -> Color) + -> (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 + else + do (winSizeX, winSizeY) <- sizeOfDisplay display - {-# INLINE frame #-} - frame !time - = return + let frame !time + = return $ makePicture winSizeX winSizeY zoomX zoomY (makePixel time) - in animateFixedIO display black frame + animateFixedIO display black frame (const $ return ()) + {-# INLINE animateField #-} -- INLINE so the repa functions fuse with the users client functions. +-- AnimateIO -------------------------------------------------------------------- +-- | Animate a continuous 2D function, via the IO monad. +animateFieldIO + :: Display + -- ^ Display mode. + -> (Int, Int) + -- ^ Number of pixels to draw per point. + -> (Float -> IO (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 () + +animateFieldIO 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 + do (winSizeX, winSizeY) <- sizeOfDisplay display + + let frame !time + = makePicture winSizeX winSizeY zoomX zoomY <$> makePixel time + + animateFixedIO display black frame (const $ return ()) + +{-# INLINE animateFieldIO #-} + -- Play ----------------------------------------------------------------------- -- | Play a game with a continous 2D function. -playField - :: Display +playField + :: Display -- ^ Display mode. - -> (Int, Int) + -> (Int, Int) -- ^ Number of pixels to draw per point. -> Int -- ^ Number of simulation steps to take -- for each second of real time - -> world + -> world -- ^ The initial world. - -> (world -> Point -> Color) + -> (world -> Point -> Color) -- ^ Function to compute the color of the world at the given point. - -> (Event -> world -> world) + -> (Event -> world -> world) -- ^ Function to handle input events. - -> (Float -> world -> world) + -> (Float -> world -> world) -- ^ Function to step the world one iteration. -- It is passed the time in seconds since the program started. -> IO () @@ -122,25 +180,70 @@ !initWorld !makePixel !handleEvent !stepWorld = zoomX `seq` zoomY `seq` if zoomX < 1 || zoomY < 1 - then error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor " + 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 + else do (winSizeX, winSizeY) <- sizeOfDisplay display + winSizeX `seq` winSizeY `seq` + play display black stepRate + ((winSizeX, winSizeY), initWorld) + (\((winSizeX', winSizeY'), world) -> + winSizeX' `seq` winSizeY' `seq` world `seq` + makePicture winSizeX' winSizeY' zoomX zoomY (makePixel world)) + (\event (winSize, world) -> + let winSize' = + case event of + EventResize dims -> dims + _ -> winSize + in (winSize', handleEvent event world)) + (fmap . stepWorld) {-# INLINE playField #-} +-- PlayIO ----------------------------------------------------------------------- +-- | Play a game with a continous 2D function, via the IO monad. +playFieldIO + :: 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 -> IO (Point -> Color)) + -- ^ Function to compute the color of the world at the given point. + -> (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 () +playFieldIO !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 do (winSizeX, winSizeY) <- sizeOfDisplay display + winSizeX `seq` winSizeY `seq` + playIO display black stepRate + ((winSizeX, winSizeY), initWorld) + (\((winSizeX', winSizeY'), world) -> + winSizeX' `seq` winSizeY' `seq` world `seq` + makePicture winSizeX' winSizeY' zoomX zoomY <$> makePixel world) + (\event (winSize, world) -> + let winSize' = + case event of + EventResize dims -> dims + _ -> winSize + in (,) winSize' <$> handleEvent event world) + (\time (winSize, world) -> (,) winSize <$> stepWorld time world) +{-# INLINE playFieldIO #-} -sizeOfDisplay :: Display -> (Int, Int) +sizeOfDisplay :: Display -> IO (Int, Int) sizeOfDisplay display = case display of - InWindow _ s _ -> s - FullScreen s -> s + InWindow _ s _ -> return s + FullScreen -> getScreenSize {-# INLINE sizeOfDisplay #-} @@ -157,12 +260,12 @@ sizeX = winSizeX `div` zoomX sizeY = winSizeY `div` zoomY - {-# INLINE conv #-} + {-# INLINE conv #-} conv (r, g, b) = let r' = fromIntegral r g' = fromIntegral g b' = fromIntegral b - a = 255 + a = 255 !w = unsafeShiftL r' 24 .|. unsafeShiftL g' 16 @@ -176,17 +279,18 @@ -- 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.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 + let picture = Scale (fromIntegral zoomX) (fromIntegral zoomY) $ bitmapOfForeignPtr sizeX sizeY -- raw image size - (R.toForeignPtr $ unsafeCoerce arrRGB) + (BitmapFormat BottomToTop PxABGR) + (R.toForeignPtr $ unsafeCoerce arrRGB) -- the image data. False -- don't cache this in texture memory. @@ -223,7 +327,7 @@ in makePixel (x', y') in R.hintInterleave - $ R.map unpackColor + $ R.map unpackColor $ R.fromFunction (Z :. sizeY :. sizeX) $ pixelOfIndex {-# INLINE makeFrame #-} @@ -234,7 +338,7 @@ -- doesn't have enout specialisations and goes via Integer. word8OfFloat :: Float -> Word8 word8OfFloat f - = fromIntegral (truncate f :: Int) + = fromIntegral (truncate f :: Int) {-# INLINE word8OfFloat #-} @@ -245,3 +349,4 @@ , word8OfFloat (g * 255) , word8OfFloat (b * 255)) {-# INLINE unpackColor #-} + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2012 Benjamin Lippmeier +Copyright (c) 2011-2016 The Gloss Development Team Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation diff --git a/gloss-raster.cabal b/gloss-raster.cabal --- a/gloss-raster.cabal +++ b/gloss-raster.cabal @@ -1,11 +1,11 @@ Name: gloss-raster -Version: 1.7.8.1 +Version: 1.13.1.2 License: MIT License-file: LICENSE Author: Ben Lippmeier Maintainer: benl@ouroborus.net Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >=1.10 Stability: provisional Category: Graphics Homepage: http://gloss.ouroborus.net @@ -16,21 +16,41 @@ Synopsis: Parallel rendering of raster images. -Tested-with: GHC == 6.12.1, GHC == 7.0.1 +Flag llvm + Description: Compile via LLVM. This produces much better object code + but your GHC needs to have been built against the LLVM compiler. + Default: False + +source-repository head + type: git + location: https://github.com/benl23x5/gloss + +source-repository this + type: git + tag: v1.13.0.2 + location: https://github.com/benl23x5/gloss + Library - Build-Depends: - base == 4.6.*, - ghc-prim == 0.3.*, - containers == 0.5.*, - repa == 3.2.*, - gloss == 1.7.8.* + Build-Depends: + base >= 4.8 && < 5 + , containers >= 0.5 && < 0.7 + , ghc-prim + , gloss == 1.13.* + , gloss-rendering == 1.13.* + , repa == 3.4.* + Default-Language: + Haskell2010 + ghc-options: - -Odph -fno-liberate-case - -fllvm -optlo-O3 + -O2 + -fmax-simplifier-iterations=20 + -fsimplifier-phases=3 + -fno-liberate-case Exposed-modules: Graphics.Gloss.Raster.Field Graphics.Gloss.Raster.Array +-- vim: nospell