diagrams-rasterific 0.1.0.8 → 1.3.0.0
raw patch · 6 files changed
+305/−355 lines, 6 filesdep +hashabledep −directorydep −old-timedep −processdep ~basedep ~diagrams-coredep ~diagrams-libnew-uploader
Dependencies added: hashable
Dependencies removed: directory, old-time, process, time
Dependency ranges changed: base, diagrams-core, diagrams-lib, filepath
Files
- CHANGELOG.md +101/−0
- CHANGES.md +0/−46
- LICENSE +5/−0
- diagrams-rasterific.cabal +8/−10
- src/Diagrams/Backend/Rasterific.hs +154/−157
- src/Diagrams/Backend/Rasterific/CmdLine.hs +37/−142
+ CHANGELOG.md view
@@ -0,0 +1,101 @@+# Change Log++## [v1.3](http://github.com/diagrams/diagrams-rasterific/tree/v1.3) (2015-04-19)++- bump version to 1.3++## [v0.1.0.8](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.8) (2015-04-03)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.7...v0.1.0.8)++**Merged pull requests:**++- Generalise float [\#26](https://github.com/diagrams/diagrams-rasterific/pull/26) ([cchalmers](https://github.com/cchalmers))++## [v0.1.0.7](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.7) (2015-02-10)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.6...v0.1.0.7)++**Merged pull requests:**++- Twinside master [\#25](https://github.com/diagrams/diagrams-rasterific/pull/25) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Preparing for float text size and PointSize new type in FontyFruity. [\#24](https://github.com/diagrams/diagrams-rasterific/pull/24) ([Twinside](https://github.com/Twinside))++## [v0.1.0.6](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.6) (2015-01-13)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.5...v0.1.0.6)++**Merged pull requests:**++- Lower bound on hashable. [\#19](https://github.com/diagrams/diagrams-rasterific/pull/19) ([fryguybob](https://github.com/fryguybob))++- Hashable instance for Options. [\#18](https://github.com/diagrams/diagrams-rasterific/pull/18) ([acowley](https://github.com/acowley))++## [v0.1.0.5](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.5) (2014-12-07)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.4...v0.1.0.5)++**Closed issues:**++- Bumping dependencies to Rasterific 0.4 [\#17](https://github.com/diagrams/diagrams-rasterific/issues/17)++**Merged pull requests:**++- Bumping JuicyPixels dependency [\#16](https://github.com/diagrams/diagrams-rasterific/pull/16) ([Twinside](https://github.com/Twinside))++## [v0.1.0.4](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.4) (2014-11-17)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.3...v0.1.0.4)++**Closed issues:**++- q = max 0 \(min 100 quality\), shurely? [\#15](https://github.com/diagrams/diagrams-rasterific/issues/15)++**Merged pull requests:**++- Bump lens upper version bounds [\#14](https://github.com/diagrams/diagrams-rasterific/pull/14) ([RyanGlScott](https://github.com/RyanGlScott))++- New stuff [\#13](https://github.com/diagrams/diagrams-rasterific/pull/13) ([cchalmers](https://github.com/cchalmers))++- Diagram B [\#12](https://github.com/diagrams/diagrams-rasterific/pull/12) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Linear [\#10](https://github.com/diagrams/diagrams-rasterific/pull/10) ([cchalmers](https://github.com/cchalmers))++## [v0.1.0.3](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.3) (2014-10-08)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.2...v0.1.0.3)++**Merged pull requests:**++- use defaultLoopRender for looping [\#9](https://github.com/diagrams/diagrams-rasterific/pull/9) ([bergey](https://github.com/bergey))++- call defaultAnimMainRender with ASetter for loop options [\#8](https://github.com/diagrams/diagrams-rasterific/pull/8) ([bergey](https://github.com/bergey))++## [v0.1.0.2](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.2) (2014-09-07)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1.0.1...v0.1.0.2)++## [v0.1.0.1](https://github.com/diagrams/diagrams-rasterific/tree/v0.1.0.1) (2014-08-22)++[Full Changelog](https://github.com/diagrams/diagrams-rasterific/compare/v0.1...v0.1.0.1)++## [v0.1](https://github.com/diagrams/diagrams-rasterific/tree/v0.1) (2014-06-02)++**Merged pull requests:**++- pixelMap promotePixel = promoteImage [\#6](https://github.com/diagrams/diagrams-rasterific/pull/6) ([Twinside](https://github.com/Twinside))++- fix text scaling [\#5](https://github.com/diagrams/diagrams-rasterific/pull/5) ([byorgey](https://github.com/byorgey))++- Gradient [\#4](https://github.com/diagrams/diagrams-rasterific/pull/4) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Image2 [\#3](https://github.com/diagrams/diagrams-rasterific/pull/3) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Image [\#2](https://github.com/diagrams/diagrams-rasterific/pull/2) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Units [\#1](https://github.com/diagrams/diagrams-rasterific/pull/1) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++++\* *This Change Log was automatically generated by [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)*
− CHANGES.md
@@ -1,46 +0,0 @@-0.1.0.8 (2 April 2015)------------------------- - allow `lens-4.9`--0.1.0.7 (Feb 10 2015)------------------------ - Allow 'Fontyfruity-0.5'- - Allow 'Rasterific-0.5'- -0.1.0.6 (13 Jan 2015)------------------------- Allow `lens-4.7`--0.1.0.5 (07 December 2014)------------------------------ Allow `Rasterific-0.4`-- Allow `FontyFruity-0.4`--0.1.0.4 (17 November 2014)------------------------------ Allow `lens-4.6`--0.1.0.3 (8 October 2014)---------------------------- Allow `optparse-applicative-0.11`--0.1.0.2 (7 September 2014)------------------------------ Allow optparse-applicative-0.10--0.1.0.1 (22 August 2014)--------------------------- - Allow lens-4.4--0.1 (27 May 2014)-------------------- - Initial release.
LICENSE view
@@ -1,7 +1,12 @@ Copyright (c) 2014 diagrams-rasterific team: + Daniel Bergey <bergey@alum.mit.edu> Vincent Berthoux <vincent.berthoux@gmail.com>+ Christopher Chalmers <c.chalmers@me.com>+ Anthony Cowley Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>+ Ryan Scott+ Ryan Yates <fryguybob@gmail.com> Brent Yorgey <byorgey@ciss.upenn.edu> All rights reserved.
diagrams-rasterific.cabal view
@@ -1,5 +1,5 @@ name: diagrams-rasterific-version: 0.1.0.8+version: 1.3.0.0 synopsis: Rasterific backend for diagrams. description: A full-featured backend for rendering diagrams using the Rasterific rendering engine.@@ -12,7 +12,8 @@ category: Graphics build-type: Simple data-files: fonts/*.ttf-extra-source-files: README.md, CHANGES.md+extra-source-files: README.md, CHANGELOG.md+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 cabal-version: >=1.10 Source-repository head type: git@@ -23,13 +24,10 @@ 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,+ build-depends: base >= 4.2 && < 4.9,+ diagrams-core >= 1.3 && < 1.4,+ diagrams-lib >= 1.3 && < 1.4,+ hashable >= 1.1 && < 1.3, Rasterific >= 0.5 && < 0.6, FontyFruity >= 0.5 && < 0.6, JuicyPixels >= 3.1.5 && < 3.3,@@ -38,7 +36,7 @@ statestack >= 0.2 && < 0.3, data-default-class >= 0.0 && < 0.1, containers >= 0.5 && < 0.6,- filepath >= 1.2 && < 1.4,+ filepath >= 1.2 && < 1.5, optparse-applicative >= 0.10 && < 0.12, bytestring >= 0.9 && < 0.11, split >= 0.1 && < 1.3
src/Diagrams/Backend/Rasterific.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -13,7 +14,7 @@ ------------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Rasterific--- Copyright : (c) 2014 diagrams-rasterific team (see LICENSE)+-- Copyright : (c) 2014-2015 diagrams-rasterific team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -38,35 +39,30 @@ -- '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+-- > renderDia :: b -> Options b v n -> QDiagram b v n m -> Result b v n -- -- (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+-- backend type, @v@ the vector space, @n@ the numeric field, 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?--- > }+-- particular backend. For @b ~ Rasterific@, @v ~ V2@, and @n ~ n@, we have ----- @--- data family Render Rasterific R2 = 'R (RenderM ())'--- @+-- > data Options Rasterific V2 n = RasterificOptions+-- > { _size :: SizeSpec2D n -- ^ The requested size of the output+-- > } -- -- @--- type family Result Rasterific R2 = 'Image PixelRGBA8'+-- type family Result Rasterific V2 n = 'Image PixelRGBA8' -- @ -- -- So the type of 'renderDia' resolves to -- -- @--- renderDia :: Rasterific -> Options Rasterific R2 -> QDiagram Rasterific R2 m -> 'Image PixelRGBA8'+-- renderDia :: Rasterific -> Options Rasterific V2 n -> QDiagram Rasterific V2 n m -> 'Image PixelRGBA8' -- @ ----- which you could call like @renderDia Rasterific (RasterificOptions (Width 250))+-- which you could call like @renderDia Rasterific (RasterificOptions (mkWidth 250)) -- myDiagram@. -- -------------------------------------------------------------------------------@@ -83,50 +79,50 @@ ) where import Diagrams.Core.Compile-import Diagrams.Core.Transform (matrixHomRep)+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 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.Text hiding (Font) import Codec.Picture-import Codec.Picture.Types (dropTransparency, convertPixel- ,promoteImage, convertImage)--import GHC.Float (double2Float, float2Double)+import Codec.Picture.Types (convertImage,+ convertPixel,+ dropTransparency,+ promoteImage) -import qualified Graphics.Rasterific as R-import Graphics.Rasterific.Texture (uniformTexture, Gradient- ,linearGradientTexture ,withSampler- ,radialGradientWithFocusTexture- ,transformTexture)+import qualified Graphics.Rasterific as R+import Graphics.Rasterific.Texture (Gradient,+ linearGradientTexture, radialGradientWithFocusTexture,+ transformTexture,+ uniformTexture,+ withSampler) import qualified Graphics.Rasterific.Transformations as R import Graphics.Text.TrueType -import Control.Lens hiding (transform, ( # ))-import Control.Monad (when)+import Control.Monad (when) import Control.Monad.StateStack-import Control.Monad.Trans (lift)+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 qualified Data.ByteString.Lazy as L (writeFile)+import qualified Data.Foldable as F+import Data.Hashable (Hashable (..))+import Data.Maybe (fromJust, fromMaybe,+ isJust) import Data.Tree import Data.Typeable-import Data.Word (Word8)+import Data.Word (Word8) -import System.FilePath (takeExtension)-import System.IO.Unsafe (unsafePerformIO)-import Paths_diagrams_rasterific (getDataFileName)+import Paths_diagrams_rasterific (getDataFileName)+import System.FilePath (takeExtension)+import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- -- | This data declaration is simply used as a token to distinguish@@ -139,14 +135,16 @@ type B = Rasterific -data RasterificState =- RasterificState { _accumStyle :: Style R2- -- ^ The current accumulated style.- }+type instance V Rasterific = V2+type instance N Rasterific = Double +data RasterificState n = RasterificState+ { _accumStyle :: Style V2 n -- ^ The current accumulated style.+ }+ makeLenses ''RasterificState -instance Default RasterificState where+instance Typeable n => Default (RasterificState n) where def = RasterificState { _accumStyle = mempty }@@ -154,35 +152,35 @@ -- | 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 RenderM n = StateStackT (RasterificState n) RenderR type RenderR = R.Drawing PixelRGBA8 -liftR :: RenderR a -> RenderM a+liftR :: RenderR a -> RenderM n a liftR = lift -runRenderM :: RenderM a -> RenderR a+runRenderM :: Typeable n => RenderM n 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+instance TypeableFloat n => Backend Rasterific V2 n where+ newtype Render Rasterific V2 n = R (RenderM n ())+ type Result Rasterific V2 n = Image PixelRGBA8+ data Options Rasterific V2 n = RasterificOptions+ { _sizeSpec :: SizeSpec V2 n -- ^ The requested size of the output }- deriving (Show)+ deriving Show renderRTree _ opts t = R.renderDrawing (round w) (round h) bgColor r where- r = runRenderM . runR . toRender $ t- (w,h) = sizePair (opts^.size)+ r = runRenderM . runR . toRender $ t+ V2 w h = specToSize 100 (opts^.sizeSpec) bgColor = PixelRGBA8 0 0 0 0 - adjustDia c opts d = adjustDia2D size c opts (d # reflectY # fontSizeO 12)+ adjustDia c opts d = adjustDia2D sizeSpec c opts (d # reflectY) -toRender :: RTree Rasterific R2 a -> Render Rasterific R2+toRender :: TypeableFloat n => RTree Rasterific V2 n a -> Render Rasterific V2 n toRender = fromRTree . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double))) . (:[])@@ -191,7 +189,7 @@ fromRTree (Node (RPrim p) _) = render Rasterific p fromRTree (Node (RStyle sty) rs) = R $ do save- accumStyle %= (<> sty)+ accumStyle <>= sty aStyle <- use accumStyle let R r = F.foldMap fromRTree rs m = evalStateStackT r (RasterificState aStyle)@@ -199,27 +197,27 @@ restore fromRTree (Node _ rs) = F.foldMap fromRTree rs -runR :: Render Rasterific R2 -> RenderM ()+runR :: Render Rasterific V2 n -> RenderM n () runR (R r) = r -instance Monoid (Render Rasterific R2) where- mempty = R $ return ()- (R rd1) `mappend` (R rd2) = R (rd1 >> rd2)+instance Monoid (Render Rasterific V2 n) 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})+instance Hashable n => Hashable (Options Rasterific V2 n) where+ hashWithSalt s (RasterificOptions sz) = s `hashWithSalt` sz -rasterificStrokeStyle :: Style v- -> (Float, R.Join, (R.Cap, R.Cap), Maybe (R.DashPattern, Float))+sizeSpec :: Lens' (Options Rasterific V2 n) (SizeSpec V2 n)+sizeSpec = lens _sizeSpec (\o s -> o {_sizeSpec = s})++rasterificStrokeStyle :: TypeableFloat n => Style v n+ -> (n, R.Join, (R.Cap, R.Cap), Maybe (R.DashPattern, n)) rasterificStrokeStyle s = (strokeWidth, strokeJoin, strokeCaps, strokeDash) where- strokeWidth = double2Float $ case getLineWidth <$> getAttr s of- Just o -> fromOutput o- _ -> 1+ strokeWidth = fromMaybe 1 $ getLineWidth <$> getAttr s strokeJoin = fromMaybe (R.JoinMiter 0) (fromLineJoin . getLineJoin <$> getAttr s) strokeCaps = (strokeCap, strokeCap)- strokeCap = fromMaybe (R.CapStraight 0) (fromLineCap . getLineCap <$> getAttr s)+ strokeCap = fromMaybe (R.CapStraight 0) (fromLineCap . getLineCap <$> getAttr s) strokeDash = fromDashing . getDashing <$> getAttr s fromLineCap :: LineCap -> R.Cap@@ -232,20 +230,23 @@ 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+fromDashing :: Real n => Dashing n -> (R.DashPattern, n)+fromDashing (Dashing ds d) = (map realToFrac ds, d) fromFillRule :: FillRule -> R.FillMethod fromFillRule EvenOdd = R.FillEvenOdd-fromFillRule _ = R.FillWinding+fromFillRule _ = R.FillWinding +getAttrN :: AttributeClass (a n) => Style v n -> Maybe (a n)+getAttrN = getAttr+ -- | Get an accumulated style attribute from the render monad state.-getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)+getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM n (Maybe b) getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle +getStyleAttribN :: AttributeClass (a n) => (a n -> b) -> RenderM n (Maybe b)+getStyleAttribN = getStyleAttrib+ rasterificColor :: SomeColor -> Double -> PixelRGBA8 rasterificColor c o = PixelRGBA8 r g b a where@@ -258,13 +259,12 @@ rasterificSpreadMethod GradReflect = R.SamplerReflect rasterificSpreadMethod GradRepeat = R.SamplerRepeat -rasterificStops :: [GradientStop] -> Gradient PixelRGBA8-rasterificStops s = map fromStop s+rasterificStops :: TypeableFloat n => [GradientStop n] -> Gradient PixelRGBA8+rasterificStops = map fromStop where- fromStop (GradientStop c v) =- (double2Float v, rasterificColor c 1)+ fromStop (GradientStop c v) = (realToFrac v, rasterificColor c 1) -rasterificLinearGradient :: LGradient -> R.Texture PixelRGBA8+rasterificLinearGradient :: TypeableFloat n => LGradient n -> R.Texture PixelRGBA8 rasterificLinearGradient g = transformTexture tr tx where tr = rasterificMatTransf (inv $ g^.lGradTrans)@@ -275,22 +275,21 @@ p1 = p2v2 (g^.lGradEnd) -rasterificRadialGradient :: RGradient -> R.Texture PixelRGBA8+rasterificRadialGradient :: TypeableFloat n => RGradient n -> R.Texture PixelRGBA8 rasterificRadialGradient g = transformTexture tr tx where tr = rasterificMatTransf (inv $ g^.rGradTrans)- tx = withSampler spreadMethod (radialGradientWithFocusTexture gradDef c r f)+ tx = withSampler spreadMethod (radialGradientWithFocusTexture gradDef c (realToFrac r1) 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)+ stopFracs = r0 / r1 : map (\s -> (r0 + (s^.stopFraction) * (r1 - r0)) / r1) (g^.rGradStops) gradStops = case g^.rGradStops of [] -> []@@ -298,70 +297,67 @@ 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 :: TypeableFloat n => Texture n -> 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 :: Real n => P2 n -> R.Point+p2v2 (P v) = r2v2 v+{-# INLINE p2v2 #-} -p2v2 :: P2 -> R.Point-p2v2 p = uncurry v2 $ unp2 p+r2v2 :: Real n => V2 n -> R.Point+r2v2 (V2 x y) = R.V2 (realToFrac x) (realToFrac y)+{-# INLINE r2v2 #-} -r2v2 :: R2 -> R.Point-r2v2 r = uncurry v2 $ unr2 r+rv2 :: (Real n, Fractional n) => Iso' R.Point (P2 n)+rv2 = iso (\(R.V2 x y) -> V2 (realToFrac x) (realToFrac y)) r2v2 . from _Point+{-# INLINE rv2 #-} -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+rasterificPtTransf :: TypeableFloat n => T2 n -> R.Point -> R.Point+rasterificPtTransf t = over rv2 (papply t) -rasterificMatTransf :: T2 -> R.Transformation+rasterificMatTransf :: TypeableFloat n => T2 n -> R.Transformation rasterificMatTransf tr = R.Transformation a c e b d f where- [[a, b], [c, d], [e, f]] = (map . map) double2Float (matrixHomRep tr)+ [[a, b], [c, d], [e, f]] = map realToFrac <$> 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 :: TypeableFloat n => Located (Segment Closed V2 n) -> R.Primitive renderSeg l = case viewLoc l of- (p, (Linear (OffsetClosed v))) ->+ (p, Linear (OffsetClosed v)) -> R.LinePrim $ R.Line p' (p' + r2v2 v) where p' = p2v2 p- (p, (Cubic u1 u2 (OffsetClosed u3))) ->+ (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 :: TypeableFloat n => Path V2 n -> [[R.Primitive]] renderPath p = (map . map) renderSeg (pathLocSegments p) -clip :: Style v -> RenderR () -> RenderM ()+clip :: TypeableFloat n => Style V2 n -> RenderR () -> RenderM n () clip sty d = maybe (liftR d) (\paths -> liftR $ R.withClipping- (R.fill (concat . concat $ (map renderPath paths))) d)- (op Clip <$> getAttr sty)+ (R.fill (concat . concat $ map renderPath paths)) d)+ (op Clip <$> getAttrN sty) -- Stroke both dashed and solid lines.-mkStroke :: Float -> R.Join -> (R.Cap, R.Cap) -> Maybe (R.DashPattern, Float)+mkStroke :: TypeableFloat n => n -> R.Join -> (R.Cap, R.Cap) -> Maybe (R.DashPattern, n) -> [[R.Primitive]] -> RenderR ()-mkStroke l j c d primList =+mkStroke (realToFrac -> l) j c d primList = maybe (mapM_ (R.stroke l j c) primList)- (\(dsh, off) -> mapM_ (R.dashedStrokeWithOffset off dsh l j c) primList)+ (\(dsh, off) -> mapM_ (R.dashedStrokeWithOffset (realToFrac off) dsh l j c) primList) d -instance Renderable (Path R2) Rasterific where+instance TypeableFloat n => Renderable (Path V2 n) Rasterific where render _ p = R $ do- f <- getStyleAttrib getFillTexture- s <- fromMaybe (SC (SomeColor (black :: Colour Double))) - <$> getStyleAttrib getLineTexture+ f <- getStyleAttribN getFillTexture+ s <- fromMaybe (solid black) <$> getStyleAttribN getLineTexture o <- fromMaybe 1 <$> getStyleAttrib getOpacity r <- fromMaybe Winding <$> getStyleAttrib getFillRule sty <- use accumStyle@@ -386,22 +382,22 @@ openSansRegular :: Font openSansRegular = fnt where- Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-Regular.ttf")+ Right fnt = unsafePerformIO . loadFontFile $ ro "fonts/OpenSans-Regular.ttf" openSansBold :: Font openSansBold = fnt where- Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-Bold.ttf")+ Right fnt = unsafePerformIO . loadFontFile $ ro "fonts/OpenSans-Bold.ttf" openSansItalic :: Font openSansItalic = fnt where- Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-Italic.ttf")+ Right fnt = unsafePerformIO . loadFontFile $ ro "fonts/OpenSans-Italic.ttf" openSansBoldItalic :: Font openSansBoldItalic = fnt where- Right fnt = unsafePerformIO . loadFontFile $ (ro "fonts/OpenSans-BoldItalic.ttf")+ Right fnt = unsafePerformIO . loadFontFile $ ro "fonts/OpenSans-BoldItalic.ttf" fromFontStyle :: FontSlant -> FontWeight -> Font fromFontStyle FontSlantItalic FontWeightBold = openSansBoldItalic@@ -411,43 +407,39 @@ fromFontStyle FontSlantOblique FontWeightNormal = openSansItalic fromFontStyle _ _ = openSansRegular -textBox :: Font -> R.PointSize -> String -> (Double, Double)-textBox f ps str = (float2Double w, float2Double h)+textBox :: Font -> R.PointSize -> String -> (Float, Float)+textBox f p s = (_xMax bb - _xMin bb, _yMax bb - _yMin bb) where- bb = stringBoundingBox f 96 ps str- (w, h) = (_xMax bb - _xMin bb, _yMax bb - _yMin bb)+ bb = stringBoundingBox f 96 p s -instance Renderable Text Rasterific where- render _ (Text tt tn al str) = R $ do- isLocal <- fromMaybe True <$> getStyleAttrib getFontSizeIsLocal- fs <- fromMaybe 12 <$> getStyleAttrib (fromOutput . getFontSize)+instance TypeableFloat n => Renderable (Text n) Rasterific where+ render _ (Text tr al str) = R $ do+ fs <- fromMaybe 12 <$> getStyleAttribN getFontSize slant <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant fw <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight- f <- fromMaybe (SC (SomeColor (black :: Colour Double))) - <$> getStyleAttrib getFillTexture+ f <- fromMaybe (solid black) <$> getStyleAttribN getFillTexture o <- fromMaybe 1 <$> getStyleAttrib getOpacity let fColor = rasterificTexture f o- fs' = R.PointSize . double2Float $ fs- fnt = fromFontStyle slant fw- (x, y) = textBox fnt fs' str+ fs' = R.PointSize (realToFrac 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)+ BaselineText -> (0, 0)+ BoxAlignedText xt yt -> (x * realToFrac xt, -y * realToFrac yt)+ 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 (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 (ImageCMYK8 i) = promoteImage (convertImage i :: Image PixelRGB8) toImageRGBA8 _ = error "Unsupported Pixel type" -instance Renderable (DImage Embedded) Rasterific where+instance TypeableFloat n => Renderable (DImage n Embedded) Rasterific where render _ (DImage iD w h tr) = R $ liftR (R.withTransformation (rasterificMatTransf (tr <> reflectionY))@@ -455,22 +447,27 @@ where ImageRaster dImg = iD img = toImageRGBA8 dImg- trl = moveOriginBy (r2 ((fromIntegral w / 2), (fromIntegral h / 2))) mempty - p = rasterificPtTransf trl (R.V2 0 0)+ trl = moveOriginBy (r2 (fromIntegral w / 2, fromIntegral h / 2 :: n)) mempty+ p = rasterificPtTransf trl (R.V2 0 0) -writeJpeg :: Word8 -> FilePath -> Result Rasterific R2 -> IO ()+-- | Render a 'Rasterific' diagram to a jpeg file with given quality+-- (between 0 and 100).+writeJpeg :: Word8 -> FilePath -> Result Rasterific V2 n -> 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+-- | Render a 'Rasterific' diagram to a file with the given size. The+-- format is determined by the extension (@.png@, @.tif@, @.bmp@ and+-- @.jpg@ supported. (jpeg quality is 80, use 'writeJpeg' to choose+-- quality).+renderRasterific :: TypeableFloat n => FilePath -> SizeSpec V2 n -> QDiagram Rasterific V2 n Any -> IO ()+renderRasterific outFile spec 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+ ".png" -> writePng+ ".tif" -> writeTiff+ ".bmp" -> writeBitmap+ ".jpg" -> writeJpeg 80+ _ -> writePng+ img = renderDia Rasterific (RasterificOptions spec) d
src/Diagrams/Backend/Rasterific/CmdLine.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- |@@ -76,102 +76,47 @@ , B ) where -import Diagrams.Prelude hiding (width, height, interval- ,option, (<>))-import Diagrams.Backend.Rasterific import Diagrams.Backend.CmdLine+import Diagrams.Backend.Rasterific+import Diagrams.Prelude hiding (height, interval, option,+ output, width, (<>)) import Codec.Picture-import Codec.Picture.Types (dropTransparency)-import Codec.Picture.ColorQuant (defaultPaletteOptions)+import Codec.Picture.ColorQuant (defaultPaletteOptions)+import Codec.Picture.Types (dropTransparency) -import qualified Data.ByteString.Lazy as L (ByteString, writeFile)+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 :: Diagram Rasterific -> 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)+instance TypeableFloat n => Mainable (QDiagram Rasterific V2 n Any) where+ type MainOpts (QDiagram Rasterific V2 n Any) = (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+ defaultLoopRender loopOpts -chooseRender :: DiagramOpts -> Diagram Rasterific R2 -> IO ()+chooseRender :: TypeableFloat n => DiagramOpts -> QDiagram Rasterific V2 n Any -> 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)- )+ (fromIntegral <$> mkSizeSpec2D (opts^.width) (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+ "jpg" -> writeJpeg 80 (opts^.output) img _ -> writePng (opts^.output) img | otherwise -> putStrLn $ "Unknown file type: " ++ last ps @@ -194,12 +139,12 @@ -- $ ./MultiTest --selection bar -o Bar.png -w 200 -- @ -multiMain :: [(String, Diagram Rasterific R2)] -> IO ()+multiMain :: [(String, Diagram Rasterific)] -> IO () multiMain = mainWith -instance Mainable [(String,Diagram Rasterific R2)] where- type MainOpts [(String,Diagram Rasterific R2)]- = (MainOpts (Diagram Rasterific R2), DiagramMultiOpts)+instance TypeableFloat n => Mainable [(String,QDiagram Rasterific V2 n Any)] where+ type MainOpts [(String,QDiagram Rasterific V2 n Any)]+ = (MainOpts (QDiagram Rasterific V2 n Any), DiagramMultiOpts) mainRender = defaultMultiMainRender @@ -219,71 +164,22 @@ -- -- 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 :: Animation Rasterific V2 Double -> IO () animMain = mainWith -instance Mainable (Animation Rasterific R2) where- type MainOpts (Animation Rasterific R2) =- (MainOpts (Diagram Rasterific R2), DiagramAnimOpts)+instance TypeableFloat n => Mainable (Animation Rasterific V2 n) where+ type MainOpts (Animation Rasterific V2 n) =+ ((DiagramOpts, DiagramAnimOpts), DiagramLoopOpts) - mainRender = defaultAnimMainRender output'+ mainRender (opts, l) d = defaultAnimMainRender chooseRender output opts d >> defaultLoopRender l -#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 :: [(Diagram Rasterific, GifDelay)] -> IO () gifMain = mainWith -- | Extra options for animated GIFs.-data GifOpts = GifOpts { _dither :: Bool- , _noLooping :: Bool+data GifOpts = GifOpts { _dither :: Bool+ , _noLooping :: Bool , _loopRepeat :: Maybe Int} makeLenses ''GifOpts@@ -304,13 +200,13 @@ ( long "loop-repeat" <> help "Number of times to repeat" ) -instance Mainable [(Diagram Rasterific R2, GifDelay)] where- type MainOpts [(Diagram Rasterific R2, GifDelay)] = (DiagramOpts, GifOpts)+instance TypeableFloat n => Mainable [(QDiagram Rasterific V2 n Any, GifDelay)] where+ type MainOpts [(QDiagram Rasterific V2 n Any, GifDelay)] = (DiagramOpts, GifOpts) - mainRender (dOpts, gOpts) ds = gifRender (dOpts, gOpts) ds+ mainRender = gifRender encodeGifAnimation' :: [GifDelay] -> GifLooping -> Bool- -> [Image PixelRGB8] -> Either String (L.ByteString)+ -> [Image PixelRGB8] -> Either String L.ByteString encodeGifAnimation' delays looping dithering lst = encodeGifImages looping triples where@@ -324,7 +220,7 @@ writeGifAnimation' path delays looping dithering img = L.writeFile path <$> encodeGifAnimation' delays looping dithering img -gifRender :: (DiagramOpts, GifOpts) -> [(Diagram Rasterific R2, GifDelay)] -> IO ()+gifRender :: TypeableFloat n => (DiagramOpts, GifOpts) -> [(QDiagram Rasterific V2 n Any, GifDelay)] -> IO () gifRender (dOpts, gOpts) lst = case splitOn "." (dOpts^.output) of [""] -> putStrLn "No output file given"@@ -336,9 +232,8 @@ Just n -> LoopingRepeat (fromIntegral n) dias = map fst lst delays = map snd lst- sizeSpec = mkSizeSpec (fromIntegral <$> dOpts^.width)- (fromIntegral <$> dOpts^.height)- opts = RasterificOptions sizeSpec+ spec = fromIntegral <$> mkSizeSpec2D (dOpts^.width) (dOpts^.height)+ opts = RasterificOptions spec imageRGB8s = map (pixelMap dropTransparency . renderDia Rasterific opts) dias result = writeGifAnimation' (dOpts^.output) delays@@ -347,4 +242,4 @@ case result of Left s -> putStrLn s Right io -> io- | otherwise -> putStrLn $ "File name must end with .gif"+ | otherwise -> putStrLn "File name must end with .gif"