diff --git a/Graphics/Gloss/Internals/Data/Picture.hs b/Graphics/Gloss/Internals/Data/Picture.hs --- a/Graphics/Gloss/Internals/Data/Picture.hs +++ b/Graphics/Gloss/Internals/Data/Picture.hs @@ -9,7 +9,7 @@ , Picture(..) -- * Bitmaps - , BitmapData + , BitmapData, PixelFormat(..), BitmapFormat(..), RowOrder(..) , bitmapOfForeignPtr , bitmapOfByteString , bitmapOfBMP @@ -93,11 +93,15 @@ -- | A bitmap image with a width, height and some 32-bit RGBA -- bitmap data. - -- + -- -- The boolean flag controls whether Gloss should cache the data - -- between frames for speed. If you are programatically generating - -- the image for each frame then use `False`. If you have loaded it - -- from a file then use `True`. + -- in GPU memory between frames. If you are programatically generating + -- the image for each frame then use @False@. If you have loaded it + -- from a file then use @True@. + -- Setting @False@ for static images will make rendering slower + -- than it needs to be. + -- Setting @True@ for dynamically generated images will cause a + -- GPU memory leak. | Bitmap Int Int BitmapData Bool -- Color ------------------------------------------ @@ -130,16 +134,16 @@ -- Bitmaps -------------------------------------------------------------------- -- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap with the given -- width and height. - +-- -- The boolean flag controls whether Gloss should cache the data -- between frames for speed. If you are programatically generating -- the image for each frame then use `False`. If you have loaded it -- from a file then use `True`. -bitmapOfForeignPtr :: Int -> Int -> ForeignPtr Word8 -> Bool -> Picture -bitmapOfForeignPtr width height fptr cacheMe +bitmapOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture +bitmapOfForeignPtr width height fmt fptr cacheMe = let len = width * height * 4 - bdata = BitmapData len fptr - in Bitmap width height bdata cacheMe + bdata = BitmapData len fmt fptr + in Bitmap width height bdata cacheMe -- | O(size). Copy a `ByteString` of RGBA data into a bitmap with the given @@ -149,9 +153,8 @@ -- between frames for speed. If you are programatically generating -- the image for each frame then use `False`. If you have loaded it -- from a file then use `True`. -{-# NOINLINE bitmapOfByteString #-} -bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture -bitmapOfByteString width height bs cacheMe +bitmapOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> Picture +bitmapOfByteString width height fmt bs cacheMe = unsafePerformIO $ do let len = width * height * 4 ptr <- mallocBytes len @@ -160,17 +163,17 @@ BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len - let bdata = BitmapData len fptr + let bdata = BitmapData len fmt fptr return $ Bitmap width height bdata cacheMe +{-# NOINLINE bitmapOfByteString #-} -- | O(size). Copy a `BMP` file into a bitmap. -{-# NOINLINE bitmapOfBMP #-} bitmapOfBMP :: BMP -> Picture bitmapOfBMP bmp = unsafePerformIO $ do let (width, height) = bmpDimensions bmp - let bs = unpackBMPToRGBA32 bmp + let bs = unpackBMPToRGBA32 bmp let len = width * height * 4 ptr <- mallocBytes len @@ -179,10 +182,10 @@ BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len - let bdata = BitmapData len fptr - reverseRGBA bdata + let bdata = BitmapData len (BitmapFormat BottomToTop PxRGBA) fptr return $ Bitmap width height bdata True +{-# NOINLINE bitmapOfBMP #-} -- | Load an uncompressed 24 or 32bit RGBA BMP file as a bitmap. @@ -192,5 +195,4 @@ case ebmp of Left err -> error $ show err Right bmp -> return $ bitmapOfBMP bmp - diff --git a/Graphics/Gloss/Internals/Rendering/Bitmap.hs b/Graphics/Gloss/Internals/Rendering/Bitmap.hs --- a/Graphics/Gloss/Internals/Rendering/Bitmap.hs +++ b/Graphics/Gloss/Internals/Rendering/Bitmap.hs @@ -3,84 +3,64 @@ -- | Helper functions for rendering bitmaps module Graphics.Gloss.Internals.Rendering.Bitmap ( BitmapData(..) - , reverseRGBA + , BitmapFormat(..), PixelFormat(..), RowOrder(..) , bitmapPath - , freeBitmapData - ) + , freeBitmapData) where import Data.Data import Foreign -- | Abstract 32-bit RGBA bitmap data. -data BitmapData - = BitmapData - Int -- length (in bytes) - (ForeignPtr Word8) -- pointer to data +data BitmapData + = BitmapData + { bitmapDataLength :: Int -- length (in bytes) + , bitmapFormat :: BitmapFormat + , bitmapPointer :: (ForeignPtr Word8) } deriving (Eq, Data, Typeable) +-- | Description of how the bitmap is layed out in memory. +-- +-- * Prior version of Gloss assumed `BitmapFormat BottomToTop PxAGBR` +-- +data BitmapFormat + = BitmapFormat + { rowOrder :: RowOrder + , pixelFormat :: PixelFormat } + deriving (Eq, Data, Typeable, Show, Ord) + + +-- | Order of rows in an image are either: +-- +-- * `TopToBottom` - the top row, followed by the next-lower row and so on. +-- * `BottomToTop` - the bottom row followed by the next-higher row and so on. +-- +data RowOrder + = TopToBottom + | BottomToTop + deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded) + + +-- | Pixel formats describe the order of the color channels in memory. +data PixelFormat + = PxRGBA | PxABGR + deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded) + + instance Show BitmapData where show _ = "BitmapData" -- | Generates the point path to display the bitmap centred bitmapPath :: Float -> Float -> [(Float, Float)] -bitmapPath width height +bitmapPath width height = [(-width', -height'), (width', -height'), (width', height'), (-width', height')] where width' = width / 2 height' = height / 2 --- | Destructively reverse the byte order in an array. --- This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA -reverseRGBA :: BitmapData -> IO () -reverseRGBA (BitmapData length8 fptr) - = withForeignPtr fptr (reverseRGBA_ptr length8) - - --- | Destructively reverses the byte order in an array. -reverseRGBA_ptr :: Int -> Ptr Word8 -> IO () -reverseRGBA_ptr length8 ptr8 - = go (length8 `div` 4) (castPtr ptr8) 0 - where - go :: Int -> Ptr Word32 -> Int -> IO () - go len ptr count - | count < len - = do curr <- peekElemOff ptr count - let byte0 = shift (isolateByte0 curr) 24 - let byte1 = shift (isolateByte1 curr) 8 - let byte2 = shift (isolateByte2 curr) (-8) - let byte3 = shift (isolateByte3 curr) (-24) - pokeElemOff ptr count (byte0 .|. byte1 .|. byte2 .|. byte3) - go len ptr (count + 1) - - | otherwise - = return () - -- | Frees the allocated memory given to OpenGL to avoid a memory leak freeBitmapData :: Ptr Word8 -> IO () -{-# INLINE freeBitmapData #-} freeBitmapData p = free p - - --- | These functions work as bit masks to isolate the Word8 components -{-# INLINE isolateByte0 #-} -isolateByte0 :: Word32 -> Word32 -isolateByte0 word = - word .&. (255 :: Word32) - -{-# INLINE isolateByte1 #-} -isolateByte1 :: Word32 -> Word32 -isolateByte1 word = - word .&. (65280 :: Word32) - -{-# INLINE isolateByte2 #-} -isolateByte2 :: Word32 -> Word32 -isolateByte2 word = - word .&. (16711680 :: Word32) - -{-# INLINE isolateByte3 #-} -isolateByte3 :: Word32 -> Word32 -isolateByte3 word = - word .&. (4278190080 :: Word32) +{-# INLINE freeBitmapData #-} diff --git a/Graphics/Gloss/Internals/Rendering/Circle.hs b/Graphics/Gloss/Internals/Rendering/Circle.hs --- a/Graphics/Gloss/Internals/Rendering/Circle.hs +++ b/Graphics/Gloss/Internals/Rendering/Circle.hs @@ -15,13 +15,13 @@ -- the size of the circle on the screen, not its intrinsic radius. -- If the viewport has been zoomed-in then we need to use more segments. -- -{-# INLINE circleSteps #-} circleSteps :: Float -> Int circleSteps sDiam | sDiam < 8 = 8 | sDiam < 16 = 16 | sDiam < 32 = 32 | otherwise = 64 +{-# INLINE circleSteps #-} -- Circle --------------------------------------------------------------------- diff --git a/Graphics/Gloss/Internals/Rendering/Picture.hs b/Graphics/Gloss/Internals/Rendering/Picture.hs --- a/Graphics/Gloss/Internals/Rendering/Picture.hs +++ b/Graphics/Gloss/Internals/Rendering/Picture.hs @@ -163,6 +163,11 @@ -- Bitmap ------------------------------- Bitmap width height imgData cacheMe -> do + let rowInfo = + case rowOrder (bitmapFormat imgData) of + BottomToTop -> [(0,0), (1,0), (1,1), (0,1)] + TopToBottom -> [(0,1), (1,1), (1,0), (0,0)] + -- Load the image data into a texture, -- or grab it from the cache if we've already done that before. tex <- loadTexture (stateTextures state) width height imgData cacheMe @@ -191,7 +196,7 @@ GL.vertex $ GL.Vertex2 (gf pX) (gf pY)) (bitmapPath (fromIntegral width) (fromIntegral height)) - [(0,0), (1.0,0), (1.0,1.0), (0,1.0)] + rowInfo -- Restore color GL.currentColor $= oldColor @@ -284,8 +289,11 @@ -> Bool -> IO Texture -installTexture width height bitmapData@(BitmapData _ fptr) cacheMe +installTexture width height bitmapData@(BitmapData _ fmt fptr) cacheMe = do + let glFormat = case pixelFormat fmt of + PxABGR -> GL.RGBA + PxRGBA -> GL.ABGR -- Allocate texture handle for texture [tex] <- GL.genObjectNames 1 GL.textureBinding GL.Texture2D $= Just tex @@ -304,7 +312,7 @@ (gsizei width) (gsizei height)) 0 - (GL.PixelData GL.RGBA GL.UnsignedInt8888 ptr) + (GL.PixelData glFormat GL.UnsignedInt8888 ptr) -- Make a stable name that we can use to identify this data again. -- If the user gives us the same texture data at the same size then we @@ -321,7 +329,7 @@ -- | If this texture does not have its `cacheMe` flag set then delete it from --- OpenGL and free the memory. +-- OpenGL and free the GPU memory. freeTexture :: Texture -> IO () freeTexture tex | texCacheMe tex = return () @@ -349,11 +357,9 @@ vertexPFs :: [(Float, Float)] -> IO () -{-# INLINE vertexPFs #-} vertexPFs [] = return () vertexPFs ((x, y) : rest) = do GL.vertex $ GL.Vertex2 (gf x) (gf y) vertexPFs rest - - +{-# INLINE vertexPFs #-} diff --git a/Graphics/Gloss/Internals/Rendering/State.hs b/Graphics/Gloss/Internals/Rendering/State.hs --- a/Graphics/Gloss/Internals/Rendering/State.hs +++ b/Graphics/Gloss/Internals/Rendering/State.hs @@ -14,7 +14,8 @@ import qualified Graphics.Rendering.OpenGL.GL as GL --- | Render options settings +-- | Abstract Gloss render state which holds references to textures +-- loaded into the GPU context. data State = State { -- | Whether to use color @@ -69,4 +70,3 @@ , stateLineSmooth = False , stateTextures = textures } - diff --git a/Graphics/Gloss/Rendering.hs b/Graphics/Gloss/Rendering.hs --- a/Graphics/Gloss/Rendering.hs +++ b/Graphics/Gloss/Rendering.hs @@ -15,6 +15,7 @@ -- * Bitmaps , BitmapData + , BitmapFormat(..), PixelFormat(..), RowOrder(..) , bitmapOfForeignPtr , bitmapOfByteString , bitmapOfBMP diff --git a/gloss-rendering.cabal b/gloss-rendering.cabal --- a/gloss-rendering.cabal +++ b/gloss-rendering.cabal @@ -1,5 +1,5 @@ name: gloss-rendering -version: 1.9.3.1 +version: 1.10.1.1 license: MIT license-file: LICENSE author: Elise Huard @@ -31,7 +31,7 @@ base == 4.8.*, containers == 0.5.*, bytestring == 0.10.*, - OpenGL == 2.12.*, + OpenGL >= 2.12 && < 3.1, GLUT == 2.7.*, bmp == 1.2.*