diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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)* diff --git a/CHANGES.md b/CHANGES.md deleted file mode 100644 --- a/CHANGES.md +++ /dev/null @@ -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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,12 @@ Copyright (c) 2014 diagrams-rasterific team: + Daniel Bergey Vincent Berthoux + Christopher Chalmers + Anthony Cowley Jeffrey Rosenbluth + Ryan Scott + Ryan Yates Brent Yorgey All rights reserved. diff --git a/diagrams-rasterific.cabal b/diagrams-rasterific.cabal --- a/diagrams-rasterific.cabal +++ b/diagrams-rasterific.cabal @@ -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 diff --git a/src/Diagrams/Backend/Rasterific.hs b/src/Diagrams/Backend/Rasterific.hs --- a/src/Diagrams/Backend/Rasterific.hs +++ b/src/Diagrams/Backend/Rasterific.hs @@ -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 diff --git a/src/Diagrams/Backend/Rasterific/CmdLine.hs b/src/Diagrams/Backend/Rasterific/CmdLine.hs --- a/src/Diagrams/Backend/Rasterific/CmdLine.hs +++ b/src/Diagrams/Backend/Rasterific/CmdLine.hs @@ -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"