gloss-export (empty) → 0.1.0.0
raw patch · 14 files changed
+541/−0 lines, 14 filesdep +GLFW-bdep +GLUTdep +JuicyPixelssetup-changed
Dependencies added: GLFW-b, GLUT, JuicyPixels, OpenGLRaw, base, gloss, gloss-export, gloss-rendering, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +2/−0
- app/Export.hs +61/−0
- gloss-export.cabal +81/−0
- src/Graphics/Gloss/Export.hs +40/−0
- src/Graphics/Gloss/Export/Bitmap.hs +24/−0
- src/Graphics/Gloss/Export/Gif.hs +63/−0
- src/Graphics/Gloss/Export/Image.hs +157/−0
- src/Graphics/Gloss/Export/PNG.hs +24/−0
- src/Graphics/Gloss/Export/Tga.hs +24/−0
- src/Graphics/Gloss/Export/Tiff.hs +24/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for gloss-export++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++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 Author name here 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.
+ README.md view
@@ -0,0 +1,6 @@+# gloss-export++Export gloss pictures as PNG, Bitmap, TGA, TIFF, Gif++Credit to Samuel Gélineau (https://github.com/benl23x5/gloss/pull/23), who provided a working conversion from Picture to PNG.+I just refactored it a little and turned it into a library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Export.hs view
@@ -0,0 +1,61 @@+module Main where++import Graphics.Gloss.Data.Color+import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.Bitmap+import Graphics.Gloss+import Graphics.Gloss.Export++size :: (Int, Int)+size = (1500, 1000)++shorthand = exportPictureToPNG size white++main :: IO ()+main = do+ bmp <- loadBMP "loadme.bmp"+ let pic = Pictures [bmp, Color red $ Polygon [(-80,0), (0,80), (80,0)], Circle 80, Text "text"]+ exportPictureToPNG (400,400) white "comprehensive.png" pic+ exportPictureToBitmap (400,400) white "comprehensive.bmp" pic+ exportPictureToTga (400,400) white "comprehensive.tga" pic+ exportPictureToTiff (400,400) white "comprehensive.tiff" pic+ -- display (InWindow "" (100,80) (0, 0)) white pic+ shorthand "bmp.png" (bmp)+ shorthand "circle.png" (circle 25)+ exportPictureToPNG (500,500) white "circles.png" (Pictures (map circle [0,10..250]))+ -- background seems limited to (1853,1025) beyond that it's transparent+ let f = "top_and_right_margin_transparent_bg_on_my_machine.png"+ let wby2 = 1853 / 2+ let hby2 = 1025 / 2+ let p = Pictures [Translate wby2 hby2 $ ThickCircle 10 80+ ,Translate wby2 hby2 $ ThickCircle 10 80+ ,Color blue $ Line [(-wby2, hby2),(wby2, -hby2)]+ ,ThickCircle 10 80]+ exportPictureToPNG (1900,1050) white f p+ + let stack = (Pictures [ Color blue $ poly 49 --100x100+ , Color red $ poly 30 -- 60x60+ , Color yellow $ poly 20 -- 40x40+ , Color green $ poly 10 -- 20x20+ , Color white $ poly 5 -- 10x10+ ]+ )+ + exportPictureToPNG (10,10) white "p10.png" stack+ exportPictureToPNG (20,20) white "p20.png" stack+ exportPictureToPNG (40,40) white "p40.png" stack+ exportPictureToPNG (60,60) white "p60.png" stack+ exportPictureToPNG (100,100) white "p100.png" stack+ + exportPicturesToPNG (1000,1000) white "growing_polgons%d.png" (Color blue . poly) [200,250..500]+ exportPicturesToBitmap (1000,1000) white "growing_polgons%d.bmp" (Color blue . poly) [200,250..500]+ exportPicturesToTga (1000,1000) white "growing_polgons%d.tga" (Color blue . poly) [200,250..500]+ exportPicturesToTiff (1000,1000) white "growing_polgons%d.tiff" (Color blue . poly) [200,250..500]+ exportPicturesToGif 10 LoopingNever (1000,1000) red "growing_polgons.gif" (Color blue . poly) [200,250..500]+++textFloats :: [Float]+textFloats = [0,1..10]++poly :: Float -> Picture+poly l = Polygon [(-l,l),( l,l),(l,-l),(-l,-l)]
+ gloss-export.cabal view
@@ -0,0 +1,81 @@+-- 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.0+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+bug-reports: https://gitlab.com/timo-a/gloss-export/issues+author: Timo A+maintainer: timo-a@gmx.ch+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+category: Graphics+ +extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://gitlab.com/timo-a/gloss-export++library+ hs-source-dirs:+ src+ ghc-options: -fwarn-unused-imports + build-depends:+ -- I have checked(i.e. searched the functions in the documentation)+ -- the lower/upper bounds. No idea about versions inbetween.++ base >=4.7 && <5+ , gloss-rendering >= 1.9.3.1 && <= 1.13.0.2+ , GLFW-b >= 1.0.0 && <= 3.2.1.1+ , OpenGLRaw <= 3.3.1.0+ -- I can't see where the respective functions come from... it works with the upper bound+ , JuicyPixels >= 3.2 && <= 3.3.1+ , vector >= 0.9.1 && <= 0.12.0.1+ , GLUT >= 2.1.2.0 && <= 2.7.0.14+ exposed-modules:+ Graphics.Gloss.Export+ , Graphics.Gloss.Export.Image+ , Graphics.Gloss.Export.PNG+ , Graphics.Gloss.Export.Bitmap+ , Graphics.Gloss.Export.Tga+ , Graphics.Gloss.Export.Tiff+ , Graphics.Gloss.Export.Gif+ other-modules:+ Paths_gloss_export+ default-language: Haskell2010++executable gloss-export-exe+ main-is: Export.hs+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , gloss+ , gloss-export+ other-modules:+ Paths_gloss_export+ default-language: Haskell2010++test-suite gloss-export-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , gloss-export+ other-modules:+ Paths_gloss_export+ default-language: Haskell2010
+ src/Graphics/Gloss/Export.hs view
@@ -0,0 +1,40 @@+-- | Main module for exporting gloss pictures to image files, gif animations and juicy-pixels image datatypes+-- The canvas seems limited to (1853,1025) beyond that it's transparent++module Graphics.Gloss.Export+ (+ -- * For tinkering yourself+ initialize+ , pictureToImageRGB8+ , pictureToImageRGBA8+ , exportPictureToFormat+ , exportPicturesToFormat+ + -- * Writing to PNG+ , exportPictureToPNG+ , exportPicturesToPNG++ -- * Writing to Bitmap+ , exportPictureToBitmap+ , exportPicturesToBitmap++ -- * Writing to Tga+ , exportPictureToTga+ , exportPicturesToTga++ -- * Writing to Tiff+ , exportPictureToTiff+ , exportPicturesToTiff ++ -- * Writing to Gif+ , exportPicturesToGif+ , GifDelay(..)+ , GifLooping(..)+ ) where++import Graphics.Gloss.Export.Image+import Graphics.Gloss.Export.PNG+import Graphics.Gloss.Export.Bitmap+import Graphics.Gloss.Export.Tga+import Graphics.Gloss.Export.Tiff+import Graphics.Gloss.Export.Gif
+ src/Graphics/Gloss/Export/Bitmap.hs view
@@ -0,0 +1,24 @@+module Graphics.Gloss.Export.Bitmap+ ( exportPictureToBitmap+ , exportPicturesToBitmap+ ) where++import Codec.Picture.Bitmap (writeBitmap)+import qualified Graphics.Gloss.Rendering as Gloss++import Graphics.Gloss.Export.Image++-- | Save a gloss Picture as Bitmap+exportPictureToBitmap :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath -> Gloss.Picture -> IO ()+exportPictureToBitmap = exportPictureToFormat writeBitmap++-- | Save a gloss animation as Bitmap+exportPicturesToBitmap :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [Float] -- ^ list of points in time at which to evaluate the animation+ -> IO ()+exportPicturesToBitmap = exportPicturesToFormat writeBitmap
+ src/Graphics/Gloss/Export/Gif.hs view
@@ -0,0 +1,63 @@+module Graphics.Gloss.Export.Gif+ ( exportPicturesToGif+ , GifDelay(..)+ , GifLooping(..)+ ) where++--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++-- | Save a gloss animation as PNG+exportPicturesToGif :: GifDelay -- ^ time between frames in centiseconds+ -> GifLooping+ -> Size -- ^ width, height in pixels as in Gloss.Display+ -> Gloss.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [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++{- slower on my machine -> not distributed+ but maybe helpful in the future e.g. when juicy-pixels offers `writeGifAnimation` with RGBA8+exportPicturesToGifByConverting :: GifDelay -- ^ time between frames (Int)+ -> GifLooping+ -> Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [Float] -- ^ list of points in time at which to evaluate the animation+ -> IO ()+exportPicturesToGifByConverting gifDelay gifLooping size bgc f anim ts = do+ s <- initialize size+ (imgs, ptrs) <- mapAndUnzipM (pictureToImageRGBA8 size bgc s) (map anim ts)+ let imgs' = map (convertRGB8 . ImageRGBA8) imgs+ case writeGifAnimation f gifDelay gifLooping imgs' of+ Left errmsg -> putStrLn ("Error:" ++ errmsg)+ Right io -> io+ forM_ ptrs $ \ptr -> do+ free ptr+-}++{- RGB8+real 0m2,229s+user 0m4,030s+sys 0m1,874s++RGBA8 then conversion+real 0m3,438s+user 0m6,987s+sys 0m2,649s++-}
+ src/Graphics/Gloss/Export/Image.hs view
@@ -0,0 +1,157 @@+-- author: Samuel Gélineau (gelisam)+-- in response to https://www.reddit.com/r/haskell/comments/3u5s4e/is_there_a_way_to_write_the_frames_of_a_gloss/+-- slightly improved++module Graphics.Gloss.Export.Image+ ( Size+ , Animation+ , initialize+ , pictureToImageRGB8+ , pictureToImageRGBA8+ , 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 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 Text.Printf (printf)+import GHC.Int+import qualified Graphics.UI.GLUT as GLUT+import Prelude hiding (concat)++type Size = (Int, Int)+type Animation = Float -> Gloss.Picture++-- | Save a gloss Picture to a file.+exportPictureToFormat :: (FilePath -> Image PixelRGBA8 -> IO ()) -- ^ function that saves an intermediate representation to a format. Written with writeXY from Codec.Picture in mind+ -> Size -- ^ (width, heigth) in pixels - as in Gloss.Display+ -> 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++-- | If you want to write your own functions, call this function before pictureToImage* +initialize :: Size -> IO Gloss.State+initialize size = do+ _ <- GLUT.exit -- otherwise 'illegal reinitialization'+ (_,_) <- GLUT.getArgsAndInitialize -- needed for text https://github.com/elisehuard/game-in-haskell/pull/3+ s <- Gloss.initState+ initOpenGL size+ return s+++-- let GLFW bother with the OpenGL initialization+initOpenGL :: (Int, Int) -- ^ windowWidth, windowHeight+ -> IO () +initOpenGL (windowWidth, windowHeight) = do+ True <- GLFW.init+ Just w <- GLFW.createWindow+ windowWidth windowHeight+ "gloss-to-file demo"+ Nothing Nothing+ GLFW.makeContextCurrent (Just w)+++++-- | 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+ -> Gloss.Color -- ^ background color+ -> FilePath -- ^ must contain "%d", will be replaced by frame number+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [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++-- 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++-- | 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)++drawReadBuffer :: Size+ -> Gloss.Color -- ^ Background color+ -> Gloss.State -> Gloss.Picture -> IO ()+drawReadBuffer size bg s p = do+ glDrawBuffer GL_BACK+ Gloss.withClearBuffer bg $ Gloss.withModelview size $ do+ 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)
+ src/Graphics/Gloss/Export/PNG.hs view
@@ -0,0 +1,24 @@+module Graphics.Gloss.Export.PNG+ ( exportPictureToPNG+ , exportPicturesToPNG+ ) where++import Codec.Picture.Png (writePng)+import qualified Graphics.Gloss.Rendering as Gloss++import Graphics.Gloss.Export.Image++-- | Save a gloss Picture as PNG+exportPictureToPNG :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath -> Gloss.Picture -> IO ()+exportPictureToPNG = exportPictureToFormat writePng++-- | Save a gloss animation as PNG+exportPicturesToPNG :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [Float] -- ^ list of points in time at which to evaluate the animation+ -> IO ()+exportPicturesToPNG = exportPicturesToFormat writePng
+ src/Graphics/Gloss/Export/Tga.hs view
@@ -0,0 +1,24 @@+module Graphics.Gloss.Export.Tga+ ( exportPictureToTga+ , exportPicturesToTga+ ) where++import Codec.Picture.Tga (writeTga)+import qualified Graphics.Gloss.Rendering as Gloss++import Graphics.Gloss.Export.Image++-- | Save a gloss Picture as Tga+exportPictureToTga :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath -> Gloss.Picture -> IO ()+exportPictureToTga = exportPictureToFormat writeTga++-- | Save a gloss animation as Tga+exportPicturesToTga :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [Float] -- ^ list of points in time at which to evaluate the animation+ -> IO ()+exportPicturesToTga = exportPicturesToFormat writeTga
+ src/Graphics/Gloss/Export/Tiff.hs view
@@ -0,0 +1,24 @@+module Graphics.Gloss.Export.Tiff+ ( exportPictureToTiff+ , exportPicturesToTiff+ ) where++import Codec.Picture.Tiff (writeTiff)+import qualified Graphics.Gloss.Rendering as Gloss++import Graphics.Gloss.Export.Image++-- | Save a gloss Picture as Tiff+exportPictureToTiff :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath -> Gloss.Picture -> IO ()+exportPictureToTiff = exportPictureToFormat writeTiff++-- | Save a gloss animation as Tiff+exportPicturesToTiff :: Size -- ^ width, height in pixels + -> Gloss.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Gloss.Animation+ -> [Float] -- ^ list of points in time at which to evaluate the animation+ -> IO ()+exportPicturesToTiff = exportPicturesToFormat writeTiff
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"