gloss-export 0.1.0.0 → 0.1.0.1
raw patch · 6 files changed
+185/−67 lines, 6 filesdep +directorydep +filepathdep ~JuicyPixelsPVP ok
version bump matches the API change (PVP)
Dependencies added: directory, filepath
Dependency ranges changed: JuicyPixels
API changes (from Hackage documentation)
Files
- app/Demo.hs +15/−0
- app/Export.hs +0/−61
- gloss-export.cabal +8/−4
- src/Graphics/Gloss/Export/Image.hs +1/−0
- test/Export.hs +161/−0
- test/Spec.hs +0/−2
+ app/Demo.hs view
@@ -0,0 +1,15 @@+module Main where++import Graphics.Gloss.Data.Color+import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Export++main :: IO ()+main = exportPicturesToGif 10 LoopingForever (160,160) white "inf_loop.gif" (animation . (*a)) [0..(steps-1)]+ where+ steps = 40+ a = (90)/steps+ animation t = Rotate t (poly 50)++poly :: Float -> Picture+poly l = Polygon [(-l,l),( l,l),(l,-l),(-l,-l)]
− app/Export.hs
@@ -1,61 +0,0 @@-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
@@ -5,7 +5,7 @@ -- hash: 0cb0cf7bc206d3b65fbbc53380a4357db15315303559877a10b52a2e8a28104d name: gloss-export-version: 0.1.0.0+version: 0.1.0.1 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@@ -55,7 +55,7 @@ default-language: Haskell2010 executable gloss-export-exe- main-is: Export.hs+ main-is: Demo.hs hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -66,16 +66,20 @@ other-modules: Paths_gloss_export default-language: Haskell2010-+ test-suite gloss-export-test type: exitcode-stdio-1.0- main-is: Spec.hs+ main-is: Export.hs hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , directory+ , filepath+ , gloss , gloss-export+ , JuicyPixels other-modules: Paths_gloss_export default-language: Haskell2010
src/Graphics/Gloss/Export/Image.hs view
@@ -57,6 +57,7 @@ -> IO () initOpenGL (windowWidth, windowHeight) = do True <- GLFW.init+ GLFW.windowHint (GLFW.WindowHint'Visible False) Just w <- GLFW.createWindow windowWidth windowHeight "gloss-to-file demo"
+ test/Export.hs view
@@ -0,0 +1,161 @@+module Main where++import Codec.Picture+import Control.Monad+import Data.Foldable+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+import System.FilePath+import Text.Printf++-- A variant of 'readImage' which fails with an exception instead of a 'Left'+loadJuicyThrow :: FilePath -> IO DynamicImage+loadJuicyThrow filePath = do+ r <- readImage filePath+ case r of+ Left err -> error err+ Right dynamicImage -> pure dynamicImage++-- A variant of 'readGifImages' which fails with an exception instead of a 'Left'+readGifImagesThrow :: FilePath -> IO [DynamicImage]+readGifImagesThrow filePath = do+ r <- readGifImages filePath+ case r of+ Left err -> error err+ Right dynamicImages -> pure dynamicImages++-- Some versions of JuicyPixels we want to support do not have an Eq instance+-- for 'Image', so we need to compare the individual fields ourselves.+eqImage :: Image PixelRGBA8 -> Image PixelRGBA8 -> Bool+eqImage image1 image2 = imageWidth image1 == imageWidth image2+ && imageHeight image1 == imageHeight image2+ && imageData image1 == imageData image2++-- Even on the versions of JuicyPixels which do have an Eq instance for+-- 'DynamicImage', we need a version which considers two dynamic images which+-- have the same pixels but use a different format to be equal.+eqDynamicImage :: DynamicImage -> DynamicImage -> Bool+eqDynamicImage dynamicImage1 dynamicImage2+ = eqImage (convertRGBA8 dynamicImage1)+ (convertRGBA8 dynamicImage1)++assertSameImageFiles :: FilePath -> FilePath -> IO ()+assertSameImageFiles filePath1 filePath2 = do+ dynamicImage1 <- loadJuicyThrow filePath1+ dynamicImage2 <- loadJuicyThrow filePath2+ + unless (eqDynamicImage dynamicImage1 dynamicImage2) $ do+ error $ "images do not match: " ++ filePath1 ++ ", " ++ filePath2++assertSameGifFiles :: FilePath -> FilePath -> IO ()+assertSameGifFiles filePath1 filePath2 = do+ dynamicImages1 <- readGifImagesThrow filePath1+ dynamicImages2 <- readGifImagesThrow filePath2+ + unless (length dynamicImages1 == length dynamicImages2) $ do+ error $ "gifs have a different number of frames: " ++ filePath1 ++ ", " ++ filePath2+ for_ (zip [1..] (zipWith eqDynamicImage dynamicImages1 dynamicImages2)) $ \(i, framesMatch) -> do+ unless framesMatch $ do+ error $ "animations do not match at frame " ++ show i ++ ": " ++ filePath1 ++ ", " ++ filePath2++-- Validates the given image against an expected image, which is assumed to be+-- a png file found at the same location as the given image, but prefixed with+-- "expected_".+assertSameImageAsExpected :: FilePath -> IO ()+assertSameImageAsExpected filePath = do+ let expectedFilePath = replaceExtension ("expected_" ++ filePath) "png"+ assertSameImageFiles filePath expectedFilePath++-- A wrapper around functions like 'exportPictureToPNG' which also validates+-- the generated image.+exportPictureAndCheck :: (Size -> Color -> FilePath -> Picture -> IO ()) -- ^ wrapped export function+ -> Size -- ^ width, height in pixels+ -> Color -- ^ background color+ -> FilePath -> Picture -> IO ()+exportPictureAndCheck exportPicture size bg filePath picture = do+ exportPicture size bg filePath picture+ assertSameImageAsExpected filePath++-- A wrapper around functions like 'exportPicturesToPNG' which also validates+-- the generated images.+exportPicturesAndCheck :: (Size -> Color -> FilePath -> Animation -> [Float] -> IO ()) -- ^ wrapped export function+ -> Size -- ^ width, height in pixels + -> 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 ()+exportPicturesAndCheck exportPictures size bg filePathPattern animation ts = do+ exportPictures size bg filePathPattern animation ts+ for_ [1..length ts] $ \i -> do+ let filePath = printf filePathPattern i+ assertSameImageAsExpected filePath++size :: (Int, Int)+size = (1500, 1000)++shorthand = exportPictureAndCheck exportPictureToPNG size white++main :: IO ()+main = do+ -- @stack test@ sets the working directory to the project root, but all the+ -- filenames are relative to the @test@ folder.+ setCurrentDirectory "test"++ -- Test multiple gloss features and multiple export formats.+ bmp <- loadBMP "loadme.bmp"+ let pic = Pictures [bmp, Color red $ Polygon [(-80,0), (0,80), (80,0)], Circle 80, Text "text"]+ exportPictureAndCheck exportPictureToPNG (400,400) white "comprehensive.png" pic+ exportPictureAndCheck exportPictureToBitmap (400,400) white "comprehensive.bmp" pic+ exportPictureAndCheck exportPictureToTga (400,400) white "comprehensive.tga" pic+ exportPictureAndCheck exportPictureToTiff (400,400) white "comprehensive.tiff" pic+ -- display (InWindow "" (100,80) (0, 0)) white pic+ shorthand "bmp.png" (bmp)+ shorthand "circle.png" (circle 25)+ exportPictureAndCheck exportPictureToPNG (500,500) white "circles.png" (Pictures (map circle [0,10..250]))+ + -- Make sure we can export large images. In a previous version, attempting+ -- to export an image larger than the screen resolution WxH resulted in a+ -- scaled down image displayed in the lower-left WxH rectantle, with+ -- transparent pixels everywhere else.+ 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]+ exportPictureAndCheck exportPictureToPNG (1900,1050) white "large_image.png" 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+ ]+ )+ + exportPictureAndCheck exportPictureToPNG (10,10) white "p10.png" stack+ exportPictureAndCheck exportPictureToPNG (20,20) white "p20.png" stack+ exportPictureAndCheck exportPictureToPNG (40,40) white "p40.png" stack+ exportPictureAndCheck exportPictureToPNG (60,60) white "p60.png" stack+ exportPictureAndCheck exportPictureToPNG (100,100) white "p100.png" stack+ + exportPicturesAndCheck exportPicturesToPNG (1000,1000) white "growing_polgons%d.png" (Color blue . poly) [200,250..500]+ exportPicturesAndCheck exportPicturesToBitmap (1000,1000) white "growing_polgons%d.bmp" (Color blue . poly) [200,250..500]+ exportPicturesAndCheck exportPicturesToTga (1000,1000) white "growing_polgons%d.tga" (Color blue . poly) [200,250..500]+ exportPicturesAndCheck 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]+ assertSameGifFiles "growing_polgons.gif" "expected_growing_polgons.gif"+++textFloats :: [Float]+textFloats = [0,1..10]++poly :: Float -> Picture+poly l = Polygon [(-l,l),( l,l),(l,-l),(-l,-l)]
− test/Spec.hs
@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"