diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,22 @@ +1.1 (8 March 2014) +------------------ + +* **New features** + + - It is now possible to directly output animated GIFs, using the + `gifMain` function. + +* **Dependency/version changes** + + - allow `diagrams-core-1.1` and `diagrams-lib-1.1` + - allow `unix-2.7` + - allow `vector-0.10` + +* **Bug fixes** + + - Don't explicitly draw final segment of a loop if it is straight + ([#38](https://github.com/diagrams/diagrams-cairo/issues/38)) + 1.0.1.2 (6 February 2014) ------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -9,6 +9,7 @@ Michael Sloan Luite Stegeman Kanchalai Suveepattananont + Robert Vollmert Ryan Yates Brent Yorgey diff --git a/diagrams-cairo.cabal b/diagrams-cairo.cabal --- a/diagrams-cairo.cabal +++ b/diagrams-cairo.cabal @@ -1,5 +1,5 @@ Name: diagrams-cairo -Version: 1.0.1.2 +Version: 1.1 Synopsis: Cairo backend for diagrams drawing EDSL Description: A full-featured backend for rendering diagrams using the cairo rendering engine. @@ -35,7 +35,7 @@ Build-type: Simple Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown -Tested-with: GHC == 7.4.2, GHC == 7.6.1 +Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-cairo.git @@ -55,20 +55,25 @@ filepath, old-time, time, - diagrams-core >= 1.0 && < 1.1, - diagrams-lib >= 1.0.1 && < 1.1, + diagrams-core >= 1.0 && < 1.2, + diagrams-lib >= 1.0.1 && < 1.2, cairo >= 0.12.4 && < 0.13, colour, split >= 0.1.2 && < 0.3, containers >= 0.3 && < 0.6, - lens >= 3.8 && < 4, + lens >= 3.8 && < 4.1, data-default-class >= 0.0.1 && < 0.1, statestack >= 0.2 && < 0.3, + JuicyPixels >= 3.1.3.2 && < 3.2, + vector >= 0.10.0 && < 0.11, + bytestring >= 0.9 && < 0.11, + optparse-applicative >= 0.7 && < 0.8, hashable >= 1.1 && < 1.3 if impl(ghc < 7.6) Build-depends: ghc-prim + default-language: Haskell2010 if !os(windows) cpp-options: -DCMDLINELOOP - Build-depends: unix >= 2.4 && < 2.7 + Build-depends: unix >= 2.4 && < 2.8 diff --git a/src/Diagrams/Backend/Cairo/CmdLine.hs b/src/Diagrams/Backend/Cairo/CmdLine.hs --- a/src/Diagrams/Backend/Cairo/CmdLine.hs +++ b/src/Diagrams/Backend/Cairo/CmdLine.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -23,9 +24,11 @@ -- * 'animMain' is like 'defaultMain' but for animations instead of -- diagrams. -- +-- * `gifMain` creates an executable to generate an animated GIF. +-- -- * 'mainWith' is a generic form that does all of the above but with -- a slightly scarier type. See "Diagrams.Backend.CmdLine". This --- form can also take a function type that has a subtable final result +-- form can also take a function type that has a suitable final result -- (any of arguments to the above types) and 'Parseable' arguments. -- -- If you want to generate diagrams programmatically---/i.e./ if you @@ -67,17 +70,32 @@ , defaultMain , multiMain , animMain + , gifMain + -- * GIF support + + , GifOpts(..) + -- * Backend tokens , Cairo , B ) where -import Control.Lens ((^.),Lens') +import Codec.Picture +import Codec.Picture.ColorQuant (defaultPaletteOptions) +import Data.Vector.Storable (unsafeFromForeignPtr0) +import Foreign.ForeignPtr.Safe (ForeignPtr) +import qualified Data.ByteString.Lazy as L (ByteString, writeFile) +import Data.Word (Word8) +import Options.Applicative -import Diagrams.Prelude hiding (width, height, interval) +import Control.Lens ((^.), Lens', makeLenses) + +import Diagrams.Prelude hiding (width, height, interval, Image, (<>) + , option) import Diagrams.Backend.Cairo +import Diagrams.Backend.Cairo.Ptr (renderForeignPtrOpaque) import Diagrams.Backend.CmdLine -- Below hack is needed because GHC 7.0.x has a bug regarding export @@ -293,7 +311,6 @@ mainRender = defaultAnimMainRender output' - #ifdef CMDLINELOOP waitForChange :: Maybe ModuleTime -> DiagramLoopOpts -> IO () waitForChange lastAttempt opts = do @@ -342,3 +359,118 @@ where getModTime f = catch (Just <$> getModificationTime f) (\(SomeException _) -> return Nothing) #endif + +-- | @gifMain@ takes a list of diagram and delay time pairs and produces a +-- command line program to generate an animated GIF, with options @GifOpts@. +-- "Delay times are in 1/100ths of a second." +-- +-- Example usage: +-- +-- @ +-- $ ghc --make GifTest +-- [1 of 1] Compiling Main ( GifTest.hs, GifTest.o ) +-- Linking GifTest ... +-- ./GifTest --help +-- GifTest +-- +-- Usage: GifTest [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT] +-- [--dither] [--looping-off] [--loop-repeat ARG] +-- Command-line diagram generation. +-- +-- Available options: +-- -?,--help Show this help text +-- -w,--width WIDTH Desired WIDTH of the output image +-- -h,--height HEIGHT Desired HEIGHT of the output image +-- -o,--output OUTPUT OUTPUT file +-- --dither Turn on dithering. +-- --looping-off Turn looping off +-- --loop-repeat ARG Number of times to repeat +-- @ +gifMain :: [(Diagram Cairo R2, GifDelay)] -> IO () +gifMain = mainWith + +-- | Extra options for animated GIFs. +data GifOpts = GifOpts { _dither :: Bool + , _noLooping :: Bool + , _loopRepeat :: Maybe Int} + +makeLenses ''GifOpts + +-- | Command line parser for 'GifOpts'. +-- @--dither@ turn dithering on. +-- @--looping-off@ turn looping off, i.e play GIF once. +-- @--loop-repeat@ number of times to repeat the GIF after the first playing. +-- this option is only used if @--looping-off@ is not set. +instance Parseable GifOpts where + parser = GifOpts <$> switch + ( long "dither" + <> help "Turn on dithering." ) + <*> switch + ( long "looping-off" + <> help "Turn looping off" ) + <*> ( optional . option ) + ( long "loop-repeat" + <> help "Number of times to repeat" ) + +instance Mainable [(Diagram Cairo R2, GifDelay)] where + type MainOpts [(Diagram Cairo R2, GifDelay)] = (DiagramOpts, GifOpts) + + mainRender (dOpts, gOpts) ds = gifRender (dOpts, gOpts) ds + +imageRGB8FromUnsafePtr :: Int -> Int -> ForeignPtr Word8 -> Image PixelRGB8 +imageRGB8FromUnsafePtr w h ptr = pixelMap f cImg + where + f (PixelRGBA8 b g r _) = PixelRGB8 r g b + cImg = Image w h $ unsafeFromForeignPtr0 ptr (w * h * 4) + + +encodeGifAnimation' :: [GifDelay] -> GifLooping -> Bool + -> [Image PixelRGB8] -> Either String (L.ByteString) +encodeGifAnimation' delays looping dithering lst = + encodeGifImages looping triples + where + triples = zipWith (\(x,z) y -> (x, y, z)) doubles delays + doubles = [(pal, img) + | (img, pal) <- palettize + defaultPaletteOptions {enableImageDithering=dithering} <$> lst] + +writeGifAnimation' :: FilePath -> [GifDelay] -> GifLooping -> Bool + -> [Image PixelRGB8] -> Either String (IO ()) +writeGifAnimation' path delays looping dithering img = + L.writeFile path <$> encodeGifAnimation' delays looping dithering img + +scaleInt :: Int -> Double -> Double -> Int +scaleInt i num denom + | num == 0 || denom == 0 = i + | otherwise = round (num / denom * fromIntegral i) + +gifRender :: (DiagramOpts, GifOpts) -> [(Diagram Cairo R2, GifDelay)] -> IO () +gifRender (dOpts, gOpts) lst = + case splitOn "." (dOpts^.output) of + [""] -> putStrLn "No output file given" + ps | last ps == "gif" -> do + let (w, h) = case (dOpts^.width, dOpts^.height) of + (Just w', Just h') -> (w', h') + (Just w', Nothing) -> (w', scaleInt w' diaHeight diaWidth) + (Nothing, Just h') -> (scaleInt h' diaWidth diaHeight, h') + (Nothing, Nothing) -> (100, 100) + looping = if gOpts^.noLooping + then LoopingNever + else case gOpts^.loopRepeat of + Nothing -> LoopingForever + Just n -> LoopingRepeat (fromIntegral n) + dias = map fst lst + delays = map snd lst + (diaWidth, diaHeight) = size2D (head dias) + fPtrs <- mapM (renderForeignPtrOpaque w h) dias + let imageRGB8s = map (imageRGB8FromUnsafePtr w h) fPtrs + result = writeGifAnimation' + (dOpts^.output) + delays + looping + (gOpts^.dither) + imageRGB8s + case result of + Left s -> putStrLn s + Right io -> io + | otherwise -> putStrLn $ "File name must end with .gif" diff --git a/src/Diagrams/Backend/Cairo/Internal.hs b/src/Diagrams/Backend/Cairo/Internal.hs --- a/src/Diagrams/Backend/Cairo/Internal.hs +++ b/src/Diagrams/Backend/Cairo/Internal.hs @@ -304,15 +304,23 @@ = C . liftC $ C.relCurveTo x1 y1 x2 y2 x3 y3 instance Renderable (Trail R2) Cairo where - render _ t = flip withLine t $ renderT . lineSegments + render _ = withTrail renderLine renderLoop where - renderT segs = - C $ do - mapM_ renderC segs - liftC $ when (isLoop t) C.closePath + renderLine ln = C $ do + mapM_ renderC (lineSegments ln) - when (isLine t) (ignoreFill .= True) - -- remember that we saw a Line, so we will ignore fill attribute + -- remember that we saw a Line, so we will ignore fill attribute + ignoreFill .= True + + renderLoop lp = C $ do + case loopSegments lp of + -- let closePath handle the last segment if it is linear + (segs, Linear _) -> mapM_ renderC segs + + -- otherwise we have to draw it explicitly + _ -> mapM_ renderC (lineSegments . cutLoop $ lp) + + liftC C.closePath instance Renderable (Path R2) Cairo where render _ p = C $ do diff --git a/src/Diagrams/Backend/Cairo/List.hs b/src/Diagrams/Backend/Cairo/List.hs --- a/src/Diagrams/Backend/Cairo/List.hs +++ b/src/Diagrams/Backend/Cairo/List.hs @@ -22,6 +22,7 @@ import Diagrams.Backend.Cairo (Cairo) import Diagrams.Backend.Cairo.Ptr (renderPtr) +import Graphics.Rendering.Cairo (Format (..)) import Diagrams.Prelude (Diagram, R2) import Foreign.Marshal.Alloc (free) @@ -32,7 +33,7 @@ renderToList :: (Ord a, Floating a) => Int -> Int -> Diagram Cairo R2 -> IO [[AlphaColour a]] renderToList w h d = - f 0 <$> bracket (renderPtr w h d) free (peekArray $ w*h*4) + f 0 <$> bracket (renderPtr w h FormatARGB32 d) free (peekArray $ w*h*4) where f :: (Ord a, Floating a) => Int -> [Word8] -> [[AlphaColour a]] f _ [] = [] diff --git a/src/Diagrams/Backend/Cairo/Ptr.hs b/src/Diagrams/Backend/Cairo/Ptr.hs --- a/src/Diagrams/Backend/Cairo/Ptr.hs +++ b/src/Diagrams/Backend/Cairo/Ptr.hs @@ -31,9 +31,9 @@ -- | Render a diagram to a new buffer in memory, with the format ARGB32. -renderPtr :: Int -> Int -> Diagram Cairo R2 -> IO (Ptr Word8) -renderPtr w h d = do - let stride = formatStrideForWidth FormatARGB32 w +renderPtr :: Int -> Int -> Format -> Diagram Cairo R2 -> IO (Ptr Word8) +renderPtr w h fmt d = do + let stride = formatStrideForWidth fmt w size = stride * h opt = CairoOptions { _cairoSizeSpec = Dims (fromIntegral w) (fromIntegral h) @@ -45,11 +45,14 @@ b <- mallocArray size pokeArray b (replicate size 0) - withImageSurfaceForData b FormatARGB32 w h stride (`renderWith` r) + withImageSurfaceForData b fmt w h stride (`renderWith` r) return (castPtr b) -- | Like 'renderPtr' but automatically garbage collected by Haskell. renderForeignPtr :: Int -> Int -> Diagram Cairo R2 -> IO (ForeignPtr Word8) -renderForeignPtr w h d = renderPtr w h d >>= newForeignPtr finalizerFree +renderForeignPtr w h d = renderPtr w h FormatARGB32 d >>= newForeignPtr finalizerFree + +renderForeignPtrOpaque :: Int -> Int -> Diagram Cairo R2 -> IO (ForeignPtr Word8) +renderForeignPtrOpaque w h d = renderPtr w h FormatRGB24 d >>= newForeignPtr finalizerFree