diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2014 diagrams-rasterific team: + + Vincent Berthoux + Jeffrey Rosenbluth + Brent Yorgey + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams-rasterific.cabal b/diagrams-rasterific.cabal new file mode 100644 --- /dev/null +++ b/diagrams-rasterific.cabal @@ -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 diff --git a/fonts/OpenSans-Bold.ttf b/fonts/OpenSans-Bold.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-Bold.ttf differ diff --git a/fonts/OpenSans-BoldItalic.ttf b/fonts/OpenSans-BoldItalic.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-BoldItalic.ttf differ diff --git a/fonts/OpenSans-ExtraBold.ttf b/fonts/OpenSans-ExtraBold.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-ExtraBold.ttf differ diff --git a/fonts/OpenSans-ExtraBoldItalic.ttf b/fonts/OpenSans-ExtraBoldItalic.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-ExtraBoldItalic.ttf differ diff --git a/fonts/OpenSans-Italic.ttf b/fonts/OpenSans-Italic.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-Italic.ttf differ diff --git a/fonts/OpenSans-Light.ttf b/fonts/OpenSans-Light.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-Light.ttf differ diff --git a/fonts/OpenSans-LightItalic.ttf b/fonts/OpenSans-LightItalic.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-LightItalic.ttf differ diff --git a/fonts/OpenSans-Regular.ttf b/fonts/OpenSans-Regular.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-Regular.ttf differ diff --git a/fonts/OpenSans-Semibold.ttf b/fonts/OpenSans-Semibold.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-Semibold.ttf differ diff --git a/fonts/OpenSans-SemiboldItalic.ttf b/fonts/OpenSans-SemiboldItalic.ttf new file mode 100644 Binary files /dev/null and b/fonts/OpenSans-SemiboldItalic.ttf differ diff --git a/src/Diagrams/Backend/Rasterific.hs b/src/Diagrams/Backend/Rasterific.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Rasterific.hs @@ -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 diff --git a/src/Diagrams/Backend/Rasterific/CmdLine.hs b/src/Diagrams/Backend/Rasterific/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Rasterific/CmdLine.hs @@ -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 +-- . +-- +----------------------------------------------------------------------------- +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"