diff --git a/Graphics/Gloss.hs b/Graphics/Gloss.hs --- a/Graphics/Gloss.hs +++ b/Graphics/Gloss.hs @@ -30,6 +30,11 @@ -- -- @Release Notes: -- +-- For 1.5.0: +-- * O(1) Conversion of ForeignPtrs to bitmaps. +-- * An extra flag on the Bitmap constructor allows bitmaps to be cached +-- in texture memory between frames. +-- -- For 1.4.0: -- Thanks to Christiaan Baaij: -- * Refactoring of Gloss internals to support multiple window manager backends. diff --git a/Graphics/Gloss/Data/Picture.hs b/Graphics/Gloss/Data/Picture.hs --- a/Graphics/Gloss/Data/Picture.hs +++ b/Graphics/Gloss/Data/Picture.hs @@ -5,14 +5,20 @@ , Vector , Path , Picture(..) + , BitmapData -- * Aliases for Picture constructors , blank, polygon, line, circle, thickCircle, text, bitmap , color, translate, rotate, scale , pictures - -- * Miscellaneous + -- * Loading Bitmaps + , bitmapOfForeignPtr + , bitmapOfByteString + , bitmapOfBMP , loadBMP + + -- * Miscellaneous , lineLoop , circleSolid @@ -23,10 +29,18 @@ import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Vector +import Graphics.Gloss.Internals.Render.Bitmap import Control.Monad -import Data.Monoid import Codec.BMP -import Data.ByteString (ByteString) +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Ptr +import Data.Word +import Data.Monoid +import Data.ByteString +import System.IO.Unsafe +import qualified Data.ByteString.Unsafe as BSU -- | A path through the x-y plane. @@ -56,12 +70,12 @@ -- | Some text to draw with a vector font. | Text String - -- | A bitmap image with a width, height and a ByteString holding the 32 bit RGBA bitmap data. + -- | A bitmap image with a width, height and a Vector holding the 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`. - | Bitmap Int Int ByteString Bool + | Bitmap Int Int BitmapData Bool -- Color ------------------------------------------ -- | A picture drawn with this color. @@ -109,7 +123,7 @@ text :: String -> Picture text = Text -bitmap :: Int -> Int -> ByteString -> Bool -> Picture +bitmap :: Int -> Int -> BitmapData -> Bool -> Picture bitmap = Bitmap color :: Color -> Picture -> Picture @@ -128,18 +142,59 @@ pictures = Pictures --- BMP file loader ------------------------------------------------------------ --- | An IO action that loads a BMP format file from the given path, and --- produces a picture. +-- Bitmaps -------------------------------------------------------------------- +-- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap. +bitmapOfForeignPtr :: Int -> Int -> ForeignPtr Word8 -> Bool -> Picture +bitmapOfForeignPtr width height fptr cacheMe + = let len = width * height * 4 + bdata = BitmapData len fptr + in Bitmap width height bdata cacheMe + + +-- | O(size). Copy a `ByteString` of RGBA data into a bitmap. +{-# NOINLINE bitmapOfByteString #-} +bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture +bitmapOfByteString width height bs cacheMe + = unsafePerformIO + $ do let len = width * height * 4 + ptr <- mallocBytes len + fptr <- newForeignPtr finalizerFree ptr + + BSU.unsafeUseAsCString bs + $ \cstr -> copyBytes ptr (castPtr cstr) len + + let bdata = BitmapData len fptr + return $ Bitmap width height bdata cacheMe + + +-- | 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 len = width * height * 4 + + ptr <- mallocBytes len + fptr <- newForeignPtr finalizerFree ptr + + BSU.unsafeUseAsCString bs + $ \cstr -> copyBytes ptr (castPtr cstr) len + + let bdata = BitmapData len fptr + reverseRGBA bdata + + return $ Bitmap width height bdata True + + +-- | Load an uncompressed 24 or 32bit RGBA BMP file as a bitmap. loadBMP :: FilePath -> IO Picture loadBMP filePath = do ebmp <- readBMP filePath case ebmp of Left err -> error $ show err - Right bmp - -> do let (width, height) = bmpDimensions bmp - let bs = bmpRawImageData bmp - return $ Bitmap width height bs True + Right bmp -> return $ bitmapOfBMP bmp -- Shapes ---------------------------------------------------------------------------------------- diff --git a/Graphics/Gloss/Internals/Render/Bitmap.hs b/Graphics/Gloss/Internals/Render/Bitmap.hs --- a/Graphics/Gloss/Internals/Render/Bitmap.hs +++ b/Graphics/Gloss/Internals/Render/Bitmap.hs @@ -2,15 +2,27 @@ -- | Helper functions for rendering bitmaps module Graphics.Gloss.Internals.Render.Bitmap - ( reverseRGBA + ( BitmapData(..) + , reverseRGBA , bitmapPath , freeBitmapData ) where import Foreign -import qualified Data.ByteString as B +-- | Abstract bitmap data. +data BitmapData + = BitmapData + Int -- length (in bytes) + (ForeignPtr Word8) -- pointer to data + deriving (Eq) + + +instance Show BitmapData where + show _ = "BitmapData" + + -- | Generates the point path to display the bitmap centred bitmapPath :: Float -> Float -> [(Float, Float)] bitmapPath width height @@ -19,28 +31,31 @@ height' = height / 2 --- | This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA -reverseRGBA :: B.ByteString -> IO (Ptr Word8) -reverseRGBA orig - = do ptr <- newArray $ B.unpack orig - reverseRGBA' (B.length orig `div` 4) (castPtr ptr) 0 - return ptr +-- | 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) --- | Parses through pixel values, shifting the bytes into OpenGL ABGR order -reverseRGBA' :: Int -> Ptr Word32 -> Int -> IO () -reverseRGBA' 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) - reverseRGBA' len ptr (count + 1) +-- | 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 () + | otherwise + = return () -- | Frees the allocated memory given to OpenGL to avoid a memory leak freeBitmapData :: Ptr Word8 -> IO () @@ -49,18 +64,22 @@ -- | 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) diff --git a/Graphics/Gloss/Internals/Render/Picture.hs b/Graphics/Gloss/Internals/Render/Picture.hs --- a/Graphics/Gloss/Internals/Render/Picture.hs +++ b/Graphics/Gloss/Internals/Render/Picture.hs @@ -13,14 +13,14 @@ import Graphics.Gloss.Internals.Render.Common import Graphics.Gloss.Internals.Render.Circle import Graphics.Gloss.Internals.Render.Bitmap -import Graphics.Rendering.OpenGL (($=), get) -import qualified Graphics.Rendering.OpenGL.GL as GL -import qualified Graphics.UI.GLUT as GLUT import System.Mem.StableName +import Foreign.ForeignPtr import Data.IORef import Data.List -import Data.ByteString (ByteString) import Control.Monad +import Graphics.Rendering.OpenGL (($=), get) +import qualified Graphics.Rendering.OpenGL.GL as GL +import qualified Graphics.UI.GLUT as GLUT -- ^ Render a picture using the given render options and viewport. @@ -201,7 +201,7 @@ -- otherwise load it into OpenGL. loadTexture :: IORef [Texture] - -> Int -> Int -> ByteString + -> Int -> Int -> BitmapData -> Bool -> IO Texture @@ -230,23 +230,22 @@ -- | Install a texture into OpenGL. installTexture :: Int -> Int - -> ByteString + -> BitmapData -> Bool -> IO Texture -installTexture width height imgData cacheMe +installTexture width height bitmapData@(BitmapData _ fptr) cacheMe = do - -- As OpenGL reads texture pixels as ABGR (instead of RGBA) - -- each pixel's value needs to be reversed we also need to - -- Convert imgData from ByteString to Ptr Word8 - ptrData <- reverseRGBA $ imgData - -- Allocate texture handle for texture [tex] <- GL.genObjectNames 1 GL.textureBinding GL.Texture2D $= Just tex -- Sets the texture in imgData as the current texture - GL.texImage2D + -- This copies the data from the pointer into OpenGL texture memory, + -- so it's ok if the foreignptr gets garbage collected after this. + withForeignPtr fptr + $ \ptr -> + GL.texImage2D Nothing GL.NoProxy 0 @@ -255,18 +254,18 @@ (gsizei width) (gsizei height)) 0 - (GL.PixelData GL.RGBA GL.UnsignedInt8888 ptrData) + (GL.PixelData GL.RGBA 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 -- can avoid loading it into texture memory again. - name <- makeStableName imgData + name <- makeStableName bitmapData return Texture { texName = name , texWidth = width , texHeight = height - , texData = ptrData + , texData = fptr , texObject = tex , texCacheMe = cacheMe } @@ -276,17 +275,8 @@ freeTexture :: Texture -> IO () freeTexture tex | texCacheMe tex = return () - | otherwise = deleteTexture tex - - --- | Delete a texture object from OpenGL. -deleteTexture :: Texture -> IO () -deleteTexture tex - = do -- Delete texture - GL.deleteObjectNames [texObject tex] + | otherwise = GL.deleteObjectNames [texObject tex] - -- Free image data - freeBitmapData (texData tex) -- Utils ------------------------------------------------------------------------------------------ diff --git a/Graphics/Gloss/Internals/Render/State.hs b/Graphics/Gloss/Internals/Render/State.hs --- a/Graphics/Gloss/Internals/Render/State.hs +++ b/Graphics/Gloss/Internals/Render/State.hs @@ -7,11 +7,11 @@ , Texture (..)) where import qualified Graphics.Rendering.OpenGL.GL as GL -import Foreign.Ptr +import Foreign.ForeignPtr import System.Mem.StableName -import Data.ByteString (ByteString) import Data.Word import Data.IORef +import Graphics.Gloss.Data.Picture -- | Render options settings data State @@ -36,9 +36,8 @@ -- | A texture that we've sent to OpenGL. data Texture = Texture - { -- | Stable name derived from the `ByteString` that the user gives us. - -- We - texName :: StableName ByteString + { -- | Stable name derived from the `BitmapData` that the user gives us. + texName :: StableName BitmapData -- | Width of the image, in pixels. , texWidth :: Int @@ -47,7 +46,7 @@ , texHeight :: Int -- | Pointer to the Raw texture data. - , texData :: Ptr Word8 + , texData :: ForeignPtr Word8 -- | The OpenGL texture object. , texObject :: GL.TextureObject diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -1,5 +1,5 @@ Name: gloss -Version: 1.4.0.1 +Version: 1.5.0.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -41,7 +41,8 @@ bytestring == 0.9.*, OpenGL == 2.4.*, GLUT == 2.2.*, - bmp == 1.1.* + bmp == 1.1.*, + vector >= 0.8 && < 1.0 ghc-options: -O2 -Wall