diagrams-rasterific (empty) → 0.1

raw patch · 16 files changed

+921/−0 lines, 16 filesdep +FontyFruitydep +JuicyPixelsdep +Rasterificsetup-changedbinary-added

Dependencies added: FontyFruity, JuicyPixels, Rasterific, base, bytestring, containers, data-default-class, diagrams-core, diagrams-lib, directory, filepath, lens, mtl, old-time, optparse-applicative, process, split, statestack, time, unix

Files

• LICENSE +34/−0
• README.md +10/−0
• Setup.hs +2/−0
• diagrams-rasterific.cabal +50/−0
• fonts/OpenSans-Bold.ttf binary
• fonts/OpenSans-BoldItalic.ttf binary
• fonts/OpenSans-ExtraBold.ttf binary
• fonts/OpenSans-ExtraBoldItalic.ttf binary
• fonts/OpenSans-Italic.ttf binary
• fonts/OpenSans-Light.ttf binary
• fonts/OpenSans-LightItalic.ttf binary
• fonts/OpenSans-Regular.ttf binary
• fonts/OpenSans-Semibold.ttf binary
• fonts/OpenSans-SemiboldItalic.ttf binary
• src/Diagrams/Backend/Rasterific.hs +475/−0
• src/Diagrams/Backend/Rasterific/CmdLine.hs +350/−0

@@ -0,0 +1,34 @@+Copyright (c) 2014 diagrams-rasterific team:++   Vincent Berthoux <vincent.berthoux@gmail.com>+   Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>+   Brent Yorgey <byorgey@ciss.upenn.edu>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jeffrey Rosenbluth nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,10 @@+diagrams-rasterific+===================++_diagrams-rasterific_ is a an Rasterific backend for [diagrams]. Diagrams is a powerful,+flexible, declarative domain-specific language for creating vector graphics,+using the [Haskell programming language][haskell]. It supports png, tif, bmp,+jpg and animated GIF output.++[diagrams]: http://projects.haskell.org/diagrams/+[haskell]: http://www.haskell.org/haskellwiki/Haskell

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,50 @@+name:                diagrams-rasterific+version:             0.1+synopsis:            Rasterific backend for diagrams.+description:         A full-featured backend for rendering+                     diagrams using the Rasterific rendering engine.+homepage:             http://projects.haskell.org/diagrams/+license:             BSD3+license-file:        LICENSE+author:              Jeffrey Rosenbluth+maintainer:          diagrams-discuss@googlegroups.com+bug-reports:         http://github.com/diagrams/diagrams-cairo/issues+category:            Graphics+build-type:          Simple+data-files:          fonts/*.ttf+extra-source-files:  README.md+cabal-version:       >=1.10+Source-repository head+  type:     git+  location: http://github.com/diagrams/diagrams-rasterific.git++library+  exposed-modules:     Diagrams.Backend.Rasterific+                       Diagrams.Backend.Rasterific.CmdLine+  hs-source-dirs:      src+  other-modules:       Paths_diagrams_rasterific+  build-depends:       base >= 4.2 && < 4.8,+                       old-time,+                       time,+                       process,+                       directory,+                       diagrams-core >= 1.2 && < 1.3,+                       diagrams-lib >= 1.2 && < 1.3,+                       Rasterific >= 0.2 && < 0.4,+                       FontyFruity >= 0.2 && < 0.4,+                       JuicyPixels >= 3.1.5 && < 3.2,+                       lens >= 4.0 && < 4.3,+                       mtl >= 2.1 && < 2.3,+                       statestack >= 0.2 && < 0.3,+                       data-default-class >= 0.0 && < 0.1,+                       containers >= 0.5 && < 0.6,+                       filepath >= 1.2 && < 1.4,+                       optparse-applicative >= 0.7 && < 0.10,+                       bytestring >= 0.9 && < 0.11,+                       split >= 0.1 && < 1.3++  if !os(windows)+    cpp-options:       -DCMDLINELOOP+    Build-depends:     unix >= 2.4 && < 2.8++  default-language:    Haskell2010

binary file changed (absent → 224592 bytes)

binary file changed (absent → 213292 bytes)

binary file changed (absent → 222584 bytes)

binary file changed (absent → 213420 bytes)

binary file changed (absent → 212896 bytes)

binary file changed (absent → 222412 bytes)

binary file changed (absent → 213128 bytes)

binary file changed (absent → 217360 bytes)

binary file changed (absent → 221328 bytes)

binary file changed (absent → 212820 bytes)

@@ -0,0 +1,475 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeSynonymInstances      #-}+{-# LANGUAGE ViewPatterns              #-}++-------------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Backend.Rasterific+-- Copyright   :  (c) 2014 diagrams-rasterific team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- A full-featured rendering backend for diagrams using Rasterific,+-- implemented natively in Haskell (making it easy to use on any+-- platform). Can create png, tif, bmp, jpg, and animated GIFs.+--+-- To invoke the Rasterific backend, you have three options.+--+-- * You can use the "Diagrams.Backend.Rasterific.CmdLine" module to create+--   standalone executables which output images when invoked.+--+-- * You can use the 'renderRasterific' function provided by this module,+--   which gives you more flexible programmatic control over when and+--   how images are output (making it easy to, for example, write a+--   single program that outputs multiple images, or one that outputs+--   images dynamically based on user input, and so on).+--+-- * For the most flexibility (/e.g./ if you want access to the+--   resulting Rasterific value directly in memory without writing it to+--   disk), you can manually invoke the 'renderDia' method from the+--   'Diagrams.Core.Types.Backend' instance for @Rasterific@.  In particular,+--   'Diagrams.Core.Types.renderDia' has the generic type+--+-- > renderDia :: b -> Options b v -> QDiagram b v m -> Result b v+--+-- (omitting a few type class constraints).  @b@ represents the+-- backend type, @v@ the vector space, and @m@ the type of monoidal+-- query annotations on the diagram.  'Options' and 'Result' are+-- associated data and type families, respectively, which yield the+-- type of option records and rendering results specific to any+-- particular backend.  For @b ~ Rasterific@ and @v ~ R2@, we have+--+-- > data Options Rasterific R2 = RasterificOptions+-- >          { _rasterificSizeSpec      :: SizeSpec2D -- ^ The requested size of the output+-- >          , _rasterificBypassAdjust  :: Bool       -- ^ Should the 'adjustDia' step be bypassed during rendering?+-- >          }+--+-- @+-- data family Render Rasterific R2 = 'R (RenderM ())'+-- @+--+-- @+-- type family Result Rasterific R2 = 'Image PixelRGBA8'+-- @+--+-- So the type of 'renderDia' resolves to+--+-- @+-- renderDia :: Rasterific -> Options Rasterific R2 -> QDiagram Rasterific R2 m -> 'Image PixelRGBA8'+-- @+--+-- which you could call like @renderDia Rasterific (RasterificOptions (Width 250))+-- myDiagram@.+--+-------------------------------------------------------------------------------+module Diagrams.Backend.Rasterific+  ( Rasterific(..)+  , B -- rendering token+  , Options(..)++  , renderRasterific+  , size++  , writeJpeg++  ) where++import           Diagrams.Core.Compile+import           Diagrams.Core.Transform     (matrixHomRep)+++import           Diagrams.Prelude            hiding (opacity, view)+import           Diagrams.TwoD.Adjust        (adjustDia2D)+import           Diagrams.TwoD.Attributes    (splitTextureFills)+import           Diagrams.TwoD.Path          (Clip (Clip), getFillRule)+import           Diagrams.TwoD.Size          (sizePair)+import           Diagrams.TwoD.Text          hiding (Font)++import           Codec.Picture+import           Codec.Picture.Types         (dropTransparency, convertPixel+                                             ,promoteImage, convertImage)++import           GHC.Float                   (double2Float, float2Double)++import qualified Graphics.Rasterific         as R+import           Graphics.Rasterific.Texture (uniformTexture, Gradient+                                             ,linearGradientTexture ,withSampler+                                             ,radialGradientWithFocusTexture+                                             ,transformTexture)++import qualified Graphics.Rasterific.Transformations as R++import           Graphics.Text.TrueType      (loadFontFile, Font, stringBoundingBox)+++import           Control.Lens                hiding (transform, ( # ))+import           Control.Monad               (when)+import           Control.Monad.StateStack+import           Control.Monad.Trans         (lift)+++import qualified Data.ByteString.Lazy as L   (writeFile)+import           Data.Default.Class+import qualified Data.Foldable               as F+import           Data.Maybe                  (fromMaybe, isJust, fromJust)+import           Data.Tree+import           Data.Typeable+import           Data.Word                   (Word8)++import           System.FilePath             (takeExtension)+import           System.IO.Unsafe            (unsafePerformIO)+import           Paths_diagrams_rasterific   (getDataFileName)++--------------------------------------------------------------------------------+-- | This data declaration is simply used as a token to distinguish+--   the Rasterific backend: (1) when calling functions where the type+--   inference engine would otherwise have no way to know which+--   backend you wanted to use, and (2) as an argument to the+--   'Backend' and 'Renderable' type classes.+data Rasterific = Rasterific+  deriving (Eq,Ord,Read,Show,Typeable)++type B = Rasterific++data RasterificState =+  RasterificState { _accumStyle :: Style R2+                    -- ^ The current accumulated style.+                  }++makeLenses ''RasterificState++instance Default RasterificState where+  def = RasterificState+        { _accumStyle       = mempty+        }++-- | The custom monad in which intermediate drawing options take+--   place; 'Graphics.Rasterific.Drawing' is Rasterific's own rendering+--   monad.+type RenderM a = StateStackT RasterificState RenderR a++type RenderR = R.Drawing PixelRGBA8++liftR :: RenderR a -> RenderM a+liftR = lift++runRenderM :: RenderM a -> RenderR a+runRenderM = flip evalStateStackT def++-- From Diagrams.Core.Types.+instance Backend Rasterific R2 where+  data Render  Rasterific R2 = R (RenderM ())+  type Result  Rasterific R2 = Image PixelRGBA8+  data Options Rasterific R2 = RasterificOptions+          { _size      :: SizeSpec2D -- ^ The requested size of the output+          }+    deriving (Show)++  renderRTree _ opts t =+    R.renderDrawing (round w) (round h) bgColor r+    where+      r = runRenderM . runR . toRender $ t+      (w,h) = sizePair (opts^.size)+      bgColor = PixelRGBA8 0 0 0 0++  adjustDia c opts d = adjustDia2D size c opts (d # reflectY # fontSizeO 12)++toRender :: RTree Rasterific R2 a -> Render Rasterific R2+toRender = fromRTree+  . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))+  . (:[])+  . splitTextureFills+    where+      fromRTree (Node (RPrim p) _) = render Rasterific p+      fromRTree (Node (RStyle sty) rs) = R $ do+        save+        accumStyle %= (<> sty)+        aStyle <- use accumStyle+        let R r = F.foldMap fromRTree rs+            m = evalStateStackT r (RasterificState aStyle)+        clip sty m+        restore+      fromRTree (Node _ rs) = F.foldMap fromRTree rs++runR :: Render Rasterific R2 -> RenderM ()+runR (R r) = r++instance Monoid (Render Rasterific R2) where+  mempty  = R $ return ()+  (R rd1) `mappend` (R rd2) = R (rd1 >> rd2)++size :: Lens' (Options Rasterific R2) SizeSpec2D+size = lens (\(RasterificOptions {_size = s}) -> s)+                     (\o s -> o {_size = s})++rasterificStrokeStyle :: Style v+                     -> (Float, R.Join, (R.Cap, R.Cap), Maybe (R.DashPattern, Float))+rasterificStrokeStyle s = (strokeWidth, strokeJoin, strokeCaps, strokeDash)+  where+    strokeWidth = double2Float $ case getLineWidth <$> getAttr s of+                      Just o ->  fromOutput o+                      _               ->  1+    strokeJoin = fromMaybe (R.JoinMiter 0) (fromLineJoin . getLineJoin <$> getAttr s)+    strokeCaps = (strokeCap, strokeCap)+    strokeCap = fromMaybe (R.CapStraight 0) (fromLineCap . getLineCap <$> getAttr s)+    strokeDash = fromDashing . getDashing <$> getAttr s++fromLineCap :: LineCap -> R.Cap+fromLineCap LineCapButt   = R.CapStraight 0+fromLineCap LineCapRound  = R.CapRound+fromLineCap LineCapSquare = R.CapStraight 1++fromLineJoin :: LineJoin -> R.Join+fromLineJoin LineJoinMiter = R.JoinMiter 0+fromLineJoin LineJoinRound = R.JoinRound+fromLineJoin LineJoinBevel = R.JoinMiter 1++fromDashing :: Dashing -> (R.DashPattern, Float)+fromDashing (Dashing ds d) = (map double2Float ds', double2Float d')+  where+    ds' = map fromOutput ds+    d' = fromOutput d++fromFillRule :: FillRule -> R.FillMethod+fromFillRule EvenOdd = R.FillEvenOdd+fromFillRule _ = R.FillWinding++-- | Get an accumulated style attribute from the render monad state.+getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)+getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle++rasterificColor :: SomeColor -> Double -> PixelRGBA8+rasterificColor c o = PixelRGBA8 r g b a+  where+    (r, g, b, a) = (int r', int g', int b', int (o * a'))+    (r', g', b', a') = colorToSRGBA (toAlphaColour c)+    int x = round (255 * x)++rasterificSpreadMethod :: SpreadMethod -> R.SamplerRepeat+rasterificSpreadMethod GradPad      = R.SamplerPad+rasterificSpreadMethod GradReflect  = R.SamplerReflect+rasterificSpreadMethod GradRepeat   = R.SamplerRepeat++rasterificStops :: [GradientStop] -> Gradient PixelRGBA8+rasterificStops s = map fromStop s+  where+    fromStop (GradientStop c v) =+      (double2Float v, rasterificColor c 1)++rasterificLinearGradient :: LGradient -> R.Texture PixelRGBA8+rasterificLinearGradient g = transformTexture tr tx+  where+    tr = rasterificMatTransf (inv $ g^.lGradTrans)+    tx = withSampler spreadMethod (linearGradientTexture gradDef p0 p1)+    spreadMethod = rasterificSpreadMethod (g^.lGradSpreadMethod)+    gradDef = rasterificStops (g^.lGradStops)+    p0 = p2v2 (g^.lGradStart)+    p1 = p2v2 (g^.lGradEnd)+++rasterificRadialGradient :: RGradient -> R.Texture PixelRGBA8+rasterificRadialGradient g = transformTexture tr tx+  where+    tr = rasterificMatTransf (inv $ g^.rGradTrans)+    tx = withSampler spreadMethod (radialGradientWithFocusTexture gradDef c r f)+    spreadMethod = rasterificSpreadMethod (g^.rGradSpreadMethod)+    c = p2v2 (g^.rGradCenter1)+    f = p2v2 (g^.rGradCenter0)+    r = double2Float r1+    gradDef = rasterificStops ss++    -- Adjust the stops so that the gradient begins at the perimeter of+    -- the inner circle (center0, radius0) and ends at the outer circle.+    r0 = g^.rGradRadius0+    r1 = g^.rGradRadius1+    stopFracs = r0 / r1 : map (\s -> (r0 + (s^.stopFraction) * (r1-r0)) / r1)+                (g^.rGradStops)+    gradStops = case g^.rGradStops of+      []       -> []+      xs@(x:_) -> x : xs+    ss = zipWith (\gs sf -> gs & stopFraction .~ sf ) gradStops stopFracs++-- Convert a diagrams @Texture@ and opacity to a rasterific texture.+rasterificTexture :: Texture -> Double -> R.Texture PixelRGBA8+rasterificTexture (SC c) o = uniformTexture $ rasterificColor c o+rasterificTexture (LG g) _ = rasterificLinearGradient g+rasterificTexture (RG g) _ = rasterificRadialGradient g++v2 :: Double -> Double -> R.Point+v2 x y = R.V2 x' y'+  where+    (x', y') = (double2Float x, double2Float y)++p2v2 :: P2 -> R.Point+p2v2 p = uncurry v2 $ unp2 p++r2v2 :: R2 -> R.Point+r2v2 r = uncurry v2 $ unr2 r++rasterificPtTransf :: T2 -> R.Point -> R.Point+rasterificPtTransf tr p =  p2v2 $ transform tr p'+  where+    p' = mkP2 (float2Double x) (float2Double y)+    R.V2 x y = p++rasterificMatTransf :: T2 -> R.Transformation+rasterificMatTransf tr = R.Transformation a c e b d f+  where+    [[a, b], [c, d], [e, f]] = (map . map) double2Float (matrixHomRep tr)++-- Note: Using view patterns confuses ghc to think there are missing patterns,+-- so we avoid them here.+renderSeg :: Located (Segment Closed R2) -> R.Primitive+renderSeg l =+  case viewLoc l of+    (p, (Linear (OffsetClosed v))) ->+      R.LinePrim $ R.Line p' (p' + r2v2 v)+      where+        p' = p2v2 p+    (p, (Cubic u1 u2 (OffsetClosed u3))) ->+      R.CubicBezierPrim $ R.CubicBezier q0 q1 q2 q3+      where+        (q0, q1, q2, q3) = (p2v2 p, q0 + r2v2 u1, q0 + r2v2 u2, q0 + r2v2 u3)++renderPath :: Path R2 -> [[R.Primitive]]+renderPath p = (map . map) renderSeg (pathLocSegments p)++clip :: Style v -> RenderR () -> RenderM ()+clip sty d =+  maybe (liftR d)+        (\paths -> liftR $ R.withClipping+                  (R.fill (concat . concat $ (map renderPath paths))) d)+        (op Clip <$> getAttr sty)++-- Stroke both dashed and solid lines.+mkStroke :: Float ->  R.Join -> (R.Cap, R.Cap) ->  Maybe (R.DashPattern, Float)+      -> [[R.Primitive]] -> RenderR ()+mkStroke l j c d  primList =+  maybe (mapM_ (R.stroke l j c) primList)+        (\(dsh, off) -> mapM_ (R.dashedStrokeWithOffset off dsh l j c) primList)+        d++instance Renderable (Path R2) Rasterific where+  render _ p = R $ do+    f <- getStyleAttrib getFillTexture+    s <- fromMaybe (SC (SomeColor (black :: Colour Double))) +         <$> getStyleAttrib getLineTexture+    o <- fromMaybe 1 <$> getStyleAttrib getOpacity+    r <- fromMaybe Winding <$> getStyleAttrib getFillRule+    sty <- use accumStyle++    let (l, j, c, d) = rasterificStrokeStyle sty+        rule = fromFillRule r++        -- For stroking we need to keep all of the contours separate.+        primList = renderPath p++        -- For filling we need to concatenate them into a flat list.+        prms = concat primList++    when (isJust f) $ liftR (R.withTexture (rasterificTexture (fromJust f) o)+                    $ R.fillWithMethod rule prms)+    liftR (R.withTexture (rasterificTexture s o) $ mkStroke l j c d primList)++-- read only of static data (safe)+ro :: FilePath -> FilePath+ro = unsafePerformIO . getDataFileName++openSansRegular :: Font+openSansRegular = fnt+  where+    Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-Regular.ttf")++openSansBold :: Font+openSansBold = fnt+  where+    Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-Bold.ttf")++openSansItalic :: Font+openSansItalic = fnt+  where+    Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-Italic.ttf")++openSansBoldItalic :: Font+openSansBoldItalic = fnt+  where+    Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-BoldItalic.ttf")++fromFontStyle :: FontSlant -> FontWeight -> Font+fromFontStyle FontSlantItalic FontWeightBold = openSansBoldItalic+fromFontStyle FontSlantOblique FontWeightBold = openSansBoldItalic+fromFontStyle FontSlantNormal FontWeightBold = openSansBold+fromFontStyle FontSlantItalic FontWeightNormal = openSansItalic+fromFontStyle FontSlantOblique FontWeightNormal = openSansItalic+fromFontStyle _ _ = openSansRegular++textBox :: Font -> Int -> String -> (Double, Double)+textBox f ps str = (float2Double w, float2Double h)+  where+    (w, h) = stringBoundingBox f 96 ps str++instance Renderable Text Rasterific where+  render _ (Text tt tn al str) = R $ do+    isLocal <- fromMaybe True <$> getStyleAttrib getFontSizeIsLocal+    fs      <- fromMaybe 12 <$> getStyleAttrib (fromOutput . getFontSize)+    slant   <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant+    fw      <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight+    f       <- fromMaybe (SC (SomeColor (black :: Colour Double))) +               <$> getStyleAttrib getFillTexture+    o       <- fromMaybe 1 <$> getStyleAttrib getOpacity+    let fColor = rasterificTexture f o+        fs' = round fs+        fnt = fromFontStyle slant fw+        (x, y) = textBox fnt fs' str+        (refX, refY) = case al of+          BaselineText -> (0, y)+          BoxAlignedText xt yt -> (x * xt, (1 - yt) * y)+        tr = if isLocal then tt else tn+        p = rasterificPtTransf ((moveOriginBy (r2 (refX, refY)) mempty)) (R.V2 0 0)+    liftR (R.withTransformation (rasterificMatTransf (tr <> reflectionY))+          (R.withTexture fColor $ R.printTextAt fnt fs' p str))++toImageRGBA8 :: DynamicImage -> Image PixelRGBA8+toImageRGBA8 (ImageRGBA8 i)  = i+toImageRGBA8 (ImageRGB8 i)   = promoteImage i+toImageRGBA8 (ImageYCbCr8 i) = promoteImage $ (convertImage i :: Image PixelRGB8)+toImageRGBA8 (ImageY8 i)     = promoteImage i+toImageRGBA8 (ImageYA8 i)    = promoteImage i+toImageRGBA8 (ImageCMYK8 i)  = promoteImage $ (convertImage i :: Image PixelRGB8)+toImageRGBA8 _               = error "Unsupported Pixel type"++instance Renderable (DImage Embedded) Rasterific where+  render _ (DImage iD w h tr) = R $ liftR+                               (R.withTransformation+                               (rasterificMatTransf (tr <> reflectionY))+                               (R.drawImage img 0 p))+    where+      ImageRaster dImg = iD+      img = toImageRGBA8 dImg+      trl = moveOriginBy (r2 ((fromIntegral w / 2), (fromIntegral h / 2))) mempty +      p = rasterificPtTransf trl (R.V2 0 0)++writeJpeg :: Word8 -> FilePath -> Result Rasterific R2 -> IO ()+writeJpeg quality outFile img = L.writeFile outFile bs+  where+    bs = encodeJpegAtQuality quality (pixelMap (convertPixel . dropTransparency) img)++renderRasterific :: FilePath -> SizeSpec2D -> Word8 -> Diagram Rasterific R2 -> IO ()+renderRasterific outFile sizeSpec quality d = writer outFile img+  where+    writer = case takeExtension outFile of+              ".png" -> writePng+              ".tif" -> writeTiff+              ".bmp" -> writeBitmap+              ".jpg" -> writeJpeg q+              _      -> writePng+    img = renderDia Rasterific (RasterificOptions sizeSpec) d+    q = max quality 100

@@ -0,0 +1,350 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP                  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.Backend.Rasterific.CmdLine+-- Copyright   :  (c) 2014 Diagrams team (see LICENSE)+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  diagrams-discuss@googlegroups.com+--+-- Convenient creation of command-line-driven executables for+-- rendering diagrams using the Rasterific backend. Create+-- png, tif, bmp, jpg or animated GIF files.+--+-- * 'defaultMain' creates an executable which can render a single+--   diagram at various options.+--+-- * 'multiMain' is like 'defaultMain' but allows for a list of+--   diagrams from which the user can choose one to render.+--+-- * '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 suitable final result+--   (any of arguments to the above types) and 'Parseable' arguments.+--+-- If you want to generate diagrams programmatically---/i.e./ if you+-- want to do anything more complex than what the below functions+-- provide---you have several options.+--+-- * Use a function with 'mainWith'.  This may require making+--   'Parseable' instances for custom argument types.+--+-- * Make a new 'Mainable' instance.  This may require a newtype+--   wrapper on your diagram type to avoid the existing instances.+--   This gives you more control over argument parsing, intervening+--   steps, and diagram creation.+--+-- * Build option records and pass them along with a diagram to 'mainRender'+--   from "Diagrams.Backend.CmdLine".+--+-- * You can use 'Diagrams.Backend.Rasterific.renderRasterific' to render a+--   diagram to a file directly; see "Diagrams.Backend.Rasterific".+--+-- * A more flexible approach is to directly call 'renderDia'; see+--   "Diagrams.Backend.Rasterific" for more information.+--+-- For a tutorial on command-line diagram creation see+-- <http://projects.haskell.org/diagrams/doc/cmdline.html>.+--+-----------------------------------------------------------------------------+module Diagrams.Backend.Rasterific.CmdLine+        (+         -- * General form of @main@+         -- $mainwith+         mainWith++         -- * Supported forms of @main@+       , defaultMain+       , multiMain+       , animMain+       , gifMain++        -- * GIF support+       , GifOpts(..)++         -- * Backend tokens+       , Rasterific+       , B+       ) where++import           Diagrams.Prelude              hiding (width, height, interval+                                              ,option, (<>))+import           Diagrams.Backend.Rasterific+import           Diagrams.Backend.CmdLine++import           Codec.Picture+import           Codec.Picture.Types          (dropTransparency)+import           Codec.Picture.ColorQuant     (defaultPaletteOptions)++import qualified Data.ByteString.Lazy as L    (ByteString, writeFile)++import           Options.Applicative+import           Control.Lens                 ((^.), Lens', makeLenses)++import           Data.List.Split++#ifdef CMDLINELOOP++import           Data.Maybe                  (fromMaybe)+import           Control.Monad               (when, mplus)+import           Control.Lens                (_1)++import           System.Environment          (getArgs, getProgName)+import           System.Directory            (getModificationTime)+import           System.Process              (runProcess, waitForProcess)+import           System.IO                   (openFile, hClose, IOMode(..)+                                             ,hSetBuffering, BufferMode(..)+                                             ,stdout)+import           System.Exit                 (ExitCode(..))+import           Control.Concurrent          (threadDelay)+import           Control.Exception           (catch, SomeException(..), bracket)+import           System.Posix.Process        (executeFile)++#if MIN_VERSION_directory(1,2,0)++import           Data.Time.Clock             (UTCTime,getCurrentTime)++type ModuleTime = UTCTime+getModuleTime :: IO  ModuleTime+getModuleTime = getCurrentTime++#else++import          System.Time                  (ClockTime, getClockTime)++type ModuleTime = ClockTime+getModuleTime :: IO  ModuleTime+getModuleTime = getClockTime++#endif+#endif++defaultMain :: Diagram Rasterific R2 -> IO ()+defaultMain = mainWith++#ifdef CMDLINELOOP++output' :: Lens' (MainOpts (Diagram Rasterific R2)) FilePath+output' = _1 . output++instance Mainable (Diagram Rasterific R2) where+    type MainOpts (Diagram Rasterific R2) = (DiagramOpts, DiagramLoopOpts)++    mainRender (opts,loopOpts) d = do+        chooseRender opts d+        when (loopOpts^.loop) (waitForChange Nothing loopOpts)+#else++output' :: Lens' (MainOpts (Diagram Rasterific R2)) FilePath+output' = output++instance Mainable (Diagram Rasterific R2) where+    type MainOpts (Diagram Rasterific R2) = DiagramOpts++    mainRender opts d = chooseRender opts d++#endif++chooseRender :: DiagramOpts -> Diagram Rasterific R2 -> IO ()+chooseRender opts d =+  case splitOn "." (opts ^. output) of+    [""] -> putStrLn "No output file given."+    ps | last ps `elem` ["png", "tif", "bmp", "jpg"] -> do+           let img = renderDia Rasterific+                        ( RasterificOptions+                          (mkSizeSpec+                             (fromIntegral <$> opts ^. width )+                             (fromIntegral <$> opts ^. height)+                          )+                        )+                        d+           case last ps of+             "png" -> writePng (opts^.output) img+             "tif" -> writeTiff (opts^.output) img+             "bmp" -> writeBitmap (opts^.output) img+             "jpg" -> writeJpeg 100 (opts^.output) img+             _     -> writePng (opts^.output) img+       | otherwise -> putStrLn $ "Unknown file type: " ++ last ps++-- | @multiMain@ is like 'defaultMain', except instead of a single+--   diagram it takes a list of diagrams paired with names as input.+--   The generated executable then takes a @--selection@ option+--   specifying the name of the diagram that should be rendered.  The+--   list of available diagrams may also be printed by passing the+--   option @--list@.+--+--   Example usage:+--+-- @+-- $ ghc --make MultiTest+-- [1 of 1] Compiling Main             ( MultiTest.hs, MultiTest.o )+-- Linking MultiTest ...+-- $ ./MultiTest --list+-- Available diagrams:+--   foo bar+-- $ ./MultiTest --selection bar -o Bar.png -w 200+-- @++multiMain :: [(String, Diagram Rasterific R2)] -> IO ()+multiMain = mainWith++instance Mainable [(String,Diagram Rasterific R2)] where+    type MainOpts [(String,Diagram Rasterific R2)]+        = (MainOpts (Diagram Rasterific R2), DiagramMultiOpts)++    mainRender = defaultMultiMainRender++-- | @animMain@ is like 'defaultMain', but renders an animation+-- instead of a diagram.  It takes as input an animation and produces+-- a command-line program which will crudely \"render\" the animation+-- by rendering one image for each frame, named by extending the given+-- output file name by consecutive integers.  For example if the given+-- output file name is @foo\/blah.png@, the frames will be saved in+-- @foo\/blah001.png@, @foo\/blah002.png@, and so on (the number of+-- padding digits used depends on the total number of frames).  It is+-- up to the user to take these images and stitch them together into+-- an actual animation format (using, /e.g./ @ffmpeg@).+--+--   Of course, this is a rather crude method of rendering animations;+--   more sophisticated methods will likely be added in the future.+--+-- The @--fpu@ option can be used to control how many frames will be+-- output for each second (unit time) of animation.+animMain :: Animation Rasterific R2 -> IO ()+animMain = mainWith++instance Mainable (Animation Rasterific R2) where+    type MainOpts (Animation Rasterific R2) =+      (MainOpts (Diagram Rasterific R2), DiagramAnimOpts)++    mainRender = defaultAnimMainRender output'++#ifdef CMDLINELOOP++waitForChange :: Maybe ModuleTime -> DiagramLoopOpts -> IO ()+waitForChange lastAttempt opts = do+    prog <- getProgName+    args <- getArgs+    hSetBuffering stdout NoBuffering+    go prog args lastAttempt+  where go prog args lastAtt = do+          threadDelay (1000000 * opts^.interval)+          -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")"+          (newBin, newAttempt) <- recompile lastAtt prog (opts^.src)+          if newBin+            then executeFile prog False args Nothing+            else go prog args $ newAttempt `mplus` lastAtt++-- | @recompile t prog@ attempts to recompile @prog@, assuming the+--   last attempt was made at time @t@.  If @t@ is @Nothing@ assume+--   the last attempt time is the same as the modification time of the+--   binary.  If the source file modification time is later than the+--   last attempt time, then attempt to recompile, and return the time+--   of this attempt.  Otherwise (if nothing has changed since the+--   last attempt), return @Nothing@.  Also return a Bool saying+--   whether a successful recompilation happened.+recompile :: Maybe ModuleTime -> String -> Maybe String -> IO (Bool, Maybe ModuleTime)+recompile lastAttempt prog mSrc = do+  let errFile = prog ++ ".errors"+      srcFile = fromMaybe (prog ++ ".hs") mSrc+  binT <- maybe (getModTime prog) (return . Just) lastAttempt+  srcT <- getModTime srcFile+  if (srcT > binT)+    then do+      putStr "Recompiling..."+      status <- bracket (openFile errFile WriteMode) hClose $ \h ->+        waitForProcess =<< runProcess "ghc" ["--make", srcFile]+                           Nothing Nothing Nothing Nothing (Just h)++      if (status /= ExitSuccess)+        then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr+        else putStrLn "done."++      curTime <- getModuleTime+      return (status == ExitSuccess, Just curTime)++    else return (False, Nothing)++ where getModTime f = catch (Just <$> getModificationTime f)+                            (\(SomeException _) -> return Nothing)+#endif++gifMain :: [(Diagram Rasterific 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 Rasterific R2, GifDelay)] where+    type MainOpts [(Diagram Rasterific R2, GifDelay)] = (DiagramOpts, GifOpts)++    mainRender (dOpts, gOpts) ds = gifRender (dOpts, gOpts) ds++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++gifRender :: (DiagramOpts, GifOpts) -> [(Diagram Rasterific R2, GifDelay)] -> IO ()+gifRender (dOpts, gOpts) lst =+  case splitOn "." (dOpts^.output) of+    [""] -> putStrLn "No output file given"+    ps | last ps == "gif" -> do+           let 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+               sizeSpec = mkSizeSpec (fromIntegral <$> dOpts^.width)+                                 (fromIntegral <$> dOpts^.height)+               opts = RasterificOptions sizeSpec+               imageRGB8s = map (pixelMap dropTransparency+                               . renderDia Rasterific opts) dias+               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"