brillo-export (empty) → 0.2.0.0
raw patch · 36 files changed
+3155/−0 lines, 36 filesdep +GLFW-bdep +JuicyPixelsdep +OpenGLRawsetup-changedbinary-added
Dependencies added: GLFW-b, JuicyPixels, OpenGLRaw, base, brillo, brillo-export, brillo-rendering, bytestring, directory, filepath, text, vector, webp
Files
- ChangeLog.md +14/−0
- README.md +13/−0
- Setup.hs +4/−0
- app/Demo.hs +25/−0
- brillo-export.cabal +139/−0
- src/Brillo/Export.hs +55/−0
- src/Brillo/Export/Bitmap.hs +36/−0
- src/Brillo/Export/Gif.hs +68/−0
- src/Brillo/Export/Image.hs +195/−0
- src/Brillo/Export/PNG.hs +36/−0
- src/Brillo/Export/SVG.hs +750/−0
- src/Brillo/Export/Tga.hs +36/−0
- src/Brillo/Export/Tiff.hs +36/−0
- src/Brillo/Export/WebP.hs +86/−0
- test/Export.hs +313/−0
- test/SVGTest.hs +802/−0
- test/WebPTest.hs +547/−0
- test/expected_bmp.png binary
- test/expected_circle.png binary
- test/expected_circles.png binary
- test/expected_comprehensive.png binary
- test/expected_growing_polgons.gif binary
- test/expected_growing_polgons1.png binary
- test/expected_growing_polgons2.png binary
- test/expected_growing_polgons3.png binary
- test/expected_growing_polgons4.png binary
- test/expected_growing_polgons5.png binary
- test/expected_growing_polgons6.png binary
- test/expected_growing_polgons7.png binary
- test/expected_large_image.png binary
- test/expected_p10.png binary
- test/expected_p100.png binary
- test/expected_p20.png binary
- test/expected_p40.png binary
- test/expected_p60.png binary
- test/loadme.bmp binary
+ ChangeLog.md view
@@ -0,0 +1,14 @@+# Changelog for brillo-export++## 0.1.0.4++* Forked from gloss-export+* Renamed all modules from Graphics.Gloss.Export to Brillo.Export+* Updated to use Brillo types instead of Gloss types+* Changed dependency from gloss-rendering to brillo-rendering+* Updated all function names (withGlossState -> withBrilloState)+* Updated version bounds for modern dependencies++## Original gloss-export++See https://gitlab.com/timo-a/gloss-export for the original library history
+ README.md view
@@ -0,0 +1,13 @@+# brillo-export++Export Brillo pictures as PNG, Bitmap, TGA, TIFF, and animated GIF.++This library is a fork of [gloss-export], adapted to work with the Brillo graphics library.+++## Credits++- Original [gloss-export] by Timo A+- Samuel Gélineau for the initial Picture to PNG conversion: https://github.com/benl23x5/gloss/pull/23++[gloss-export]: https://gitlab.com/timo-a/gloss-export
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ app/Demo.hs view
@@ -0,0 +1,25 @@+module Main where++import Brillo.Data.Color+import Brillo.Data.Picture+import Brillo.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)]
+ brillo-export.cabal view
@@ -0,0 +1,139 @@+name: brillo-export+version: 0.2.0.0+synopsis:+ Export Brillo pictures to png, bmp, tga, tiff, gif, svg and juicy-pixels-image++description:+ Export Brillo pictures to various image formats including PNG, BMP, TGA, TIFF, animated GIF, and SVG.+ Forked from gloss-export and adapted for the Brillo graphics library.++tested-with:+ GHC ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2++homepage: https://github.com/ad-si/Brillo+bug-reports: https://github.com/ad-si/Brillo/issues+author: Timo A+maintainer: timo-a@gmx.ch+license: MIT+build-type: Simple+cabal-version: >=1.10+category: Graphics+extra-source-files:+ ChangeLog.md+ README.md++data-dir: test+data-files:+ expected_bmp.png+ expected_circle.png+ expected_circles.png+ expected_comprehensive.png+ expected_growing_polgons.gif+ expected_growing_polgons1.png+ expected_growing_polgons2.png+ expected_growing_polgons3.png+ expected_growing_polgons4.png+ expected_growing_polgons5.png+ expected_growing_polgons6.png+ expected_growing_polgons7.png+ expected_large_image.png+ expected_p10.png+ expected_p100.png+ expected_p20.png+ expected_p40.png+ expected_p60.png+ loadme.bmp++source-repository head+ type: git+ location: https://github.com/ad-si/Brillo++library+ hs-source-dirs: src+ ghc-options: -fwarn-unused-imports+ build-depends:+ base >=4.7 && <5+ , brillo-rendering >=2.0 && <3.0+ , bytestring >=0.11 && <0.13+ , GLFW-b >=1.0.0 && <4+ , JuicyPixels >=3.2 && <4+ , OpenGLRaw >=3.0 && <4+ , text >=2.0 && <3+ , vector >=0.9.1 && <1+ , webp >=0.1 && <0.2++ exposed-modules:+ Brillo.Export+ Brillo.Export.Bitmap+ Brillo.Export.Gif+ Brillo.Export.Image+ Brillo.Export.PNG+ Brillo.Export.SVG+ Brillo.Export.Tga+ Brillo.Export.Tiff+ Brillo.Export.WebP++ other-modules: Paths_brillo_export+ default-language: Haskell2010++executable brillo-export-exe+ main-is: Demo.hs+ hs-source-dirs: app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , brillo >=2.0 && <3.0+ , brillo-export++ other-modules: Paths_brillo_export+ default-language: Haskell2010++test-suite brillo-export-test+ type: exitcode-stdio-1.0+ main-is: Export.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , brillo >=2.0 && <3.0+ , brillo-export+ , directory+ , filepath+ , GLFW-b >=1.0.0 && <4+ , JuicyPixels+ , text >=2.0 && <3++ other-modules: Paths_brillo_export+ default-language: Haskell2010++test-suite brillo-svg-test+ type: exitcode-stdio-1.0+ main-is: SVGTest.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , brillo >=2.0 && <3.0+ , brillo-export+ , directory+ , filepath+ , text >=2.0 && <3++ default-language: Haskell2010++test-suite brillo-webp-test+ type: exitcode-stdio-1.0+ main-is: WebPTest.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , brillo >=2.0 && <3.0+ , brillo-export+ , bytestring >=0.11 && <0.13+ , directory+ , filepath+ , GLFW-b >=1.0.0 && <4+ , text >=2.0 && <3++ default-language: Haskell2010
+ src/Brillo/Export.hs view
@@ -0,0 +1,55 @@+{-| Main module for exporting Brillo pictures to image files, gif animations, SVG and juicy-pixels image datatypes.+ While no screen is displayed during the export process (except for SVG which is purely computed),+ the canvas is still limited to the screen's resolution for raster formats.+-}+module Brillo.Export (+ -- * For tinkering yourself+ withBrilloState,+ withImage,+ withImages,+ 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 (..),++ -- * Writing to SVG+ exportPictureToSVG,+ exportPicturesToSVG,+ renderPictureToSVG,+ pictureToSVGDoc,++ -- * Writing to WebP+ exportPictureToWebP,+ exportPicturesToWebP,+ exportPictureToWebPLossy,+ exportPicturesToWebPLossy,+) where++import Brillo.Export.Bitmap+import Brillo.Export.Gif+import Brillo.Export.Image+import Brillo.Export.PNG+import Brillo.Export.SVG+import Brillo.Export.Tga+import Brillo.Export.Tiff+import Brillo.Export.WebP+
+ src/Brillo/Export/Bitmap.hs view
@@ -0,0 +1,36 @@+module Brillo.Export.Bitmap (+ exportPictureToBitmap,+ exportPicturesToBitmap,+) where++import qualified Brillo.Rendering as Brillo+import Codec.Picture.Bitmap (writeBitmap)++import Brillo.Export.Image+++-- | Save a Brillo Picture as Bitmap+exportPictureToBitmap ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ Brillo.Picture ->+ IO ()+exportPictureToBitmap = exportPictureToFormat writeBitmap+++-- | Save a Brillo animation as Bitmap+exportPicturesToBitmap ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ -- | function that maps from point in time to Picture. analog to Brillo.Animation+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToBitmap = exportPicturesToFormat writeBitmap
+ src/Brillo/Export/Gif.hs view
@@ -0,0 +1,68 @@+module Brillo.Export.Gif (+ exportPicturesToGif,+ GifDelay,+ GifLooping (..),+) where++-- import Codec.Picture.Types++import qualified Brillo.Rendering as Brillo+import Codec.Picture++import Brillo.Export.Image+++-- | Save a Brillo animation as PNG+exportPicturesToGif ::+ -- | time between frames in centiseconds+ GifDelay ->+ GifLooping ->+ -- | width, height in pixels as in Brillo.Display+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ -- | function that maps from point in time to Picture. analog to Brillo.Animation+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToGif gifDelay gifLooping size bgc f anim ts = do+ withBrilloState 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+exportPicturesToGifByConverting :: GifDelay -- ^ time between frames (Int)+ -> GifLooping+ -> Size -- ^ width, height in pixels+ -> Brillo.Color -- ^ background color+ -> FilePath+ -> Animation -- ^ function that maps from point in time to Picture. analog to Brillo.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/Brillo/Export/Image.hs view
@@ -0,0 +1,195 @@+-- 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_Brillo/+-- slightly improved+-- Modified for Brillo++{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}+module Brillo.Export.Image+ ( Size+ , Animation+ , withBrilloState+ , withImage+ , withImages+ , exportPictureToFormat+ , exportPicturesToFormat+ ) where++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 Brillo.Rendering as Brillo+import Graphics.GL -- as GL*+import qualified Graphics.UI.GLFW as GLFW+import Foreign (newForeignPtr_)+import Foreign.Marshal.Array (allocaArray)+import Text.Printf (printf)+import GHC.Int+import Prelude hiding (concat)++type Size = (Int, Int)+type Animation = Float -> Brillo.Picture++-- | Save a Brillo 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 Brillo.Display+ -> Brillo.Color -- ^ Background color+ -> FilePath -> Brillo.Picture -> IO ()+exportPictureToFormat savefunc size bgc f p = do+ withBrilloState size $ \s -> do+ withImage size bgc s p $ \img -> do+ savefunc f img++-- | Acquire the Brillo.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 Brillo bitmaps faster to render because their textures are kept in video memory.+withBrilloState :: Size -> (Brillo.State -> IO a) -> IO a+withBrilloState size body = do+ s <- Brillo.initState+ withGLFW $ do+ GLFW.windowHint (GLFW.WindowHint'Visible False)+ withWindow size "Brillo.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 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 Brillo 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 Brillo.Display+ -> Brillo.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 Brillo.Animation+ -> [Float] -- ^ list of points in time at which to evaluate the animation+ -> IO ()+exportPicturesToFormat savefunc size bgc f anim ts = do+ withBrilloState 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+++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 Brillo 'Picture' into an 'Image'.+withImage :: forall pixel a. OpenGLPixel pixel+ => Size -- ^ (width, height) in pixels - as in Brillo.Display+ -> Brillo.Color -- ^ Background color+ -> Brillo.State -- ^ Obtained via 'withBrilloState'+ -> Brillo.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 :: Brillo.Picture+ flippedPicture = Brillo.Scale 1 (-1) p+ drawReadBuffer (windowWidth, windowHeight) bgc s flippedPicture+ allocaArray (windowWidth * windowHeight * bytesPerPixel) $ \imgData -> do+ let wW = fromIntegral windowWidth :: GHC.Int.Int32+ let wH = fromIntegral windowHeight :: GHC.Int.Int32+ glReadPixels 0 0 wW wH pixelFormat pixelType imgData+ foreignPtr <- newForeignPtr_ imgData+ 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 Brillo.Display+ -> Brillo.Color -- ^ Background color+ -> Brillo.State -- ^ Obtained via 'withBrilloState'+ -> [Brillo.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+ -> Brillo.Color -- ^ Background color+ -> Brillo.State -> Brillo.Picture -> IO ()+drawReadBuffer (windowWidth, windowHeight) bg s p = do+ glDrawBuffer GL_BACK+ -- Set viewport to match the window size+ glViewport 0 0 (fromIntegral windowWidth) (fromIntegral windowHeight)+ Brillo.withClearBuffer bg $ Brillo.withModelview (windowWidth, windowHeight) $ do+ glColor3f 0 0 0+ Brillo.renderPicture s 1 p+ glReadBuffer GL_BACK
+ src/Brillo/Export/PNG.hs view
@@ -0,0 +1,36 @@+module Brillo.Export.PNG (+ exportPictureToPNG,+ exportPicturesToPNG,+) where++import qualified Brillo.Rendering as Brillo+import Codec.Picture.Png (writePng)++import Brillo.Export.Image+++-- | Save a Brillo Picture as PNG+exportPictureToPNG ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ Brillo.Picture ->+ IO ()+exportPictureToPNG = exportPictureToFormat writePng+++-- | Save a Brillo animation as PNG+exportPicturesToPNG ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ -- | function that maps from point in time to Picture. analog to Brillo.Animation+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToPNG = exportPicturesToFormat writePng
+ src/Brillo/Export/SVG.hs view
@@ -0,0 +1,750 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-| Export Brillo pictures to SVG format.++This module provides functions to convert Brillo 'Picture' values+to SVG (Scalable Vector Graphics) format. SVG is a vector graphics+format that can be scaled without loss of quality.+-}+module Brillo.Export.SVG (+ -- * Export functions+ exportPictureToSVG,+ exportPicturesToSVG,++ -- * Direct rendering+ renderPictureToSVG,+ pictureToSVGDoc,+) where++import Brillo.Rendering (+ BitmapData (..),+ Color,+ Picture (..),+ Point,+ Rectangle (..),+ makeColor,+ rgbaOfColor,+ )+import Codec.Picture qualified as JP+import Data.ByteString.Lazy qualified as BL+import Data.List (intercalate)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Vector.Storable qualified as V+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (peekElemOff)+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf (printf)+++-- | Size of the output image (width, height) in pixels+type Size = (Int, Int)+++-- | An animation function that takes time and returns a Picture+type Animation = Float -> Picture+++-- | Export a Brillo Picture to an SVG file.+exportPictureToSVG ::+ -- | (width, height) in pixels+ Size ->+ -- | Background color+ Color ->+ -- | Output file path+ FilePath ->+ -- | Picture to export+ Picture ->+ IO ()+exportPictureToSVG size bgColor filePath picture = do+ let svg = pictureToSVGDoc size bgColor picture+ TIO.writeFile filePath svg+++{-| Export a series of Brillo Pictures to SVG files.+The file path pattern should contain "%d" which will be replaced by the frame number.+-}+exportPicturesToSVG ::+ -- | (width, height) in pixels+ Size ->+ -- | Background color+ Color ->+ -- | File path pattern (must contain "%d")+ FilePath ->+ -- | Animation function+ Animation ->+ -- | List of time points+ [Float] ->+ IO ()+exportPicturesToSVG size bgColor filePathPattern animation times = do+ mapM_ exportFrame (zip [1 ..] times)+ where+ exportFrame (n :: Int, t) = do+ let picture = animation t+ let filePath = printf filePathPattern n+ exportPictureToSVG size bgColor filePath picture+++{-| Render a Picture to SVG text.+Returns just the SVG content without the XML declaration and doctype.+-}+renderPictureToSVG ::+ -- | (width, height) in pixels+ Size ->+ -- | Background color+ Color ->+ -- | Picture to render+ Picture ->+ Text+renderPictureToSVG (width, height) bgColor picture =+ let+ -- SVG coordinate system has origin at top-left, y increases downward+ -- Brillo has origin at center, y increases upward+ -- We need to transform accordingly+ halfW = fromIntegral width / 2 :: Float+ halfH = fromIntegral height / 2 :: Float++ -- Create the transformed picture (flip y-axis and translate origin)+ transformedPicture = Translate halfW halfH (Scale 1 (-1) picture)++ -- Render background+ bgRect = renderBackground width height bgColor++ -- Render the picture content+ content = renderPicture defaultRenderState transformedPicture+ in+ T.concat [bgRect, content]+++-- | Convert a Picture to a complete SVG document.+pictureToSVGDoc ::+ -- | (width, height) in pixels+ Size ->+ -- | Background color+ Color ->+ -- | Picture to convert+ Picture ->+ Text+pictureToSVGDoc size@(width, height) bgColor picture =+ T.concat+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+ , "<svg xmlns=\"http://www.w3.org/2000/svg\" "+ , "xmlns:xlink=\"http://www.w3.org/1999/xlink\" "+ , "width=\""+ , T.pack (show width)+ , "\" height=\""+ , T.pack (show height)+ , "\" viewBox=\"0 0 "+ , T.pack (show width)+ , " "+ , T.pack (show height)+ , "\">\n"+ , renderPictureToSVG size bgColor picture+ , "</svg>\n"+ ]+++-- | State for rendering, tracks current color+data RenderState = RenderState+ { rsColor :: Color+ -- ^ Current fill/stroke color+ }+++-- | Default render state with black color+defaultRenderState :: RenderState+defaultRenderState =+ RenderState+ { rsColor = makeColor 0 0 0 1+ }+++-- | Render the background rectangle+renderBackground :: Int -> Int -> Color -> Text+renderBackground width height bgColor =+ T.concat+ [ " <rect x=\"0\" y=\"0\" width=\""+ , T.pack (show width)+ , "\" height=\""+ , T.pack (show height)+ , "\" fill=\""+ , colorToSVG bgColor+ , "\"/>\n"+ ]+++-- | Convert a Brillo Color to SVG color string+colorToSVG :: Color -> Text+colorToSVG color =+ let (r, g, b, a) = rgbaOfColor color+ ri = round (r * 255) :: Int+ gi = round (g * 255) :: Int+ bi = round (b * 255) :: Int+ in if a >= 1.0+ then T.pack $ printf "rgb(%d,%d,%d)" ri gi bi+ else T.pack $ printf "rgba(%d,%d,%d,%.3f)" ri gi bi a+++-- | Get opacity from color+colorOpacity :: Color -> Float+colorOpacity color =+ let (_, _, _, a) = rgbaOfColor color+ in a+++-- | Main picture rendering function+renderPicture :: RenderState -> Picture -> Text+renderPicture _ Blank = ""+renderPicture rs (Polygon path) = renderPolygonSmooth rs path+renderPicture rs (PolygonAliased path) = renderPolygon rs path+renderPicture rs (Line path) = renderLine rs path 1.0+renderPicture rs (LineAliased path) = renderSmoothLine rs path 1.0+renderPicture rs (ThickLine path thickness) = renderLine rs path thickness+renderPicture rs (ThickLineAliased path thickness) = renderSmoothLine rs path thickness+renderPicture rs (Circle radius) = renderCircleSmooth rs radius 1.0+renderPicture rs (CircleAliased radius) = renderCircle rs radius 1.0+renderPicture rs (ThickCircle radius thickness) = renderThickCircleSmooth rs radius thickness+renderPicture rs (ThickCircleAliased radius thickness) = renderThickCircle rs radius thickness+renderPicture rs (Arc startAngle endAngle radius) = renderArcSmooth rs startAngle endAngle radius 1.0+renderPicture rs (ArcAliased startAngle endAngle radius) = renderArc rs startAngle endAngle radius 1.0+renderPicture rs (ThickArc startAngle endAngle thickness radius) = renderArcSmooth rs startAngle endAngle radius thickness+renderPicture rs (ThickArcAliased startAngle endAngle thickness radius) = renderArc rs startAngle endAngle radius thickness+renderPicture rs (Text txt) = renderTextSmooth rs txt 1.0+renderPicture rs (TextAliased txt) = renderText rs txt 1.0+renderPicture rs (ThickText txt thickness) = renderTextSmooth rs txt thickness+renderPicture rs (ThickTextAliased txt thickness) = renderText rs txt thickness+renderPicture rs (TrueTypeText _fontPath _size txt) = renderText rs txt 1.0+renderPicture rs (Bitmap bitmapData) = renderBitmap rs bitmapData Nothing+renderPicture rs (BitmapSection rect bitmapData) = renderBitmap rs bitmapData (Just rect)+renderPicture rs (Color color picture) =+ renderPicture (rs{rsColor = color}) picture+renderPicture rs (Translate dx dy picture) =+ T.concat+ [ " <g transform=\"translate("+ , T.pack (showFloat dx)+ , ","+ , T.pack (showFloat dy)+ , ")\">\n"+ , renderPicture rs picture+ , " </g>\n"+ ]+renderPicture rs (Rotate angle picture) =+ -- Brillo uses clockwise rotation in degrees+ -- SVG uses clockwise rotation in degrees too+ T.concat+ [ " <g transform=\"rotate("+ , T.pack (showFloat (-angle))+ , ")\">\n"+ , renderPicture rs picture+ , " </g>\n"+ ]+renderPicture rs (Scale sx sy picture) =+ T.concat+ [ " <g transform=\"scale("+ , T.pack (showFloat sx)+ , ","+ , T.pack (showFloat sy)+ , ")\">\n"+ , renderPicture rs picture+ , " </g>\n"+ ]+renderPicture rs (Pictures pictures) =+ T.concat (map (renderPicture rs) pictures)+++-- | Render a filled polygon+renderPolygon :: RenderState -> [Point] -> Text+renderPolygon _ [] = ""+renderPolygon rs points =+ T.concat+ [ " <polygon points=\""+ , T.pack $ unwords [showFloat x ++ "," ++ showFloat y | (x, y) <- points]+ , "\" fill=\""+ , colorToSVG (rsColor rs)+ , "\""+ , opacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render a filled polygon with anti-aliased edges (uses shape-rendering: geometricPrecision)+renderPolygonSmooth :: RenderState -> [Point] -> Text+renderPolygonSmooth _ [] = ""+renderPolygonSmooth rs points =+ T.concat+ [ " <polygon points=\""+ , T.pack $ unwords [showFloat x ++ "," ++ showFloat y | (x, y) <- points]+ , "\" fill=\""+ , colorToSVG (rsColor rs)+ , "\" shape-rendering=\"geometricPrecision\""+ , opacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render a line (polyline)+renderLine :: RenderState -> [Point] -> Float -> Text+renderLine _ [] _ = ""+renderLine _ [_] _ = ""+renderLine rs points thickness =+ T.concat+ [ " <polyline points=\""+ , T.pack $ unwords [showFloat x ++ "," ++ showFloat y | (x, y) <- points]+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (max 1.0 thickness))+ , "\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render a smooth line using cubic bezier curves+renderSmoothLine :: RenderState -> [Point] -> Float -> Text+renderSmoothLine _ [] _ = ""+renderSmoothLine _ [_] _ = ""+renderSmoothLine rs points thickness =+ let pathData = smoothPathToSVG points+ in T.concat+ [ " <path d=\""+ , pathData+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (max 1.0 thickness))+ , "\" stroke-linecap=\"round\" stroke-linejoin=\"round\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Convert a path to a smooth SVG path using cubic bezier curves+smoothPathToSVG :: [Point] -> Text+smoothPathToSVG [] = ""+smoothPathToSVG [p] = T.pack $ "M " ++ showPoint p+smoothPathToSVG [p1, p2] = T.pack $ "M " ++ showPoint p1 ++ " L " ++ showPoint p2+smoothPathToSVG (p1 : p2 : rest) =+ T.pack $+ "M "+ ++ showPoint p1+ ++ " "+ ++ smoothCurves (p1 : p2 : rest)+ where+ smoothCurves :: [Point] -> String+ smoothCurves pts+ | length pts < 3 = ""+ | otherwise = intercalate " " $ zipWith3 makeCurve pts (drop 1 pts) (drop 2 pts)++ makeCurve :: Point -> Point -> Point -> String+ makeCurve (_x0, _y0) (x1, y1) (x2, y2) =+ let cx2 = (x1 + x2) / 2+ cy2 = (y1 + y2) / 2+ in "Q "+ ++ showFloat x1+ ++ " "+ ++ showFloat y1+ ++ " "+ ++ showFloat cx2+ ++ " "+ ++ showFloat cy2+++-- | Render a circle outline+renderCircle :: RenderState -> Float -> Float -> Text+renderCircle rs radius thickness =+ T.concat+ [ " <circle cx=\"0\" cy=\"0\" r=\""+ , T.pack (showFloat (abs radius))+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (max 1.0 thickness))+ , "\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render a circle outline with anti-aliasing+renderCircleSmooth :: RenderState -> Float -> Float -> Text+renderCircleSmooth rs radius thickness =+ T.concat+ [ " <circle cx=\"0\" cy=\"0\" r=\""+ , T.pack (showFloat (abs radius))+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (max 1.0 thickness))+ , "\" shape-rendering=\"geometricPrecision\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++{-| Render a thick circle (annulus/ring or filled disc)+ThickCircle has parameters: radius (center of ring) and thickness (width of ring)+Inner radius = radius - thickness/2, Outer radius = radius + thickness/2+-}+renderThickCircle :: RenderState -> Float -> Float -> Text+renderThickCircle rs radius thickness+ | thickness <= 0 = renderCircle rs radius 1.0+ | otherwise =+ let innerRadius = abs radius - thickness / 2+ outerRadius = abs radius + thickness / 2+ in if innerRadius <= 0+ then+ -- Inner radius is zero or negative, render as filled circle+ T.concat+ [ " <circle cx=\"0\" cy=\"0\" r=\""+ , T.pack (showFloat outerRadius)+ , "\" fill=\""+ , colorToSVG (rsColor rs)+ , "\""+ , opacityAttr (rsColor rs)+ , "/>\n"+ ]+ else+ -- Render as a ring (stroke)+ T.concat+ [ " <circle cx=\"0\" cy=\"0\" r=\""+ , T.pack (showFloat ((innerRadius + outerRadius) / 2))+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (outerRadius - innerRadius))+ , "\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++{-| Render a thick circle (annulus/ring or filled disc) with anti-aliasing+ThickCircle has parameters: radius (center of ring) and thickness (width of ring)+Inner radius = radius - thickness/2, Outer radius = radius + thickness/2+-}+renderThickCircleSmooth :: RenderState -> Float -> Float -> Text+renderThickCircleSmooth rs radius thickness+ | thickness <= 0 = renderCircleSmooth rs radius 1.0+ | otherwise =+ let innerRadius = abs radius - thickness / 2+ outerRadius = abs radius + thickness / 2+ in if innerRadius <= 0+ then+ -- Inner radius is zero or negative, render as filled circle+ T.concat+ [ " <circle cx=\"0\" cy=\"0\" r=\""+ , T.pack (showFloat outerRadius)+ , "\" fill=\""+ , colorToSVG (rsColor rs)+ , "\" shape-rendering=\"geometricPrecision\""+ , opacityAttr (rsColor rs)+ , "/>\n"+ ]+ else+ -- Render as a ring (stroke)+ T.concat+ [ " <circle cx=\"0\" cy=\"0\" r=\""+ , T.pack (showFloat ((innerRadius + outerRadius) / 2))+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (outerRadius - innerRadius))+ , "\" shape-rendering=\"geometricPrecision\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render an arc+renderArc :: RenderState -> Float -> Float -> Float -> Float -> Text+renderArc rs startAngle endAngle radius thickness =+ let+ -- Convert angles from degrees to radians+ -- Brillo uses counter-clockwise from the positive x-axis+ -- SVG arcs need special handling+ r = abs radius+ startRad = startAngle * pi / 180+ endRad = endAngle * pi / 180++ -- Calculate start and end points+ x1 = r * cos startRad+ y1 = r * sin startRad+ x2 = r * cos endRad+ y2 = r * sin endRad++ -- Determine arc sweep (large arc flag and sweep direction)+ angleDiff = endAngle - startAngle+ largeArc = if abs angleDiff > 180 then 1 else 0 :: Int+ sweep = if angleDiff > 0 then 1 else 0 :: Int++ pathData =+ "M "+ ++ showFloat x1+ ++ " "+ ++ showFloat y1+ ++ " A "+ ++ showFloat r+ ++ " "+ ++ showFloat r+ ++ " 0 "+ ++ show largeArc+ ++ " "+ ++ show sweep+ ++ " "+ ++ showFloat x2+ ++ " "+ ++ showFloat y2+ in+ T.concat+ [ " <path d=\""+ , T.pack pathData+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (max 1.0 thickness))+ , "\" stroke-linecap=\"round\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render an arc with anti-aliasing+renderArcSmooth :: RenderState -> Float -> Float -> Float -> Float -> Text+renderArcSmooth rs startAngle endAngle radius thickness =+ let+ -- Convert angles from degrees to radians+ -- Brillo uses counter-clockwise from the positive x-axis+ -- SVG arcs need special handling+ r = abs radius+ startRad = startAngle * pi / 180+ endRad = endAngle * pi / 180++ -- Calculate start and end points+ x1 = r * cos startRad+ y1 = r * sin startRad+ x2 = r * cos endRad+ y2 = r * sin endRad++ -- Determine arc sweep (large arc flag and sweep direction)+ angleDiff = endAngle - startAngle+ largeArc = if abs angleDiff > 180 then 1 else 0 :: Int+ sweep = if angleDiff > 0 then 1 else 0 :: Int++ pathData =+ "M "+ ++ showFloat x1+ ++ " "+ ++ showFloat y1+ ++ " A "+ ++ showFloat r+ ++ " "+ ++ showFloat r+ ++ " 0 "+ ++ show largeArc+ ++ " "+ ++ show sweep+ ++ " "+ ++ showFloat x2+ ++ " "+ ++ showFloat y2+ in+ T.concat+ [ " <path d=\""+ , T.pack pathData+ , "\" fill=\"none\" stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (max 1.0 thickness))+ , "\" stroke-linecap=\"round\" shape-rendering=\"geometricPrecision\""+ , strokeOpacityAttr (rsColor rs)+ , "/>\n"+ ]+++-- | Render text+renderText :: RenderState -> Text -> Float -> Text+renderText rs txt thickness =+ T.concat+ [ " <text x=\"0\" y=\"0\" fill=\""+ , colorToSVG (rsColor rs)+ , "\" font-family=\"monospace\" font-size=\"100\""+ , if thickness > 1.0+ then+ T.concat+ [ " stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (thickness - 1.0))+ , "\""+ ]+ else ""+ , opacityAttr (rsColor rs)+ , ">"+ , escapeXML txt+ , "</text>\n"+ ]+++-- | Render text with anti-aliasing+renderTextSmooth :: RenderState -> Text -> Float -> Text+renderTextSmooth rs txt thickness =+ T.concat+ [ " <text x=\"0\" y=\"0\" fill=\""+ , colorToSVG (rsColor rs)+ , "\" font-family=\"monospace\" font-size=\"100\" text-rendering=\"geometricPrecision\""+ , if thickness > 1.0+ then+ T.concat+ [ " stroke=\""+ , colorToSVG (rsColor rs)+ , "\" stroke-width=\""+ , T.pack (showFloat (thickness - 1.0))+ , "\""+ ]+ else ""+ , opacityAttr (rsColor rs)+ , ">"+ , escapeXML txt+ , "</text>\n"+ ]+++-- | Render a bitmap image as a data URI embedded image+renderBitmap :: RenderState -> BitmapData -> Maybe Rectangle -> Text+renderBitmap _ bitmapData maybeRect =+ let+ BitmapData _len _fmt (bmpWidth, bmpHeight) _cache fptr = bitmapData++ -- Get the actual section to render+ (srcX, srcY, width, height) = case maybeRect of+ Nothing -> (0, 0, bmpWidth, bmpHeight)+ Just (Rectangle (rx, ry) (rw, rh)) -> (rx, ry, rw, rh)++ -- Create a base64 PNG data URI+ dataUri = unsafePerformIO $ do+ withForeignPtr fptr $ \ptr -> do+ -- Read pixel data+ let pixelCount = bmpWidth * bmpHeight * 4+ pixelData <- V.generateM pixelCount $ \i -> do+ let bytePtr = castPtr ptr :: Ptr Word8+ peekElemOff bytePtr i++ -- Create JuicyPixels image+ let img = JP.Image bmpWidth bmpHeight pixelData :: JP.Image JP.PixelRGBA8++ -- Encode to PNG and then base64+ let pngBytes = JP.encodePng img+ pure $ "data:image/png;base64," ++ encodeBase64 (BL.unpack pngBytes)++ -- Center the image at origin (Brillo convention)+ halfW = fromIntegral width / 2 :: Float+ halfH = fromIntegral height / 2 :: Float+ in+ T.concat+ [ " <image x=\""+ , T.pack (showFloat (-halfW))+ , "\" y=\""+ , T.pack (showFloat (-halfH))+ , "\" width=\""+ , T.pack (show width)+ , "\" height=\""+ , T.pack (show height)+ , "\" xlink:href=\""+ , T.pack dataUri+ , "\""+ , if srcX /= 0 || srcY /= 0+ then+ T.concat+ [ " preserveAspectRatio=\"xMinYMin slice\" viewBox=\""+ , T.pack (show srcX)+ , " "+ , T.pack (show srcY)+ , " "+ , T.pack (show width)+ , " "+ , T.pack (show height)+ , "\""+ ]+ else ""+ , "/>\n"+ ]+++-- | Simple base64 encoding+encodeBase64 :: [Word8] -> String+encodeBase64 = go+ where+ go [] = ""+ go [a] =+ let (i1, i2) = (fromIntegral a `div` 4, (fromIntegral a `mod` 4) * 16)+ in [base64Char i1, base64Char i2, '=', '=']+ go [a, b] =+ let i1 = fromIntegral a `div` 4+ i2 = ((fromIntegral a `mod` 4) * 16) + (fromIntegral b `div` 16)+ i3 = (fromIntegral b `mod` 16) * 4+ in [base64Char i1, base64Char i2, base64Char i3, '=']+ go (a : b : c : rest) =+ let i1 = fromIntegral a `div` 4+ i2 = ((fromIntegral a `mod` 4) * 16) + (fromIntegral b `div` 16)+ i3 = ((fromIntegral b `mod` 16) * 4) + (fromIntegral c `div` 64)+ i4 = fromIntegral c `mod` 64+ in base64Char i1 : base64Char i2 : base64Char i3 : base64Char i4 : go rest++ base64Char :: Int -> Char+ base64Char n+ | n < 26 = toEnum (fromEnum 'A' + n)+ | n < 52 = toEnum (fromEnum 'a' + n - 26)+ | n < 62 = toEnum (fromEnum '0' + n - 52)+ | n == 62 = '+'+ | otherwise = '/'+++-- | Escape XML special characters+escapeXML :: Text -> Text+escapeXML = T.concatMap escapeChar+ where+ escapeChar '<' = "<"+ escapeChar '>' = ">"+ escapeChar '&' = "&"+ escapeChar '"' = """+ escapeChar '\'' = "'"+ escapeChar c = T.singleton c+++-- | Show a floating point number with reasonable precision+showFloat :: Float -> String+showFloat f+ | isNaN f = "0"+ | isInfinite f = if f > 0 then "1e10" else "-1e10"+ | abs f < 0.0001 = "0"+ | abs (f - fromIntegral (round f :: Int)) < 0.0001 = show (round f :: Int)+ | otherwise = printf "%.4f" f+++-- | Show a point+showPoint :: Point -> String+showPoint (x, y) = showFloat x ++ " " ++ showFloat y+++-- | Generate opacity attribute if needed+opacityAttr :: Color -> Text+opacityAttr color =+ let a = colorOpacity color+ in if a < 1.0+ then T.pack $ printf " fill-opacity=\"%.3f\"" a+ else ""+++-- | Generate stroke opacity attribute if needed+strokeOpacityAttr :: Color -> Text+strokeOpacityAttr color =+ let a = colorOpacity color+ in if a < 1.0+ then T.pack $ printf " stroke-opacity=\"%.3f\"" a+ else ""
+ src/Brillo/Export/Tga.hs view
@@ -0,0 +1,36 @@+module Brillo.Export.Tga (+ exportPictureToTga,+ exportPicturesToTga,+) where++import qualified Brillo.Rendering as Brillo+import Codec.Picture.Tga (writeTga)++import Brillo.Export.Image+++-- | Save a Brillo Picture as Tga+exportPictureToTga ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ Brillo.Picture ->+ IO ()+exportPictureToTga = exportPictureToFormat writeTga+++-- | Save a Brillo animation as Tga+exportPicturesToTga ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ -- | function that maps from point in time to Picture. analog to Brillo.Animation+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToTga = exportPicturesToFormat writeTga
+ src/Brillo/Export/Tiff.hs view
@@ -0,0 +1,36 @@+module Brillo.Export.Tiff (+ exportPictureToTiff,+ exportPicturesToTiff,+) where++import qualified Brillo.Rendering as Brillo+import Codec.Picture.Tiff (writeTiff)++import Brillo.Export.Image+++-- | Save a Brillo Picture as Tiff+exportPictureToTiff ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ Brillo.Picture ->+ IO ()+exportPictureToTiff = exportPictureToFormat writeTiff+++-- | Save a Brillo animation as Tiff+exportPicturesToTiff ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ -- | function that maps from point in time to Picture. analog to Brillo.Animation+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToTiff = exportPicturesToFormat writeTiff
+ src/Brillo/Export/WebP.hs view
@@ -0,0 +1,86 @@+module Brillo.Export.WebP (+ exportPictureToWebP,+ exportPicturesToWebP,+ exportPictureToWebPLossy,+ exportPicturesToWebPLossy,+) where++import qualified Brillo.Rendering as Brillo+import Codec.Picture.Types (Image, PixelRGBA8)+import qualified Codec.Picture.WebP as WebP+import qualified Data.ByteString as BS+import Foreign.C.Types (CFloat)++import Brillo.Export.Image+++-- | Write a WebP file (lossless)+writeWebPLossless :: FilePath -> Image PixelRGBA8 -> IO ()+writeWebPLossless path img = BS.writeFile path (WebP.encodeRgba8Lossless img)+++-- | Write a WebP file with lossy compression+writeWebPLossy :: CFloat -> FilePath -> Image PixelRGBA8 -> IO ()+writeWebPLossy quality path img = BS.writeFile path (WebP.encodeRgba8 quality img)+++-- | Save a Brillo Picture as lossless WebP+exportPictureToWebP ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ Brillo.Picture ->+ IO ()+exportPictureToWebP = exportPictureToFormat writeWebPLossless+++-- | Save a Brillo animation as lossless WebP+exportPicturesToWebP ::+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ -- | filepath pattern (must contain "%d" for frame number)+ FilePath ->+ -- | function that maps from point in time to Picture+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToWebP = exportPicturesToFormat writeWebPLossless+++-- | Save a Brillo Picture as lossy WebP with specified quality+exportPictureToWebPLossy ::+ -- | quality (0.0 to 100.0)+ Float ->+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ FilePath ->+ Brillo.Picture ->+ IO ()+exportPictureToWebPLossy quality =+ exportPictureToFormat (writeWebPLossy (realToFrac quality))+++-- | Save a Brillo animation as lossy WebP with specified quality+exportPicturesToWebPLossy ::+ -- | quality (0.0 to 100.0)+ Float ->+ -- | width, height in pixels+ Size ->+ -- | background color+ Brillo.Color ->+ -- | filepath pattern (must contain "%d" for frame number)+ FilePath ->+ -- | function that maps from point in time to Picture+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesToWebPLossy quality =+ exportPicturesToFormat (writeWebPLossy (realToFrac quality))
+ test/Export.hs view
@@ -0,0 +1,313 @@+module Main where++import Brillo.Data.Bitmap+import Brillo.Data.Color+import Brillo.Data.Picture+import Brillo.Export+import Brillo.Export.Image+import Codec.Picture+import Control.Monad+import Data.Foldable+import Data.Text (pack)+import qualified Graphics.UI.GLFW as GLFW+import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)+import System.FilePath+import Text.Printf++import qualified Paths_brillo_export as Paths+++{-| Check if GLFW can initialize and create a window (i.e., we have a display+available). On Windows, GLFW.init can succeed even without a display, so we+also try creating a hidden window to verify.+This is used to skip tests in headless CI environments.+-}+canInitializeGLFW :: IO Bool+canInitializeGLFW = do+ result <- GLFW.init+ if not result+ then pure False+ else do+ GLFW.windowHint (GLFW.WindowHint'Visible False)+ maybeWindow <- GLFW.createWindow 1 1 "" Nothing Nothing+ case maybeWindow of+ Nothing -> do+ GLFW.terminate+ pure False+ Just window -> do+ GLFW.destroyWindow window+ GLFW.terminate+ pure True+++-- 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 dynamicImage2)+++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 ..] :: [Int]) (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 in the data directory, prefixed with "expected_".+assertSameImageAsExpected :: FilePath -> FilePath -> FilePath -> IO ()+assertSameImageAsExpected dataDir outputDir filePath = do+ let expectedFilePath = dataDir </> replaceExtension ("expected_" ++ filePath) "png"+ assertSameImageFiles (outputDir </> filePath) expectedFilePath+++-- A wrapper around functions like 'exportPictureToPNG' which also validates+-- the generated image.+exportPictureAndCheck ::+ FilePath ->+ FilePath ->+ -- | wrapped export function+ (Size -> Color -> FilePath -> Picture -> IO ()) ->+ -- | width, height in pixels+ Size ->+ -- | background color+ Color ->+ FilePath ->+ Picture ->+ IO ()+exportPictureAndCheck dataDir outputDir exportPicture imgSize bg filePath picture = do+ exportPicture imgSize bg (outputDir </> filePath) picture+ assertSameImageAsExpected dataDir outputDir filePath+++-- A wrapper around functions like 'exportPicturesToPNG' which also validates+-- the generated images.+exportPicturesAndCheck ::+ FilePath ->+ FilePath ->+ -- | wrapped export function+ (Size -> Color -> FilePath -> Animation -> [Float] -> IO ()) ->+ -- | width, height in pixels+ Size ->+ -- | background color+ Color ->+ FilePath ->+ -- | function that maps from point in time to Picture. analog to Brillo.Animation+ Animation ->+ -- | list of points in time at which to evaluate the animation+ [Float] ->+ IO ()+exportPicturesAndCheck dataDir outputDir exportPictures imgSize bg filePathPattern animation ts = do+ exportPictures imgSize bg (outputDir </> filePathPattern) animation ts+ for_ [1 .. length ts] $ \i -> do+ let filePath = printf filePathPattern i+ assertSameImageAsExpected dataDir outputDir filePath+++size :: (Int, Int)+size = (1500, 1000)+++main :: IO ()+main = do+ -- Check if we can initialize GLFW (requires a display).+ -- Skip tests gracefully in headless CI environments.+ hasDisplay <- canInitializeGLFW+ unless hasDisplay $ do+ putStrLn+ "Skipping brillo-export tests: no display available (GLFW cannot initialize)"+ putStrLn "This is expected in headless CI environments."+ pure ()++ when hasDisplay $ do+ -- Get the data directory where test fixtures are installed+ dataDir <- Paths.getDataDir++ -- Create a temporary output directory for generated images+ tmpDir <- getTemporaryDirectory+ let outputDir = tmpDir </> "brillo-export-test"+ createDirectoryIfMissing True outputDir++ -- Helper functions with directories bound+ let check = exportPictureAndCheck dataDir outputDir+ let checkMulti = exportPicturesAndCheck dataDir outputDir+ let shorthand = check exportPictureToPNG size white++ -- Test multiple Brillo features and multiple export formats.+ -- Use aliased primitives for deterministic rendering output.+ bmp <- loadBMP (dataDir </> "loadme.bmp")+ let pic =+ Pictures+ [ bmp+ , Color red $ PolygonAliased [(-80, 0), (0, 80), (80, 0)]+ , CircleAliased 80+ , TextAliased (pack "text")+ ]+ check+ exportPictureToPNG+ (400, 400)+ white+ "comprehensive.png"+ pic+ check+ exportPictureToBitmap+ (400, 400)+ white+ "comprehensive.bmp"+ pic+ check+ exportPictureToTga+ (400, 400)+ white+ "comprehensive.tga"+ pic+ check+ exportPictureToTiff+ (400, 400)+ white+ "comprehensive.tiff"+ pic+ -- display (InWindow "" (100,80) (0, 0)) white pic+ shorthand "bmp.png" (bmp)+ shorthand "circle.png" (CircleAliased 25)+ check+ exportPictureToPNG+ (500, 500)+ white+ "circles.png"+ (Pictures (map CircleAliased [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 $ ThickCircleAliased 10 80+ , Translate wby2 hby2 $ ThickCircleAliased 10 80+ , Color blue $ LineAliased [(-wby2, hby2), (wby2, -hby2)]+ , ThickCircleAliased 10 80+ ]+ check 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+ ]+ )++ check exportPictureToPNG (10, 10) white "p10.png" stack+ check exportPictureToPNG (20, 20) white "p20.png" stack+ check exportPictureToPNG (40, 40) white "p40.png" stack+ check exportPictureToPNG (60, 60) white "p60.png" stack+ check exportPictureToPNG (100, 100) white "p100.png" stack++ checkMulti+ exportPicturesToPNG+ (1000, 1000)+ white+ "growing_polgons%d.png"+ (Color blue . poly)+ [200, 250 .. 500]+ checkMulti+ exportPicturesToBitmap+ (1000, 1000)+ white+ "growing_polgons%d.bmp"+ (Color blue . poly)+ [200, 250 .. 500]+ checkMulti+ exportPicturesToTga+ (1000, 1000)+ white+ "growing_polgons%d.tga"+ (Color blue . poly)+ [200, 250 .. 500]+ checkMulti+ exportPicturesToTiff+ (1000, 1000)+ white+ "growing_polgons%d.tiff"+ (Color blue . poly)+ [200, 250 .. 500]++ exportPicturesToGif+ 10+ LoopingNever+ (1000, 1000)+ red+ (outputDir </> "growing_polgons.gif")+ (Color blue . poly)+ [200, 250 .. 500]+ assertSameGifFiles+ (outputDir </> "growing_polgons.gif")+ (dataDir </> "expected_growing_polgons.gif")+++textFloats :: [Float]+textFloats = [0, 1 .. 10]+++-- Use aliased polygon for deterministic rendering+poly :: Float -> Picture+poly l = PolygonAliased [(-l, l), (l, l), (l, -l), (-l, -l)]
+ test/SVGTest.hs view
@@ -0,0 +1,802 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++{-| Comprehensive test suite for SVG export functionality.++This module tests all Picture primitives and SVG features to ensure+complete coverage of the SVG export functionality.+-}+module Main where++import Brillo.Data.Color+import Brillo.Data.Picture+import Brillo.Export.SVG+import Control.Monad (forM_, unless)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import System.Directory (+ createDirectoryIfMissing,+ doesFileExist,+ getTemporaryDirectory,+ )+import System.Exit (exitFailure, exitSuccess)+import System.FilePath ((</>))+import Text.Printf (printf)+++-- | Test result type+data TestResult+ = TestPass String+ | TestFail String String+ deriving (Show)+++isPass :: TestResult -> Bool+isPass (TestPass _) = True+isPass _ = False+++-- | Run a test and return the result+runTest :: String -> IO Bool -> IO TestResult+runTest name action = do+ putStr $ " Testing " ++ name ++ "... "+ result <- action+ if result+ then do+ putStrLn "PASS"+ pure $ TestPass name+ else do+ putStrLn "FAIL"+ pure $ TestFail name "Assertion failed"+++-- | Assert that a condition is true+assertBool :: String -> Bool -> IO Bool+assertBool _ True = pure True+assertBool msg False = do+ putStrLn $ "\n ERROR: " ++ msg+ pure False+++-- | Assert that text contains a substring+assertContains :: Text -> Text -> IO Bool+assertContains haystack needle =+ assertBool+ ("Expected to find: " ++ T.unpack needle)+ (needle `T.isInfixOf` haystack)+++-- | Assert that text contains all substrings+assertContainsAll :: Text -> [Text] -> IO Bool+assertContainsAll haystack needles = do+ results <- mapM (assertContains haystack) needles+ pure $ and results+++-- | Standard test size+testSize :: (Int, Int)+testSize = (400, 400)+++-- | Output directory for test SVGs+getTestOutputDir :: IO FilePath+getTestOutputDir = do+ tmpDir <- getTemporaryDirectory+ let outputDir = tmpDir </> "brillo-svg-test"+ createDirectoryIfMissing True outputDir+ pure outputDir+++-- ============================================================================+-- Test Categories+-- ============================================================================++-- | Test basic SVG document structure+testDocumentStructure :: IO [TestResult]+testDocumentStructure = do+ putStrLn "\n=== Testing SVG Document Structure ==="++ sequence+ [ runTest "SVG header" $ do+ let svg = pictureToSVGDoc (100, 100) white Blank+ assertContainsAll+ svg+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<svg xmlns=\"http://www.w3.org/2000/svg\""+ , "xmlns:xlink=\"http://www.w3.org/1999/xlink\""+ , "width=\"100\""+ , "height=\"100\""+ , "viewBox=\"0 0 100 100\""+ , "</svg>"+ ]+ , runTest "SVG dimensions" $ do+ let svg = pictureToSVGDoc (800, 600) white Blank+ assertContainsAll+ svg+ [ "width=\"800\""+ , "height=\"600\""+ , "viewBox=\"0 0 800 600\""+ ]+ , runTest "Background color white" $ do+ let svg = pictureToSVGDoc (100, 100) white Blank+ assertContains svg "fill=\"rgb(255,255,255)\""+ , runTest "Background color black" $ do+ let svg = pictureToSVGDoc (100, 100) black Blank+ assertContains svg "fill=\"rgb(0,0,0)\""+ , runTest "Background color red" $ do+ let svg = pictureToSVGDoc (100, 100) red Blank+ assertContains svg "fill=\"rgb(255,0,0)\""+ , runTest "Background color with alpha" $ do+ let svg = pictureToSVGDoc (100, 100) (makeColor 1 0 0 0.5) Blank+ assertContains svg "rgba(255,0,0,0.500)"+ ]+++-- | Test Blank picture+testBlank :: IO [TestResult]+testBlank = do+ putStrLn "\n=== Testing Blank Picture ==="++ sequence+ [ runTest "Blank produces no content" $ do+ let svg = renderPictureToSVG testSize white Blank+ -- Should only have the background rect and transform wrappers, no actual shapes+ _ <- assertBool "Blank should have no circles" (not $ T.isInfixOf "<circle" svg)+ _ <-+ assertBool "Blank should have no polygons" (not $ T.isInfixOf "<polygon" svg)+ assertBool "Blank should have no polylines" (not $ T.isInfixOf "<polyline" svg)+ ]+++-- | Test Polygon primitive+testPolygon :: IO [TestResult]+testPolygon = do+ putStrLn "\n=== Testing Polygon Primitive ==="++ sequence+ [ runTest "Simple triangle" $ do+ let pic = Polygon [(0, 0), (100, 0), (50, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<polygon", "points="]+ , runTest "Square polygon" $ do+ let pic = Polygon [(-50, -50), (50, -50), (50, 50), (-50, 50)]+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polygon"+ , runTest "Empty polygon" $ do+ let pic = Polygon []+ let svg = pictureToSVGDoc testSize white pic+ -- Empty polygon should not produce polygon element+ pure $ not (T.isInfixOf "<polygon" svg)+ , runTest "Polygon with color" $ do+ let pic = Color blue $ Polygon [(0, 0), (100, 0), (50, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "fill=\"rgb(0,0,255)\""+ , runTest "Polygon with alpha" $ do+ let pic = Color (makeColor 1 0 0 0.5) $ Polygon [(0, 0), (100, 0), (50, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["rgba(255,0,0,0.500)", "fill-opacity"]+ , runTest "Complex polygon (star)" $ do+ let starPoints =+ [ (0, 100)+ , (22, 31)+ , (95, 31)+ , (36, -12)+ , (59, -81)+ , (0, -38)+ , (-59, -81)+ , (-36, -12)+ , (-95, 31)+ , (-22, 31)+ ]+ let pic = Polygon starPoints+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polygon"+ ]+++-- | Test Line primitives+testLine :: IO [TestResult]+testLine = do+ putStrLn "\n=== Testing Line Primitives ==="++ sequence+ [ runTest "Simple line" $ do+ let pic = Line [(0, 0), (100, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polyline"+ , runTest "Line with multiple points" $ do+ let pic = Line [(0, 0), (50, 100), (100, 0), (150, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<polyline", "points=", "fill=\"none\"", "stroke="]+ , runTest "ThickLine" $ do+ let pic = ThickLine [(0, 0), (100, 100)] 5.0+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<polyline", "stroke-width=\"5"]+ , runTest "ThickLine with varying thickness" $ do+ let pic = ThickLine [(0, 0), (100, 100)] 10.0+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "stroke-width=\"10"+ , runTest "Line with color" $ do+ let pic = Color green $ Line [(0, 0), (100, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "stroke=\"rgb(0,255,0)\""+ , runTest "Empty line" $ do+ let pic = Line []+ let svg = pictureToSVGDoc testSize white pic+ pure $ not (T.isInfixOf "<polyline" svg)+ , runTest "Single point line" $ do+ let pic = Line [(50, 50)]+ let svg = pictureToSVGDoc testSize white pic+ pure $ not (T.isInfixOf "<polyline" svg)+ , runTest "LineAliased" $ do+ let pic = LineAliased [(0, 0), (50, 100), (100, 0), (150, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll+ svg+ ["<path", "stroke-linecap=\"round\"", "stroke-linejoin=\"round\""]+ , runTest "ThickLineAliased" $ do+ let pic = ThickLineAliased [(0, 0), (50, 100), (100, 0)] 8.0+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<path", "stroke-width=\"8"]+ ]+++-- | Test Circle primitives+testCircle :: IO [TestResult]+testCircle = do+ putStrLn "\n=== Testing Circle Primitives ==="++ sequence+ [ runTest "Simple circle" $ do+ let pic = Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<circle", "r=\"50\"", "fill=\"none\"", "stroke="]+ , runTest "Circle with different radius" $ do+ let pic = Circle 100+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "r=\"100\""+ , runTest "ThickCircle" $ do+ let pic = ThickCircle 10 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<circle"+ , runTest "ThickCircle zero thickness" $ do+ let pic = ThickCircle 0 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<circle"+ , runTest "Circle with color" $ do+ let pic = Color red $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "stroke=\"rgb(255,0,0)\""+ , runTest "circleSolid" $ do+ let pic = circleSolid 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<circle"+ , runTest "Multiple concentric circles" $ do+ let pic = Pictures [Circle 25, Circle 50, Circle 75, Circle 100]+ let svg = pictureToSVGDoc testSize white pic+ -- Should have multiple circles+ assertBool "Should have multiple circles" (T.count "<circle" svg >= 4)+ ]+++-- | Test Arc primitives+testArc :: IO [TestResult]+testArc = do+ putStrLn "\n=== Testing Arc Primitives ==="++ sequence+ [ runTest "Simple arc" $ do+ let pic = Arc 0 90 50+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<path", "d=\"M", "A 50 50"]+ , runTest "Arc 180 degrees" $ do+ let pic = Arc 0 180 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<path"+ , runTest "Arc full circle" $ do+ let pic = Arc 0 360 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<path"+ , runTest "ThickArc" $ do+ let pic = ThickArc 0 90 5 50+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<path", "stroke-width"]+ , runTest "Arc with color" $ do+ let pic = Color cyan $ Arc 45 135 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "stroke=\"rgb(0,255,255)\""+ , runTest "arcSolid" $ do+ let pic = arcSolid 0 90 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<path"+ , runTest "sectorWire" $ do+ let pic = sectorWire 0 90 50+ let svg = pictureToSVGDoc testSize white pic+ -- sectorWire produces arc + two lines+ assertBool+ "Should have arc elements"+ (T.isInfixOf "<path" svg || T.isInfixOf "<polyline" svg)+ ]+++-- | Test Text primitives+testText :: IO [TestResult]+testText = do+ putStrLn "\n=== Testing Text Primitives ==="++ sequence+ [ runTest "Simple text" $ do+ let pic = Text "Hello World"+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<text", ">Hello World</text>"]+ , runTest "Text with special characters (XML escape)" $ do+ let pic = Text "A < B & C > D"+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<", "&", ">"]+ , runTest "Text with quotes" $ do+ let pic = Text "Say \"Hello\""+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg """+ , runTest "ThickText" $ do+ let pic = ThickText "Bold" 3.0+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<text", "stroke-width"]+ , runTest "Text with color" $ do+ let pic = Color magenta $ Text "Colored"+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "fill=\"rgb(255,0,255)\""+ , runTest "Empty text" $ do+ let pic = Text ""+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<text"+ , runTest "Unicode text" $ do+ let pic = Text "Hello \x4e16\x754c" -- "Hello 世界"+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<text"+ ]+++-- | Test Transform primitives+testTransforms :: IO [TestResult]+testTransforms = do+ putStrLn "\n=== Testing Transform Primitives ==="++ sequence+ [ runTest "Translate" $ do+ let pic = Translate 100 50 $ Circle 25+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<g transform=\"translate(", ")\"", "<circle"]+ , runTest "Rotate" $ do+ let pic = Rotate 45 $ rectangleSolid 50 100+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<g transform=\"rotate(", ")\""]+ , runTest "Scale" $ do+ let pic = Scale 2 0.5 $ Circle 25+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<g transform=\"scale(", ")\""]+ , runTest "Uniform scale" $ do+ let pic = Scale 2 2 $ Circle 25+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "scale(2,2)"+ , runTest "Negative scale (mirror)" $ do+ let pic = Scale (-1) 1 $ Circle 25+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "scale(-1,1)"+ , runTest "Combined transforms" $ do+ let pic = Translate 100 100 $ Rotate 45 $ Scale 2 2 $ Circle 25+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["translate(", "rotate(", "scale("]+ , runTest "Nested transforms" $ do+ let pic =+ Translate 50 50 $+ Rotate 30 $+ Translate 25 0 $+ Circle 10+ let svg = pictureToSVGDoc testSize white pic+ -- Should have multiple transform groups+ assertBool "Should have nested transforms" (T.count "<g transform" svg >= 2)+ ]+++-- | Test Color primitive+testColor :: IO [TestResult]+testColor = do+ putStrLn "\n=== Testing Color Primitive ==="++ sequence+ [ runTest "Color red" $ do+ let pic = Color red $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(255,0,0)"+ , runTest "Color green" $ do+ let pic = Color green $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(0,255,0)"+ , runTest "Color blue" $ do+ let pic = Color blue $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(0,0,255)"+ , runTest "Color yellow" $ do+ let pic = Color yellow $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(255,255,0)"+ , runTest "Color cyan" $ do+ let pic = Color cyan $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(0,255,255)"+ , runTest "Color magenta" $ do+ let pic = Color magenta $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(255,0,255)"+ , runTest "Color with transparency" $ do+ let pic = Color (makeColor 1 0 0 0.5) $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["rgba(255,0,0,0.500)", "opacity"]+ , runTest "makeColorI" $ do+ let pic = Color (makeColorI 128 64 192 255) $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgb(128,64,192)"+ , runTest "Nested colors (inner overrides)" $ do+ let pic = Color red $ Color blue $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ -- The inner color (blue) should be applied to the circle+ assertContains svg "rgb(0,0,255)"+ , runTest "Full transparency" $ do+ let pic = Color (makeColor 1 0 0 0) $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rgba(255,0,0,0.000)"+ ]+++-- | Test Pictures (composite) primitive+testPictures :: IO [TestResult]+testPictures = do+ putStrLn "\n=== Testing Pictures Composite ==="++ sequence+ [ runTest "Empty pictures" $ do+ let pic = Pictures []+ let svg = pictureToSVGDoc testSize white pic+ pure $ not (T.isInfixOf "<polygon" svg || T.isInfixOf "<circle" svg)+ , runTest "Single picture" $ do+ let pic = Pictures [Circle 50]+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<circle"+ , runTest "Multiple pictures" $ do+ let pic =+ Pictures+ [ Circle 50+ , Translate 100 0 $ Circle 25+ , Polygon [(0, 0), (50, 0), (25, 50)]+ ]+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["<circle", "<polygon"]+ , runTest "Nested pictures" $ do+ let pic =+ Pictures+ [ Pictures [Circle 25, Circle 50]+ , Pictures [Circle 75, Circle 100]+ ]+ let svg = pictureToSVGDoc testSize white pic+ assertBool "Should have multiple circles" (T.count "<circle" svg >= 4)+ , runTest "Pictures with different colors" $ do+ let pic =+ Pictures+ [ Color red $ Circle 50+ , Color blue $ Translate 100 0 $ Circle 50+ , Color green $ Translate (-100) 0 $ Circle 50+ ]+ let svg = pictureToSVGDoc testSize white pic+ assertContainsAll svg ["rgb(255,0,0)", "rgb(0,0,255)", "rgb(0,255,0)"]+ , runTest "Large pictures list" $ do+ let pic =+ Pictures [Translate (fromIntegral i * 10) 0 $ Circle 5 | i <- [0 :: Int .. 20]]+ let svg = pictureToSVGDoc testSize white pic+ assertBool "Should have many circles" (T.count "<circle" svg >= 20)+ ]+++-- | Test rectangle helper functions+testRectangles :: IO [TestResult]+testRectangles = do+ putStrLn "\n=== Testing Rectangle Helpers ==="++ sequence+ [ runTest "rectangleSolid" $ do+ let pic = rectangleSolid 100 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polygon"+ , runTest "rectangleWire" $ do+ let pic = rectangleWire 100 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polyline"+ , runTest "rectangleUpperSolid" $ do+ let pic = rectangleUpperSolid 100 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polygon"+ , runTest "rectangleUpperWire" $ do+ let pic = rectangleUpperWire 100 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polyline"+ , runTest "lineLoop (closed rectangle)" $ do+ let pic = lineLoop $ rectanglePath 100 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polyline"+ ]+++-- | Test line loops+testLineLoop :: IO [TestResult]+testLineLoop = do+ putStrLn "\n=== Testing Line Loops ==="++ sequence+ [ runTest "Simple lineLoop" $ do+ let pic = lineLoop [(0, 0), (100, 0), (100, 100), (0, 100)]+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<polyline"+ , runTest "Empty lineLoop" $ do+ let pic = lineLoop []+ let svg = pictureToSVGDoc testSize white pic+ pure $ not (T.isInfixOf "<polyline" svg) || T.isInfixOf "points=\"\"" svg+ , runTest "Triangle lineLoop" $ do+ let pic = lineLoop [(0, 0), (100, 0), (50, 100)]+ let svg = pictureToSVGDoc testSize white pic+ -- The loop should close back to the first point+ assertContains svg "<polyline"+ ]+++-- | Test edge cases and special values+testEdgeCases :: IO [TestResult]+testEdgeCases = do+ putStrLn "\n=== Testing Edge Cases ==="++ sequence+ [ runTest "Zero radius circle" $ do+ let pic = Circle 0+ let svg = pictureToSVGDoc testSize white pic+ -- Should still produce valid SVG+ assertContains svg "r=\"0\""+ , runTest "Negative radius circle" $ do+ let pic = Circle (-50)+ let svg = pictureToSVGDoc testSize white pic+ -- Should use absolute value+ assertContains svg "r=\"50\""+ , runTest "Very small values" $ do+ let pic = Circle 0.001+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "<circle"+ , runTest "Very large values" $ do+ let pic = Circle 10000+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "r=\"10000\""+ , runTest "Zero scale" $ do+ let pic = Scale 0 0 $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "scale(0,0)"+ , runTest "Very small scale" $ do+ let pic = Scale 0.001 0.001 $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "scale("+ , runTest "Large rotation" $ do+ let pic = Rotate 720 $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rotate("+ , runTest "Negative rotation" $ do+ let pic = Rotate (-45) $ Circle 50+ let svg = pictureToSVGDoc testSize white pic+ assertContains svg "rotate("+ ]+++-- | Test file export functionality+testFileExport :: IO [TestResult]+testFileExport = do+ putStrLn "\n=== Testing File Export ==="+ outputDir <- getTestOutputDir++ sequence+ [ runTest "Export single picture to file" $ do+ let pic = Pictures [Circle 50, Color red $ rectangleSolid 30 30]+ let filePath = outputDir </> "test_single.svg"+ exportPictureToSVG testSize white filePath pic+ exists <- doesFileExist filePath+ if exists+ then do+ content <- TIO.readFile filePath+ assertContainsAll content ["<?xml", "<svg", "<circle", "<polygon", "</svg>"]+ else pure False+ , runTest "Export animation to files" $ do+ let animation t = Circle (25 + t)+ let filePath = outputDir </> "test_anim%d.svg"+ exportPicturesToSVG testSize white filePath animation [10, 20, 30]+ -- Check that all frames exist+ exists1 <- doesFileExist $ outputDir </> "test_anim1.svg"+ exists2 <- doesFileExist $ outputDir </> "test_anim2.svg"+ exists3 <- doesFileExist $ outputDir </> "test_anim3.svg"+ pure $ exists1 && exists2 && exists3+ , runTest "Export with different sizes" $ do+ let pic = Circle 50+ let filePath1 = outputDir </> "test_size1.svg"+ let filePath2 = outputDir </> "test_size2.svg"+ exportPictureToSVG (100, 100) white filePath1 pic+ exportPictureToSVG (800, 600) white filePath2 pic+ content1 <- TIO.readFile filePath1+ content2 <- TIO.readFile filePath2+ result1 <- assertContains content1 "width=\"100\""+ result2 <- assertContains content2 "width=\"800\""+ pure $ result1 && result2+ ]+++-- | Test comprehensive scene+testComprehensiveScene :: IO [TestResult]+testComprehensiveScene = do+ putStrLn "\n=== Testing Comprehensive Scene ==="+ outputDir <- getTestOutputDir++ sequence+ [ runTest "Complex scene with all primitives" $ do+ let scene =+ Pictures+ [ -- Background shapes+ Color (makeColor 0.9 0.9 1 1) $ rectangleSolid 380 380+ , -- Circles+ Translate (-100) 100 $ Color red $ circleSolid 40+ , Translate 0 100 $ Color blue $ Circle 40+ , Translate 100 100 $ Color green $ ThickCircle 10 40+ , -- Polygons+ Translate (-100) 0 $ Color yellow $ Polygon [(0, 0), (40, 0), (20, 40)]+ , Translate 0 0 $ Color cyan $ rectangleSolid 60 40+ , Translate 100 0 $ Color magenta $ rectangleWire 60 40+ , -- Lines+ Translate (-100) (-100) $ Color orange $ Line [(0, 0), (40, 40)]+ , Translate 0 (-100) $ Color rose $ ThickLine [(0, 0), (40, 40)] 5+ , -- Arcs+ Translate 100 (-100) $ Color violet $ Arc 0 180 30+ , -- Text+ Translate 0 (-150) $ Color black $ Scale 0.5 0.5 $ Text "Hello SVG!"+ , -- Transformed shapes+ Translate 0 150 $+ Rotate 45 $+ Scale 0.5 0.5 $+ Color azure $+ rectangleSolid 80 80+ ]+ let filePath = outputDir </> "comprehensive_test.svg"+ exportPictureToSVG (400, 400) white filePath scene+ content <- TIO.readFile filePath+ assertContainsAll+ content+ [ "<svg"+ , "<circle"+ , "<polygon"+ , "<polyline"+ , "<path"+ , "<text"+ , "translate("+ , "rotate("+ , "scale("+ , "</svg>"+ ]+ , runTest "Deep nesting" $ do+ let deepNest =+ Translate 0 0 $+ Rotate 15 $+ Scale 0.9 0.9 $+ Translate 10 0 $+ Rotate 15 $+ Scale 0.9 0.9 $+ Translate 10 0 $+ Rotate 15 $+ Scale 0.9 0.9 $+ Circle 50+ let svg = pictureToSVGDoc testSize white deepNest+ assertContainsAll svg ["translate(", "rotate(", "scale(", "<circle"]+ ]+++-- | Test color variations+testColorVariations :: IO [TestResult]+testColorVariations = do+ putStrLn "\n=== Testing Color Variations ==="++ sequence+ [ runTest "Predefined colors" $ do+ let colors :: [(String, Color)]+ colors =+ [ ("red", red)+ , ("green", green)+ , ("blue", blue)+ , ("yellow", yellow)+ , ("cyan", cyan)+ , ("magenta", magenta)+ , ("black", black)+ , ("white", white)+ , ("orange", orange)+ , ("rose", rose)+ , ("violet", violet)+ , ("azure", azure)+ , ("aquamarine", aquamarine)+ , ("chartreuse", chartreuse)+ ]+ let pics =+ [ Color c $ Translate (fromIntegral i * 50 - 300) 0 $ Circle 20+ | (i, (_, c)) <- zip [0 :: Int ..] colors+ ]+ let svg = pictureToSVGDoc (800, 200) white $ Pictures pics+ assertBool "Should have many circles with colors" (T.count "<circle" svg >= 10)+ , runTest "Gradient-like colors" $ do+ let pics =+ [ Color (makeColor (i / 10) 0 (1 - i / 10) 1) $+ Translate (i * 40 - 200) 0 $+ Circle 15+ | i <- [0, 1 .. 10]+ ]+ let svg = pictureToSVGDoc (500, 100) white $ Pictures pics+ assertBool "Should have gradient colors" (T.count "<circle" svg >= 10)+ , runTest "Alpha gradient" $ do+ let pics =+ [ Color (makeColor 1 0 0 (i / 10)) $+ Translate (i * 40 - 200) 0 $+ circleSolid 30+ | i <- [1 .. 10]+ ]+ let svg = pictureToSVGDoc (500, 100) white $ Pictures pics+ assertContains svg "opacity"+ ]+++-- | Main test runner+main :: IO ()+main = do+ putStrLn "=========================================="+ putStrLn " Brillo SVG Export - Comprehensive Tests"+ putStrLn "=========================================="++ -- Run all test categories+ results <-+ concat+ <$> sequence+ [ testDocumentStructure+ , testBlank+ , testPolygon+ , testLine+ , testCircle+ , testArc+ , testText+ , testTransforms+ , testColor+ , testPictures+ , testRectangles+ , testLineLoop+ , testEdgeCases+ , testFileExport+ , testComprehensiveScene+ , testColorVariations+ ]++ -- Summary+ let passes = length $ filter isPass results+ let total = length results++ putStrLn "\n=========================================="+ putStrLn $ printf " Results: %d / %d tests passed" passes total+ putStrLn "=========================================="++ -- Print failures+ let failures = [name | TestFail name _ <- results]+ unless (null failures) $ do+ putStrLn "\nFailed tests:"+ forM_ failures $ \name -> putStrLn $ " - " ++ name++ -- Exit with appropriate code+ if passes == total+ then do+ putStrLn "\nAll tests passed!"+ exitSuccess+ else do+ putStrLn $ "\n" ++ show (total - passes) ++ " test(s) failed."+ exitFailure
+ test/WebPTest.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++{-| Comprehensive test suite for WebP export functionality.++This module tests all WebP export features including lossless and lossy+compression, single pictures, and animations.+-}+module Main where++import Brillo.Data.Color+import Brillo.Data.Picture+import Brillo.Export.WebP+import Control.Monad (forM_, unless, when)+import Data.ByteString qualified as BS+import Data.Text (pack)+import Graphics.UI.GLFW qualified as GLFW+import System.Directory (+ createDirectoryIfMissing,+ doesFileExist,+ getTemporaryDirectory,+ removeFile,+ )+import System.FilePath ((</>))+import Text.Printf (printf)+++-- | Test result type+data TestResult+ = TestPass String+ | TestFail String String+ deriving (Show)+++isPass :: TestResult -> Bool+isPass (TestPass _) = True+isPass _ = False+++-- | Run a test and return the result+runTest :: String -> IO Bool -> IO TestResult+runTest name action = do+ putStr $ " Testing " ++ name ++ "... "+ result <- action+ if result+ then do+ putStrLn "PASS"+ pure $ TestPass name+ else do+ putStrLn "FAIL"+ pure $ TestFail name "Assertion failed"+++-- | Assert that a condition is true+assertBool :: String -> Bool -> IO Bool+assertBool _ True = pure True+assertBool msg False = do+ putStrLn $ "\n ERROR: " ++ msg+ pure False+++-- | Standard test size+testSize :: (Int, Int)+testSize = (200, 200)+++-- | Output directory for test WebPs+getTestOutputDir :: IO FilePath+getTestOutputDir = do+ tmpDir <- getTemporaryDirectory+ let outputDir = tmpDir </> "brillo-webp-test"+ createDirectoryIfMissing True outputDir+ pure outputDir+++{-| Check if GLFW can initialize and create a window (i.e., we have a display+available). On Windows, GLFW.init can succeed even without a display, so we+also try creating a hidden window to verify.+-}+canInitializeGLFW :: IO Bool+canInitializeGLFW = do+ result <- GLFW.init+ if not result+ then pure False+ else do+ GLFW.windowHint (GLFW.WindowHint'Visible False)+ maybeWindow <- GLFW.createWindow 1 1 "" Nothing Nothing+ case maybeWindow of+ Nothing -> do+ GLFW.terminate+ pure False+ Just window -> do+ GLFW.destroyWindow window+ GLFW.terminate+ pure True+++-- | Clean up a test file if it exists+cleanupFile :: FilePath -> IO ()+cleanupFile path = do+ exists <- doesFileExist path+ when exists $ removeFile path+++-- ============================================================================+-- Test Categories+-- ============================================================================++-- | Test lossless WebP export of single pictures+testLosslessSinglePicture :: FilePath -> IO [TestResult]+testLosslessSinglePicture outputDir = do+ putStrLn "\n=== Testing Lossless Single Picture Export ==="++ sequence+ [ runTest "Export simple circle" $ do+ let pic = Circle 50+ let filePath = outputDir </> "lossless_circle.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ exists <- doesFileExist filePath+ if exists+ then do+ content <- BS.readFile filePath+ -- WebP files start with "RIFF" followed by file size and "WEBP"+ let isWebP = BS.take 4 content == "RIFF" && BS.take 4 (BS.drop 8 content) == "WEBP"+ assertBool "File should be a valid WebP" isWebP+ else assertBool "File should exist" False+ , runTest "Export filled polygon" $ do+ let pic = Color red $ Polygon [(0, 0), (100, 0), (50, 100)]+ let filePath = outputDir </> "lossless_polygon.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export complex scene" $ do+ let pic =+ Pictures+ [ Color blue $ circleSolid 40+ , Translate 50 50 $ Color green $ rectangleSolid 30 30+ , Translate (-50) (-50) $ Color red $ Circle 25+ ]+ let filePath = outputDir </> "lossless_complex.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export with transparent background" $ do+ let pic = Circle 50+ let bgColor = makeColor 0 0 0 0 -- Fully transparent+ let filePath = outputDir </> "lossless_transparent_bg.webp"+ cleanupFile filePath+ exportPictureToWebP testSize bgColor filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export with colored background" $ do+ let pic = Color white $ circleSolid 50+ let filePath = outputDir </> "lossless_colored_bg.webp"+ cleanupFile filePath+ exportPictureToWebP testSize blue filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export text" $ do+ let pic = Scale 0.5 0.5 $ Text (pack "Hello WebP!")+ let filePath = outputDir </> "lossless_text.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export with transforms" $ do+ let pic = Translate 50 0 $ Rotate 45 $ Scale 0.8 0.8 $ rectangleSolid 60 60+ let filePath = outputDir </> "lossless_transforms.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export blank picture" $ do+ let pic = Blank+ let filePath = outputDir </> "lossless_blank.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ ]+++-- | Test lossy WebP export of single pictures+testLossySinglePicture :: FilePath -> IO [TestResult]+testLossySinglePicture outputDir = do+ putStrLn "\n=== Testing Lossy Single Picture Export ==="++ sequence+ [ runTest "Export with quality 100" $ do+ let pic = Circle 50+ let filePath = outputDir </> "lossy_q100.webp"+ cleanupFile filePath+ exportPictureToWebPLossy 100 testSize white filePath pic+ exists <- doesFileExist filePath+ if exists+ then do+ content <- BS.readFile filePath+ let isWebP = BS.take 4 content == "RIFF" && BS.take 4 (BS.drop 8 content) == "WEBP"+ assertBool "File should be a valid WebP" isWebP+ else assertBool "File should exist" False+ , runTest "Export with quality 75" $ do+ let pic = Color red $ circleSolid 50+ let filePath = outputDir </> "lossy_q75.webp"+ cleanupFile filePath+ exportPictureToWebPLossy 75 testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export with quality 50" $ do+ let pic = Color blue $ rectangleSolid 80 60+ let filePath = outputDir </> "lossy_q50.webp"+ cleanupFile filePath+ exportPictureToWebPLossy 50 testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export with quality 25" $ do+ let pic = Color green $ Polygon [(0, 0), (60, 0), (30, 80)]+ let filePath = outputDir </> "lossy_q25.webp"+ cleanupFile filePath+ exportPictureToWebPLossy 25 testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export with quality 0" $ do+ let pic = Circle 50+ let filePath = outputDir </> "lossy_q0.webp"+ cleanupFile filePath+ exportPictureToWebPLossy 0 testSize white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Lossy file smaller than lossless (complex image)" $ do+ -- Create a complex picture that should compress well with lossy+ let pic =+ Pictures+ [ Color (makeColor 0.8 0.2 0.3 1) $ circleSolid 80+ , Color (makeColor 0.2 0.8 0.3 1) $ Translate 30 30 $ circleSolid 40+ , Color (makeColor 0.3 0.2 0.8 1) $ Translate (-30) (-30) $ rectangleSolid 50 50+ ]+ let losslessPath = outputDir </> "compare_lossless.webp"+ let lossyPath = outputDir </> "compare_lossy.webp"+ cleanupFile losslessPath+ cleanupFile lossyPath+ exportPictureToWebP testSize white losslessPath pic+ exportPictureToWebPLossy 50 testSize white lossyPath pic+ losslessSize <- BS.length <$> BS.readFile losslessPath+ lossySize <- BS.length <$> BS.readFile lossyPath+ -- Note: Lossy is typically smaller, but not guaranteed for all images+ -- Just verify both files were created with reasonable sizes+ assertBool "Both files should have content" (losslessSize > 0 && lossySize > 0)+ ]+++-- | Test lossless WebP export of animations (multiple pictures)+testLosslessAnimation :: FilePath -> IO [TestResult]+testLosslessAnimation outputDir = do+ putStrLn "\n=== Testing Lossless Animation Export ==="++ sequence+ [ runTest "Export animation frames" $ do+ let animation t = Circle (20 + t)+ let filePattern = outputDir </> "lossless_anim%d.webp"+ let timePoints = [10, 20, 30, 40, 50]+ -- Clean up any existing files+ forM_ [1 .. 5] $ \i -> cleanupFile (outputDir </> printf "lossless_anim%d.webp" (i :: Int))+ exportPicturesToWebP testSize white filePattern animation timePoints+ -- Verify all frames exist+ allExist <-+ mapM+ (\i -> doesFileExist (outputDir </> printf "lossless_anim%d.webp" (i :: Int)))+ [1 .. 5]+ assertBool "All 5 animation frames should exist" (and allExist)+ , runTest "Export rotating square animation" $ do+ let animation t = Rotate t $ rectangleSolid 50 50+ let filePattern = outputDir </> "lossless_rotate%d.webp"+ let timePoints = [0, 45, 90, 135, 180]+ forM_ [1 .. 5] $ \i -> cleanupFile (outputDir </> printf "lossless_rotate%d.webp" (i :: Int))+ exportPicturesToWebP testSize white filePattern animation timePoints+ allExist <-+ mapM+ (\i -> doesFileExist (outputDir </> printf "lossless_rotate%d.webp" (i :: Int)))+ [1 .. 5]+ assertBool "All 5 rotation frames should exist" (and allExist)+ , runTest "Export color changing animation" $ do+ let animation t =+ let r = t / 100+ g = 1 - (t / 100)+ in Color (makeColor r g 0.5 1) $ circleSolid 60+ let filePattern = outputDir </> "lossless_color%d.webp"+ let timePoints = [0, 25, 50, 75, 100]+ forM_ [1 .. 5] $ \i -> cleanupFile (outputDir </> printf "lossless_color%d.webp" (i :: Int))+ exportPicturesToWebP testSize white filePattern animation timePoints+ allExist <-+ mapM+ (\i -> doesFileExist (outputDir </> printf "lossless_color%d.webp" (i :: Int)))+ [1 .. 5]+ assertBool "All 5 color frames should exist" (and allExist)+ , runTest "Export single frame animation" $ do+ let animation _ = Circle 50+ let filePattern = outputDir </> "lossless_single%d.webp"+ cleanupFile (outputDir </> "lossless_single1.webp")+ exportPicturesToWebP testSize white filePattern animation [0]+ exists <- doesFileExist (outputDir </> "lossless_single1.webp")+ assertBool "Single frame should exist" exists+ ]+++-- | Test lossy WebP export of animations (multiple pictures)+testLossyAnimation :: FilePath -> IO [TestResult]+testLossyAnimation outputDir = do+ putStrLn "\n=== Testing Lossy Animation Export ==="++ sequence+ [ runTest "Export lossy animation frames" $ do+ let animation t = Circle (20 + t)+ let filePattern = outputDir </> "lossy_anim%d.webp"+ let timePoints = [10, 20, 30]+ forM_ [1 .. 3] $ \i -> cleanupFile (outputDir </> printf "lossy_anim%d.webp" (i :: Int))+ exportPicturesToWebPLossy 75 testSize white filePattern animation timePoints+ allExist <-+ mapM+ (\i -> doesFileExist (outputDir </> printf "lossy_anim%d.webp" (i :: Int)))+ [1 .. 3]+ assertBool "All 3 animation frames should exist" (and allExist)+ , runTest "Export lossy animation with different qualities" $ do+ let animation t = Color blue $ circleSolid t+ -- Export same animation at different qualities+ let filePatternHQ = outputDir </> "lossy_hq%d.webp"+ let filePatternLQ = outputDir </> "lossy_lq%d.webp"+ let timePoints = [30, 40, 50]+ forM_ [1 .. 3] $ \i -> do+ cleanupFile (outputDir </> printf "lossy_hq%d.webp" (i :: Int))+ cleanupFile (outputDir </> printf "lossy_lq%d.webp" (i :: Int))+ exportPicturesToWebPLossy 90 testSize white filePatternHQ animation timePoints+ exportPicturesToWebPLossy 30 testSize white filePatternLQ animation timePoints+ hqExist <-+ mapM+ (\i -> doesFileExist (outputDir </> printf "lossy_hq%d.webp" (i :: Int)))+ [1 .. 3]+ lqExist <-+ mapM+ (\i -> doesFileExist (outputDir </> printf "lossy_lq%d.webp" (i :: Int)))+ [1 .. 3]+ assertBool "All HQ and LQ frames should exist" (and hqExist && and lqExist)+ ]+++-- | Test different image sizes+testDifferentSizes :: FilePath -> IO [TestResult]+testDifferentSizes outputDir = do+ putStrLn "\n=== Testing Different Image Sizes ==="++ sequence+ [ runTest "Export tiny image (50x50)" $ do+ let pic = Circle 20+ let filePath = outputDir </> "size_50x50.webp"+ cleanupFile filePath+ exportPictureToWebP (50, 50) white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export small image (100x100)" $ do+ let pic = Circle 40+ let filePath = outputDir </> "size_100x100.webp"+ cleanupFile filePath+ exportPictureToWebP (100, 100) white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export medium image (400x400)" $ do+ let pic = Circle 150+ let filePath = outputDir </> "size_400x400.webp"+ cleanupFile filePath+ exportPictureToWebP (400, 400) white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export non-square image (300x200)" $ do+ let pic = rectangleSolid 200 100+ let filePath = outputDir </> "size_300x200.webp"+ cleanupFile filePath+ exportPictureToWebP (300, 200) white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export tall image (100x400)" $ do+ let pic = rectangleSolid 50 300+ let filePath = outputDir </> "size_100x400.webp"+ cleanupFile filePath+ exportPictureToWebP (100, 400) white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ , runTest "Export wide image (400x100)" $ do+ let pic = rectangleSolid 300 50+ let filePath = outputDir </> "size_400x100.webp"+ cleanupFile filePath+ exportPictureToWebP (400, 100) white filePath pic+ exists <- doesFileExist filePath+ assertBool "File should exist" exists+ ]+++-- | Test various picture types+testPictureTypes :: FilePath -> IO [TestResult]+testPictureTypes outputDir = do+ putStrLn "\n=== Testing Various Picture Types ==="++ sequence+ [ runTest "Arc" $ do+ let pic = Arc 0 180 50+ let filePath = outputDir </> "pic_arc.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ , runTest "ThickArc" $ do+ let pic = ThickArc 45 270 10 50+ let filePath = outputDir </> "pic_thickarc.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ , runTest "ThickCircle" $ do+ let pic = ThickCircle 15 50+ let filePath = outputDir </> "pic_thickcircle.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ , runTest "Line" $ do+ let pic = Line [(-80, -80), (80, 80)]+ let filePath = outputDir </> "pic_line.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ , runTest "ThickLine" $ do+ let pic = ThickLine [(-80, 80), (0, -80), (80, 80)] 5+ let filePath = outputDir </> "pic_thickline.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ , runTest "LineAliased" $ do+ let pic = LineAliased [(-80, 0), (-40, 60), (40, -60), (80, 0)]+ let filePath = outputDir </> "pic_linesmooth.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ , runTest "Pictures (nested)" $ do+ let pic =+ Pictures+ [ Pictures [Circle 30, Circle 50]+ , Translate 40 40 $ Pictures [Circle 20, Circle 30]+ ]+ let filePath = outputDir </> "pic_nested.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ doesFileExist filePath+ ]+++-- | Test WebP file validity+testFileValidity :: FilePath -> IO [TestResult]+testFileValidity outputDir = do+ putStrLn "\n=== Testing WebP File Validity ==="++ sequence+ [ runTest "Lossless WebP has valid header" $ do+ let pic = circleSolid 50+ let filePath = outputDir </> "valid_lossless.webp"+ cleanupFile filePath+ exportPictureToWebP testSize white filePath pic+ content <- BS.readFile filePath+ -- WebP format: RIFF....WEBP+ let riff = BS.take 4 content+ let webp = BS.take 4 (BS.drop 8 content)+ assertBool "Should have RIFF header" (riff == "RIFF") >>= \r1 ->+ if r1+ then assertBool "Should have WEBP marker" (webp == "WEBP")+ else pure False+ , runTest "Lossy WebP has valid header" $ do+ let pic = circleSolid 50+ let filePath = outputDir </> "valid_lossy.webp"+ cleanupFile filePath+ exportPictureToWebPLossy 75 testSize white filePath pic+ content <- BS.readFile filePath+ let riff = BS.take 4 content+ let webp = BS.take 4 (BS.drop 8 content)+ assertBool "Should have RIFF header" (riff == "RIFF") >>= \r1 ->+ if r1+ then assertBool "Should have WEBP marker" (webp == "WEBP")+ else pure False+ , runTest "File size is reasonable" $ do+ let pic = circleSolid 50+ let filePath = outputDir </> "size_check.webp"+ cleanupFile filePath+ exportPictureToWebP (100, 100) white filePath pic+ content <- BS.readFile filePath+ let size = BS.length content+ -- WebP file should be at least 100 bytes but less than 100KB for a simple 100x100 image+ assertBool+ ("File size should be reasonable (got " ++ show size ++ " bytes)")+ (size >= 100 && size < 100000)+ ]+++-- | Main test runner+main :: IO ()+main = do+ putStrLn "=========================================="+ putStrLn " Brillo WebP Export - Comprehensive Tests"+ putStrLn "=========================================="++ -- Check if we can initialize GLFW (requires a display)+ hasDisplay <- canInitializeGLFW+ unless hasDisplay $ do+ putStrLn+ "\nSkipping brillo-webp tests: no display available (GLFW cannot initialize)"+ putStrLn "This is expected in headless CI environments."++ when hasDisplay $ do+ outputDir <- getTestOutputDir+ putStrLn $ "Output directory: " ++ outputDir++ -- Run all test categories+ results <-+ concat+ <$> sequence+ [ testLosslessSinglePicture outputDir+ , testLossySinglePicture outputDir+ , testLosslessAnimation outputDir+ , testLossyAnimation outputDir+ , testDifferentSizes outputDir+ , testPictureTypes outputDir+ , testFileValidity outputDir+ ]++ -- Summary+ let passes = length $ filter isPass results+ let total = length results++ putStrLn "\n=========================================="+ putStrLn $ printf " Results: %d / %d tests passed" passes total+ putStrLn "=========================================="++ -- Print failures+ let failures = [name | TestFail name _ <- results]+ unless (null failures) $ do+ putStrLn "\nFailed tests:"+ forM_ failures $ \name -> putStrLn $ " - " ++ name++ -- Exit with appropriate code+ if passes == total+ then putStrLn "\nAll tests passed!"+ else error $ show (total - passes) ++ " test(s) failed."
+ test/expected_bmp.png view
binary file changed (absent → 17697 bytes)
+ test/expected_circle.png view
binary file changed (absent → 8518 bytes)
+ test/expected_circles.png view
binary file changed (absent → 15401 bytes)
+ test/expected_comprehensive.png view
binary file changed (absent → 10848 bytes)
+ test/expected_growing_polgons.gif view
binary file changed (absent → 23125 bytes)
+ test/expected_growing_polgons1.png view
binary file changed (absent → 8476 bytes)
+ test/expected_growing_polgons2.png view
binary file changed (absent → 9221 bytes)
+ test/expected_growing_polgons3.png view
binary file changed (absent → 9484 bytes)
+ test/expected_growing_polgons4.png view
binary file changed (absent → 9872 bytes)
+ test/expected_growing_polgons5.png view
binary file changed (absent → 10014 bytes)
+ test/expected_growing_polgons6.png view
binary file changed (absent → 9654 bytes)
+ test/expected_growing_polgons7.png view
binary file changed (absent → 5959 bytes)
+ test/expected_large_image.png view
binary file changed (absent → 14232 bytes)
+ test/expected_p10.png view
binary file changed (absent → 74 bytes)
+ test/expected_p100.png view
binary file changed (absent → 327 bytes)
+ test/expected_p20.png view
binary file changed (absent → 90 bytes)
+ test/expected_p40.png view
binary file changed (absent → 131 bytes)
+ test/expected_p60.png view
binary file changed (absent → 167 bytes)
+ test/loadme.bmp view
binary file changed (absent → 172254 bytes)