gloss-export 0.1.0.1 → 0.1.0.2

raw patch · 6 files changed

+165/−118 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−1
• gloss-export.cabal +1/−7
• src/Graphics/Gloss/Export.hs +3/−3
• src/Graphics/Gloss/Export/Gif.hs +5/−8
• src/Graphics/Gloss/Export/Image.hs +139/−98
• test/Export.hs +0/−1

@@ -1,3 +1,19 @@ # Changelog for gloss-export -## Unreleased changes+## 0.1.0.2+Error handling (throws error now, formerly stdout)+Unified approach for RGBA,RGBA8+Image is flipped by OpenGL now+easier to compile on macOS, still works on linux++contributers: Samuel Gélineau+++## 0.1.0.1+window no longer displayed when exporting+added testsuite++contributers: Samuel Gélineau++## 0.1.0.0+Initial version	

@@ -1,11 +1,5 @@--- This file has been generated from package.yaml by hpack version 0.20.0.------ see: https://github.com/sol/hpack------ hash: 0cb0cf7bc206d3b65fbbc53380a4357db15315303559877a10b52a2e8a28104d- name:           gloss-export-version:        0.1.0.1+version:        0.1.0.2 Synopsis:       Export Gloss pictures to png, bmp, tga, tiff, gif and juicy-pixels-image description:    Please see the README on GitLab at <https://gitlab.com/timo-a/gloss-export#readme> homepage:       https://gitlab.com/timo-a/gloss-export#readme

@@ -4,9 +4,9 @@ module Graphics.Gloss.Export     (     -- * For tinkering yourself-      initialize-    , pictureToImageRGB8-    , pictureToImageRGBA8+      withGlossState+    , withImage+    , withImages     , exportPictureToFormat     , exportPicturesToFormat     

@@ -7,8 +7,6 @@ --import Codec.Picture.Types import Codec.Picture  import qualified Graphics.Gloss.Rendering as Gloss-import Control.Monad (forM_, mapAndUnzipM)-import Foreign.Marshal.Alloc (free)  import Graphics.Gloss.Export.Image @@ -22,12 +20,11 @@                     -> [Float]     -- ^ list of points in time at which to evaluate the animation                     -> IO () exportPicturesToGif gifDelay gifLooping size bgc f anim ts = do-  s <- initialize size-  (imgs, ptrs) <- mapAndUnzipM (pictureToImageRGB8 size bgc s) (map anim ts)-  case writeGifAnimation f gifDelay gifLooping imgs of-    Left errmsg -> putStrLn ("Error:" ++ errmsg)-    Right io -> io-  forM_ ptrs free+  withGlossState size $ \s -> do+    withImages size bgc s (map anim ts) $ \imgs -> do+      case writeGifAnimation f gifDelay gifLooping imgs of+        Left errmsg -> error errmsg+        Right io -> io  {- slower on my machine -> not distributed    but maybe helpful in the future e.g. when juicy-pixels offers `writeGifAnimation` with RGBA8

@@ -2,28 +2,33 @@ -- in response to https://www.reddit.com/r/haskell/comments/3u5s4e/is_there_a_way_to_write_the_frames_of_a_gloss/ -- slightly improved +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} module Graphics.Gloss.Export.Image     ( Size     , Animation-    , initialize-    , pictureToImageRGB8-    , pictureToImageRGBA8+    , withGlossState+    , withImage+    , withImages     , exportPictureToFormat     , exportPicturesToFormat     ) where -import Codec.Picture.Types (Image(..), PixelRGBA8, PixelRGB8, PixelBaseComponent)-import Control.Monad (forM_)-import Data.Vector.Storable (Vector, unsafeFromForeignPtr0, Storable, slice, concat)+import Codec.Picture.Types (Image(..), Pixel, PixelRGBA8, PixelRGB8, componentCount)+import Control.Exception (bracket, bracket_)+import Control.Monad (forM_, when)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Proxy (Proxy(..))+import Data.Vector.Storable (unsafeFromForeignPtr0) import qualified Graphics.Gloss.Rendering as Gloss import Graphics.GL -- as GL* import qualified Graphics.UI.GLFW as GLFW-import Foreign (newForeignPtr_, Ptr)-import Foreign.Marshal.Alloc (free)-import Foreign.Marshal.Array (mallocArray)+import Foreign (newForeignPtr_)+import Foreign.Marshal.Array (allocaArray) import Text.Printf (printf) import GHC.Int+#ifdef linux_HOST_OS import qualified Graphics.UI.GLUT as GLUT+#endif import Prelude hiding (concat)  type Size = (Int, Int)@@ -35,38 +40,80 @@                       -> Gloss.Color         -- ^ Background color                       -> FilePath -> Gloss.Picture -> IO () exportPictureToFormat savefunc size bgc f p = do-    s <- initialize size-    --initialize is not part of pictureToImage so in-    --exportPicturesToFormat we only have to initialize once-    (img,ptr) <- pictureToImageRGBA8 size bgc s p-    savefunc f img-    free ptr+    withGlossState size $ \s -> do+      withImage size bgc s p $ \img -> do+        savefunc f img --- | If you want to write your own functions, call this function before pictureToImage* -initialize :: Size -> IO Gloss.State-initialize size = do+-- | Acquire the Gloss.State required by the withImage* functions.+-- This allows the same OpenGL surface (of the given size) to be reused several times, which in turn makes Gloss bitmaps faster to render because their textures are kept in video memory.+withGlossState :: Size -> (Gloss.State -> IO a) -> IO a+withGlossState size body = do+#ifdef linux_HOST_OS     _ <- GLUT.exit                     -- otherwise 'illegal reinitialization'     (_,_) <- GLUT.getArgsAndInitialize -- needed for text  https://github.com/elisehuard/game-in-haskell/pull/3+#endif     s <- Gloss.initState-    initOpenGL size-    return s+    withGLFW $ do+      GLFW.windowHint (GLFW.WindowHint'Visible False)+      withWindow size "Graphics.Gloss.Export.Image context" Nothing Nothing $ \window -> do+        GLFW.makeContextCurrent (Just window)+        body s +-- | A bracket API for GLFW.setErrorCallback which makes it easier to throw an exception upon failure.+withThrowGLFWError :: ((forall r. IO r) -> IO a) -> IO a+withThrowGLFWError body = do+    errorMessageRef <- newIORef "GLFW failed without an error message" --- let GLFW bother with the OpenGL initialization-initOpenGL :: (Int, Int) -- ^ windowWidth, windowHeight-           -> IO ()        -initOpenGL (windowWidth, windowHeight) = do-    True <- GLFW.init-    GLFW.windowHint (GLFW.WindowHint'Visible False)-    Just w <- GLFW.createWindow-                windowWidth windowHeight-                "gloss-to-file demo"-                Nothing Nothing-    GLFW.makeContextCurrent (Just w)+    let throwGLFWError :: IO r+        throwGLFWError = do+          errorMessage <- readIORef errorMessageRef+          error errorMessage +        errorCallback :: GLFW.ErrorCallback+        errorCallback _ errorMessage = do+          writeIORef errorMessageRef errorMessage +        acquire :: IO ()+        acquire = GLFW.setErrorCallback (Just errorCallback) +        release :: IO ()+        release = GLFW.setErrorCallback Nothing +    bracket_ acquire release $ do+      body throwGLFWError++-- | A bracket API for GLFW.init which throws an exception on failure.+withGLFW :: IO a -> IO a+withGLFW body = do+    withThrowGLFWError $ \throwGLFWError -> do+      bracket acquire release $ \glfwIsInitialized -> do+        if glfwIsInitialized then body else throwGLFWError+  where+    acquire :: IO Bool+    acquire = GLFW.init++    release :: Bool -> IO ()+    release glfwIsInitialized = when glfwIsInitialized GLFW.terminate++-- A bracket API for GLFW.createWindow which throws an exception on failure.+-- Must be called within withGLFW.+withWindow :: Size -> String -> Maybe GLFW.Monitor -> Maybe GLFW.Window+           -> (GLFW.Window -> IO a) -> IO a+withWindow (width, height) title monitor sharedContext body = do+    withThrowGLFWError $ \throwGLFWError -> do+      bracket acquire release $ \maybeWindow -> case maybeWindow of+        Just window -> body window+        Nothing -> throwGLFWError+  where+    acquire :: IO (Maybe GLFW.Window)+    acquire = GLFW.createWindow width height title monitor sharedContext++    release :: Maybe GLFW.Window -> IO ()+    release = mapM_ GLFW.destroyWindow++++ -- | Save a series of gloss Picture to files of spcified format. exportPicturesToFormat :: (FilePath -> Image PixelRGBA8 -> IO ()) -- ^ function that saves an intermediate representation to a format. Written with writeXY from Codec.Picture in mind                        -> Size                -- ^ (width, height) in pixels - as in Gloss.Display@@ -76,40 +123,71 @@                        -> [Float]             -- ^ list of points in time at which to evaluate the animation                        -> IO () exportPicturesToFormat savefunc size bgc f anim ts = do-    s <- initialize size-    forM_ (zip [1..] ts) $ \(n, t) -> do-      let filename = printf f (n :: Int)-      let picture = anim t-      (img,ptr) <- pictureToImageRGBA8 size bgc s picture-      savefunc filename img-      free ptr+    withGlossState size $ \s -> do+      forM_ (zip [1..] ts) $ \(n, t) -> do+        let filename = printf f (n :: Int)+        let picture = anim t+        withImage size bgc s picture $ \img -> do+          savefunc filename img --- I couldn't find a way to generalize over the type of pixel so I made RGBA8 and RGB8.--- Keep in mind: different pixel types have different sizes!---               GL_RGBA, 4 would also have to be abstracted +class Pixel pixel => OpenGLPixel pixel where+  openGLPixelFormat :: proxy pixel -> GLenum+  openGLPixelType   :: proxy pixel -> GLenum++instance OpenGLPixel PixelRGBA8 where+  openGLPixelFormat _ = GL_RGBA+  openGLPixelType   _ = GL_UNSIGNED_BYTE++instance OpenGLPixel PixelRGB8 where+  openGLPixelFormat _ = GL_RGB+  openGLPixelType   _ = GL_UNSIGNED_BYTE+ -- | convert a gloss 'Picture' into an 'Image'.--- The pointer should be freed after the image is no longer needed in memory--- Use 'free ptr' to free the memory.-pictureToImageRGBA8 :: Size                -- ^ (width, height) in pixels - as in Gloss.Display-                    -> Gloss.Color         -- ^ Background color-                    -> Gloss.State         -- ^ Result of 'initialize'-                    -> Gloss.Picture-                    -> IO (Image PixelRGBA8, Ptr (PixelBaseComponent PixelRGBA8)) -- ^ image and a pointer to memory-pictureToImageRGBA8 (windowWidth, windowHeight) bgc s p = do-    drawReadBuffer (windowWidth, windowHeight) bgc s p-    imageData <- mallocArray (windowWidth * windowHeight * 4)-    let wW = fromIntegral windowWidth  :: GHC.Int.Int32-    let wH = fromIntegral windowHeight :: GHC.Int.Int32-    glReadPixels 0 0 wW wH GL_RGBA GL_UNSIGNED_BYTE imageData -    foreignPtr <- newForeignPtr_ imageData-    let vector = unsafeFromForeignPtr0 foreignPtr (windowWidth * windowHeight * 4)-    let vectorFlipped = reverseImage 4 windowWidth windowHeight vector-    let image :: Image PixelRGBA8-        image = Image windowWidth windowHeight vectorFlipped-    -    return (image, imageData)+withImage :: forall pixel a. OpenGLPixel pixel+          => Size                -- ^ (width, height) in pixels - as in Gloss.Display+          -> Gloss.Color         -- ^ Background color+          -> Gloss.State         -- ^ Obtained via 'withGlossState'+          -> Gloss.Picture+          -> (Image pixel -> IO a) -> IO a+withImage (windowWidth, windowHeight) bgc s p body = do+    let bytesPerPixel :: Int+        bytesPerPixel = componentCount (undefined :: pixel) +        pixelFormat :: GLenum+        pixelFormat = openGLPixelFormat (Proxy :: Proxy pixel)++        pixelType :: GLenum+        pixelType = openGLPixelType (Proxy :: Proxy pixel)++    --- the drawn image is flipped ([rowN,...,row1]) so we need to draw it upside down+    --- I guess this is because the origin is specified as topleft and bottomleft by different functions+    let flippedPicture :: Gloss.Picture+        flippedPicture = Gloss.Scale 1 (-1) p+    drawReadBuffer (windowWidth, windowHeight) bgc s flippedPicture+    allocaArray (windowWidth * windowHeight * bytesPerPixel) $ \imageData -> do+      let wW = fromIntegral windowWidth  :: GHC.Int.Int32+      let wH = fromIntegral windowHeight :: GHC.Int.Int32+      glReadPixels 0 0 wW wH pixelFormat pixelType imageData +      foreignPtr <- newForeignPtr_ imageData+      let vector = unsafeFromForeignPtr0 foreignPtr (windowWidth * windowHeight * bytesPerPixel)+      let image :: Image pixel+          image = Image windowWidth windowHeight vector+      +      body image++withImages :: OpenGLPixel pixel+           => Size                -- ^ (width, height) in pixels - as in Gloss.Display+           -> Gloss.Color         -- ^ Background color+           -> Gloss.State         -- ^ Obtained via 'withGlossState'+           -> [Gloss.Picture]+           -> ([Image pixel] -> IO a) -> IO a+withImages _ _ _ [] body = body []+withImages size bgc s (p:ps) body = do+  withImage size bgc s p $ \image -> do+    withImages size bgc s ps $ \images -> do+      body (image:images)+ drawReadBuffer :: Size           -> Gloss.Color -- ^ Background color           -> Gloss.State -> Gloss.Picture -> IO ()@@ -119,40 +197,3 @@                                                            glColor3f 0 0 0                                                            Gloss.renderPicture s 1 p     glReadBuffer GL_BACK ----- the drawn image is flipped ([rowN,...,row1]) so we need to reverse the order of rows--- I guess this is because the origin is specified as topleft and bottomleft by different functions-reverseImage :: Storable a => Int -- ^ #Bits per pixel. 4 for rgba8, 3 for rgb8-                           -> Int-                           -> Int -> Vector a -> Vector a-reverseImage components width height vec = concat [slice i widthC vec | i <- map (*widthC) [(height-1),(height-2)..0] ]-    where-      widthC = width*components------ Below is the version without transparency for making gifs. --- ideally there would just be one function and the result would be casted to either ::PixelRGBA8 or ::PixelRGB8---- | convert a gloss 'Picture' into an 'Image'.--- The pointer should be freed after the image is no longer needed in memory--- Use 'free ptr' to free the memory.-pictureToImageRGB8 :: Size                -- ^ (width, height) in pixels - as in Gloss.Display-                   -> Gloss.Color         -- ^ Background color-                   -> Gloss.State         -- ^ Result of 'initializate'-                   -> Gloss.Picture-                   -> IO (Image PixelRGB8, Ptr (PixelBaseComponent PixelRGB8)) -- ^ image and a pointer to memory-pictureToImageRGB8 (windowWidth, windowHeight) bgc s p = do-    drawReadBuffer (windowWidth, windowHeight) bgc s p-    imageData <- mallocArray (windowWidth * windowHeight * 3)-    let wW = fromIntegral windowWidth  :: GHC.Int.Int32-    let wH = fromIntegral windowHeight :: GHC.Int.Int32-    glReadPixels 0 0 wW wH GL_RGB GL_UNSIGNED_BYTE imageData -    foreignPtr <- newForeignPtr_ imageData-    let vector = unsafeFromForeignPtr0 foreignPtr (windowWidth * windowHeight * 3)-    let vectorFlipped = reverseImage 3 windowWidth windowHeight vector-    let image :: Image PixelRGB8-        image = Image windowWidth windowHeight vectorFlipped-    -    return (image, imageData)

@@ -6,7 +6,6 @@ import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Bitmap-import Graphics.Gloss import Graphics.Gloss.Export import Graphics.Gloss.Export.Image import System.Directory