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.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)]