diff --git a/Chart-diagrams.cabal b/Chart-diagrams.cabal --- a/Chart-diagrams.cabal +++ b/Chart-diagrams.cabal @@ -1,15 +1,15 @@ Name: Chart-diagrams -Version: 1.1 +Version: 1.9.5.1 License: BSD3 License-file: LICENSE -Copyright: Jan Bracker, 2006-2010 +Copyright: Jan Bracker, 2006-2014 Author: Jan Bracker Maintainer: Jan Bracker Homepage: https://github.com/timbod7/haskell-chart/wiki Synopsis: Diagrams backend for Charts. Description: Diagrams backend for Charts. Category: Graphics -Cabal-Version: >= 1.6 +Cabal-Version: 1.18 Build-Type: Simple data-files: fonts/LinLibertine_R.svg @@ -25,23 +25,26 @@ library + default-language: Haskell98 Build-depends: base >= 3 && < 5 - , old-locale - , time, mtl - , diagrams-core >= 0.7 && < 0.8 - , diagrams-lib >= 0.7 && < 0.8 - , diagrams-svg >= 0.8 && < 0.9 - , diagrams-postscript >= 0.7 && < 0.8 - , SVGFonts >= 1.4 && < 1.5 + , old-locale >= 1.0.0 && < 1.1 + , time >= 1.12 && < 1.13 + , diagrams-core >= 1.3 && < 1.6 + , diagrams-lib >= 1.2 && < 1.5 + , diagrams-svg >= 1.4 && < 1.5 + , diagrams-postscript >= 0.7 && < 1.6 + , SVGFonts >= 1.8 && < 1.9 , colour >= 2.2.1 && < 2.4 - , blaze-svg >= 0.3.3 + , blaze-markup >= 0.7 && < 0.9 + , svg-builder >= 0.1 && < 0.2 , bytestring >= 0.9 && < 1.0 , operational >= 0.2.2 && < 0.3 - , containers >= 0.4 && < 0.6 - , data-default-class < 0.1 - , lens >= 3.9 && < 3.11 - , Chart >= 1.1 && < 1.2 - , text + , containers >= 0.4 && < 0.8 + , data-default-class < 0.2 + , lens >= 3.9 && < 5.3 + , mtl >= 2.0 && < 2.4 + , Chart >= 1.9 && < 1.10 + , text >= 2.0 && < 2.2 other-modules: Paths_Chart_diagrams Exposed-modules: Graphics.Rendering.Chart.Backend.Diagrams diff --git a/Graphics/Rendering/Chart/Backend/Diagrams.hs b/Graphics/Rendering/Chart/Backend/Diagrams.hs --- a/Graphics/Rendering/Chart/Backend/Diagrams.hs +++ b/Graphics/Rendering/Chart/Backend/Diagrams.hs @@ -1,44 +1,34 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} -- | The backend to render charts with the diagrams library. module Graphics.Rendering.Chart.Backend.Diagrams ( runBackend , runBackendR + , runBackendWithGlyphs , defaultEnv - , customFontEnv - , DEnv(..), DFont + , createEnv + , DEnv(..) -- * File Output Functons , FileFormat(..) , FileOptions(..) , fo_size , fo_format - , fo_customFonts + , fo_fonts , renderableToFile + , toFile , cBackendToFile - -- * EPS Utility Functions - , cBackendToEPSFile - , renderableToEPSFile -- deprecated - , renderableToEPSFile' -- deprecated - - -- * SVG Utility Functions - , cBackendToSVG - , cBackendToEmbeddedFontSVG - , renderableToSVG - , renderableToSVG' - , renderableToSVGFile -- deprecated - , renderableToSVGFile' -- deprecated - , renderableToSVGString - , renderableToSVGString' - - -- * SVG Embedded Font Utility Functions - , renderableToEmbeddedFontSVG - , renderableToEmbeddedFontSVG' - , renderableToEmbeddedFontSVGFile -- deprecated - , renderableToEmbeddedFontSVGFile' -- deprecated + -- * Fonts + , loadSansSerifFonts + , loadCommonFonts + , FontSelector + ) where import Data.Default.Class @@ -52,29 +42,38 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Text as T +#if MIN_VERSION_diagrams_postscript(1,5,0) +import qualified Data.ByteString.Builder as B +import System.IO (IOMode (..), hPutStr, withFile) +#endif + import Control.Lens(makeLenses) import Control.Monad.Operational import Control.Monad.State.Lazy +import Control.Monad import Diagrams.Core.Transform ( Transformation(..) ) -import Diagrams.Prelude +import Diagrams.Prelude ( Diagram - , R2, P2, T2 + , V2, P2, T2 , r2, p2, unr2, unp2 + , rad, (@@) , Trail(..), Segment - , Rad(..), CircleFrac(..) , (.+^), (<->), (~~) ) import qualified Diagrams.Prelude as D import qualified Diagrams.TwoD as D2 +import Diagrams (N, V) +import Diagrams.TwoD (V2) import qualified Diagrams.TwoD.Arc as D2 import qualified Diagrams.TwoD.Text as D2 import qualified Diagrams.Backend.Postscript as DEPS import qualified Diagrams.Backend.SVG as DSVG -import Text.Blaze.Svg.Renderer.Utf8 ( renderSvg ) -import qualified Text.Blaze.Svg11 as Svg +import qualified Graphics.Svg as Svg +import qualified Text.Blaze.Renderer.Text as B +import qualified Graphics.SVGFonts as F import qualified Graphics.SVGFonts.CharReference as F import qualified Graphics.SVGFonts.ReadFont as F import Graphics.SVGFonts.WriteFont ( makeSvgFont ) @@ -85,9 +84,12 @@ import Graphics.Rendering.Chart.Geometry as G import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.State(EC, execEC) import Paths_Chart_diagrams ( getDataFileName ) +import System.IO.Unsafe (unsafePerformIO) + -- ----------------------------------------------------------------------- -- General purpose file output function -- ----------------------------------------------------------------------- @@ -104,212 +106,122 @@ data FileOptions = FileOptions { _fo_size :: (Double,Double), _fo_format :: FileFormat, - _fo_customFonts :: M.Map (String, FontSlant, FontWeight) FilePath + _fo_fonts :: IO (FontSelector Double) } +instance Default FileOptions where + def = FileOptions (800,600) SVG loadSansSerifFonts + -- | Generate an image file for the given renderable, at the specified path. Size, format, -- and text rendering mode are all set through the `FileOptions` parameter. -renderableToFile :: FileOptions -> Renderable a -> FilePath -> IO (PickFn a) -renderableToFile fo r path = cBackendToFile fo cb path +renderableToFile :: FileOptions -> FilePath -> Renderable a -> IO (PickFn a) +renderableToFile fo path r = cBackendToFile fo cb path where cb = render r (_fo_size fo) +-- | Generate an image file from from the state content of an EC +-- computation. The state may have any type that is an instance of +-- `ToRenderable` +toFile :: (Default r,ToRenderable r) => FileOptions -> FilePath -> EC r () -> IO () +toFile fo path ec = void $ renderableToFile fo path (toRenderable (execEC ec)) + -- | Generate an image file for the given drawing instructions, at the specified path. Size and -- format are set through the `FileOptions` parameter. -cBackendToFile :: FileOptions -> ChartBackend a -> FilePath -> IO a +cBackendToFile :: FileOptions -> BackendProgram a -> FilePath -> IO a cBackendToFile fo cb path = do - env <- customFontEnv vectorAlignmentFns w h (_fo_customFonts fo) - case _fo_format fo of - EPS -> do - cBackendToEPSFile cb env path - SVG -> do - let (svg, a) = cBackendToSVG cb env - BS.writeFile path (renderSvg svg) - return a - SVG_EMBEDDED -> do - let (svg,a) = cBackendToEmbeddedFontSVG cb env - BS.writeFile path (renderSvg svg) - return a + fontSelector <- _fo_fonts fo + let env = createEnv vectorAlignmentFns w h fontSelector + + case _fo_format fo of + EPS -> do + let (d, a) = runBackend env cb + opts = DEPS.PostscriptOptions path (D2.dims2D w h) DEPS.EPS +#if MIN_VERSION_diagrams_postscript(1,5,0) + eps = D.renderDia DEPS.Postscript opts d + withFile (opts D.^. DEPS.psfileName) WriteMode $ \h -> + B.hPutBuilder h eps +#else + D.renderDia DEPS.Postscript opts d +#endif + return a + SVG -> do + let (d, a) = runBackend env cb + opts = DSVG.SVGOptions (D2.dims2D w h) Nothing T.empty [] True + svg = D.renderDia DSVG.SVG opts d + Svg.renderToFile path svg + return a + SVG_EMBEDDED -> do + let + (d, a, gs) = runBackendWithGlyphs env cb + fontDefs = Just . Svg.toElement . B.renderMarkup + $ forM_ (M.toList gs) $ \((fFam, fSlant, fWeight), usedGs) -> do + let fs = envFontStyle env + let font = envSelectFont env $ fs { _font_name = fFam + , _font_slant = fSlant + , _font_weight = fWeight + } + makeSvgFont font usedGs + svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.dims2D w h) fontDefs T.empty [] True) d + Svg.renderToFile path svg + return a where (w,h) = _fo_size fo -- ----------------------------------------------------------------------- --- SVG Utility Functions +-- Backend -- ----------------------------------------------------------------------- --- | Output the given renderable to a SVG file of the specifed size --- (in points), to the specified file using the default environment. -{-# DEPRECATED renderableToSVGFile "use renderToFile" #-} -renderableToSVGFile :: Renderable a -> Double -> Double -> FilePath -> IO (PickFn a) -renderableToSVGFile r w h file = do - (svg, x) <- renderableToSVGString r w h - BS.writeFile file svg - return x +-- | The diagrams backend environement. +data DEnv n = DEnv + { envAlignmentFns :: AlignmentFns -- ^ The used alignment functions. + , envFontStyle :: FontStyle -- ^ The current/initial font style. + , envSelectFont :: FontSelector n -- ^ The font selection function. + , envOutputSize :: (n,n) -- ^ The size of the rendered output. + , envUsedGlyphs :: M.Map (String, FontSlant, FontWeight) (S.Set String) + -- ^ The map of all glyphs that are used from a specific font. + } --- | Output the given renderable to a SVG file using the given environment. -{-# DEPRECATED renderableToSVGFile' "use renderToFile" #-} -renderableToSVGFile' :: Renderable a -> DEnv -> FilePath -> IO (PickFn a) -renderableToSVGFile' r env file = do - let (svg, x) = renderableToSVGString' r env - BS.writeFile file svg - return x +type DState n a = State (DEnv n) a --- | Output the given renderable to a string containing a SVG of the specifed size --- (in points) using the default environment. -renderableToSVGString :: Renderable a -> Double -> Double -> IO (BS.ByteString, PickFn a) -renderableToSVGString r w h = do - (svg, x) <- renderableToSVG r w h - return (renderSvg svg, x) +type FontSelector n = FontStyle -> F.PreparedFont n --- | Output the given renderable to a string containing a SVG using the given environment. -renderableToSVGString' :: Renderable a -> DEnv -> (BS.ByteString, PickFn a) -renderableToSVGString' r env = - let (svg, x) = renderableToSVG' r env - in (renderSvg svg, x) +-- | Load sans-serif fonts only --- | Output the given renderable as a SVG of the specifed size --- (in points) using the default environment. +loadSansSerifFonts :: forall n. (RealFloat n, Read n) + => IO (FontSelector n) +loadSansSerifFonts = do + sansR <- getDataFileName "fonts/SourceSansPro_R.svg" >>= F.loadFont + sansRB <- getDataFileName "fonts/SourceSansPro_RB.svg" >>= F.loadFont + sansRBI <- getDataFileName "fonts/SourceSansPro_RBI.svg" >>= F.loadFont + sansRI <- getDataFileName "fonts/SourceSansPro_RI.svg" >>= F.loadFont -renderableToSVG :: Renderable a -> Double -> Double -> IO (Svg.Svg, PickFn a) -renderableToSVG r w h = do - env <- defaultEnv vectorAlignmentFns w h - return $ renderableToSVG' r env + let selectFont :: FontStyle -> F.PreparedFont n + selectFont fs = case (_font_name fs, _font_slant fs, _font_weight fs) of + (_, FontSlantNormal , FontWeightNormal) -> alterFontFamily "sans-serif" sansR + (_, FontSlantNormal , FontWeightBold ) -> alterFontFamily "sans-serif" sansRB + (_, FontSlantItalic , FontWeightNormal) -> alterFontFamily "sans-serif" sansRI + (_, FontSlantOblique, FontWeightNormal) -> alterFontFamily "sans-serif" sansRI + (_, FontSlantItalic , FontWeightBold ) -> alterFontFamily "sans-serif" sansRBI + (_, FontSlantOblique, FontWeightBold ) -> alterFontFamily "sans-serif" sansRBI --- | Output the given renderable as a SVG using the given environment. -renderableToSVG' :: Renderable a -> DEnv -> (Svg.Svg, PickFn a) -renderableToSVG' r env = - let (w, h) = envOutputSize env - (d, x) = runBackendR env r - svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.Dims w h) Nothing) d - in (svg, x) + return selectFont --- ----------------------------------------------------------------------- --- SVG Embedded Font Utility Functions --- ----------------------------------------------------------------------- --- | Output the given renderable to a SVG file of the specifed size --- (in points), to the specified file using the default environment. --- Font are embedded to save space. -{-# DEPRECATED renderableToEmbeddedFontSVGFile "use renderToFile" #-} -renderableToEmbeddedFontSVGFile :: Renderable a -> Double -> Double -> FilePath -> IO (PickFn a) -renderableToEmbeddedFontSVGFile r w h file = do - (svg, x) <- renderableToEmbeddedFontSVG r w h - BS.writeFile file $ renderSvg svg - return x - --- | Output the given renderable to a SVG file using the given environment. --- Font are embedded to save space. -{-# DEPRECATED renderableToEmbeddedFontSVGFile' "use renderToFile" #-} -renderableToEmbeddedFontSVGFile' :: Renderable a -> DEnv -> FilePath -> IO (PickFn a) -renderableToEmbeddedFontSVGFile' r env file = do - let (svg, x) = renderableToEmbeddedFontSVG' r env - BS.writeFile file $ renderSvg svg - return x - --- | Output the given renderable as a SVG of the specifed size --- (in points) using the default environment. --- Font are embedded to save space. -renderableToEmbeddedFontSVG :: Renderable a -> Double -> Double -> IO (Svg.Svg, PickFn a) -renderableToEmbeddedFontSVG r w h = do - env <- defaultEnv vectorAlignmentFns w h - return $ renderableToEmbeddedFontSVG' r env - --- | Output the given renderable as a SVG using the given environment. --- Font are embedded to save space. -renderableToEmbeddedFontSVG' :: Renderable a -> DEnv -> (Svg.Svg,PickFn a) -renderableToEmbeddedFontSVG' r env = cBackendToEmbeddedFontSVG (render r size) env - where - size = envOutputSize env - -cBackendToEPSFile :: ChartBackend a -> DEnv -> FilePath -> IO a -cBackendToEPSFile cb env path = do - let (w, h) = envOutputSize env - (d, a) = runBackend env cb - psOpts = DEPS.PostscriptOptions path (D2.Dims w h) DEPS.EPS - D.renderDia DEPS.Postscript psOpts d - return a - -cBackendToSVG :: ChartBackend a -> DEnv -> (Svg.Svg,a) -cBackendToSVG cb env = (svg,a) - where - (w, h) = envOutputSize env - (d, a) = runBackend env cb - svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.Dims w h) Nothing) d - -cBackendToEmbeddedFontSVG :: ChartBackend a -> DEnv -> (Svg.Svg,a) -cBackendToEmbeddedFontSVG cb env = (svg, x) - where - (w, h) = envOutputSize env - (d, x, gs) = runBackendWithGlyphs env cb - fontDefs = Just $ forM_ (M.toList gs) $ \((fFam, fSlant, fWeight), usedGs) -> do - let fs = envFontStyle env - let font = envSelectFont env $ fs { _font_name = fFam - , _font_slant = fSlant - , _font_weight = fWeight - } - makeSvgFont font usedGs - -- M.Map (String, FontSlant, FontWeight) (S.Set String) - -- makeSvgFont :: (FontData, OutlineMap) -> Set.Set String -> S.Svg - svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.Dims w h) fontDefs) d - --- ----------------------------------------------------------------------- --- EPS Utility Functions --- ----------------------------------------------------------------------- - --- | Output the given renderable to a EPS file using the default environment. -{-# DEPRECATED renderableToEPSFile "use renderToFile" #-} -renderableToEPSFile :: Renderable a -> Double -> Double -> FilePath -> IO (PickFn a) -renderableToEPSFile r w h file = do - env <- defaultEnv vectorAlignmentFns w h - renderableToEPSFile' r env file - --- | Output the given renderable to a EPS file using the given environment. -{-# DEPRECATED renderableToEPSFile' "use renderToFile" #-} -renderableToEPSFile' :: Renderable a -> DEnv -> FilePath -> IO (PickFn a) -renderableToEPSFile' r env file = do - let (w, h) = envOutputSize env - let (d, x) = runBackendR env r - let psOpts = DEPS.PostscriptOptions - file - (D2.Dims w h) - DEPS.EPS - D.renderDia DEPS.Postscript psOpts d - return x - - --- ----------------------------------------------------------------------- --- Backend --- ----------------------------------------------------------------------- - --- | The diagrams backend environement. -data DEnv = DEnv - { envAlignmentFns :: AlignmentFns -- ^ The used alignment functions. - , envFontStyle :: FontStyle -- ^ The current/initial font style. - , envSelectFont :: FontStyle -> DFont -- ^ The font selection function. - , envOutputSize :: (Double, Double) -- ^ The size of the rendered output. - , envUsedGlyphs :: M.Map (String, FontSlant, FontWeight) (S.Set String) - -- ^ The map of all glyphs that are used from a specific font. - } - --- | A font a delivered by SVGFonts. -type DFont = (F.FontData, F.OutlineMap) - -type DState a = State DEnv a +-- | Load serif, sans-serif and monospace fonts. +loadCommonFonts :: forall n. (RealFloat n, Read n) => IO (FontSelector n) +loadCommonFonts = do + serifR <- getDataFileName "fonts/LinLibertine_R.svg" >>= F.loadFont + serifRB <- getDataFileName "fonts/LinLibertine_RB.svg" >>= F.loadFont + serifRBI <- getDataFileName "fonts/LinLibertine_RBI.svg" >>= F.loadFont + serifRI <- getDataFileName "fonts/LinLibertine_RI.svg" >>= F.loadFont + sansR <- getDataFileName "fonts/SourceSansPro_R.svg" >>= F.loadFont + sansRB <- getDataFileName "fonts/SourceSansPro_RB.svg" >>= F.loadFont + sansRBI <- getDataFileName "fonts/SourceSansPro_RBI.svg" >>= F.loadFont + sansRI <- getDataFileName "fonts/SourceSansPro_RI.svg" >>= F.loadFont + monoR <- getDataFileName "fonts/SourceCodePro_R.svg" >>= F.loadFont + monoRB <- getDataFileName "fonts/SourceCodePro_RB.svg" >>= F.loadFont -defaultFonts :: IO (FontStyle -> DFont) -defaultFonts = do - serifR <- loadDefaultFont "fonts/LinLibertine_R.svg" - serifRB <- loadDefaultFont "fonts/LinLibertine_RB.svg" - serifRBI <- loadDefaultFont "fonts/LinLibertine_RBI.svg" - serifRI <- loadDefaultFont "fonts/LinLibertine_RI.svg" - sansR <- loadDefaultFont "fonts/SourceSansPro_R.svg" - sansRB <- loadDefaultFont "fonts/SourceSansPro_RB.svg" - sansRBI <- loadDefaultFont "fonts/SourceSansPro_RBI.svg" - sansRI <- loadDefaultFont "fonts/SourceSansPro_RI.svg" - monoR <- loadDefaultFont "fonts/SourceCodePro_R.svg" - monoRB <- loadDefaultFont "fonts/SourceCodePro_RB.svg" - - let selectFont :: FontStyle -> DFont + let selectFont :: FontStyle -> F.PreparedFont n selectFont fs = case (_font_name fs, _font_slant fs, _font_weight fs) of ("serif", FontSlantNormal , FontWeightNormal) -> alterFontFamily "serif" serifR ("serif", FontSlantNormal , FontWeightBold ) -> alterFontFamily "serif" serifRB @@ -317,120 +229,120 @@ ("serif", FontSlantOblique, FontWeightNormal) -> alterFontFamily "serif" serifRI ("serif", FontSlantItalic , FontWeightBold ) -> alterFontFamily "serif" serifRBI ("serif", FontSlantOblique, FontWeightBold ) -> alterFontFamily "serif" serifRBI - + ("sans-serif", FontSlantNormal , FontWeightNormal) -> alterFontFamily "sans-serif" sansR ("sans-serif", FontSlantNormal , FontWeightBold ) -> alterFontFamily "sans-serif" sansRB ("sans-serif", FontSlantItalic , FontWeightNormal) -> alterFontFamily "sans-serif" sansRI ("sans-serif", FontSlantOblique, FontWeightNormal) -> alterFontFamily "sans-serif" sansRI ("sans-serif", FontSlantItalic , FontWeightBold ) -> alterFontFamily "sans-serif" sansRBI ("sans-serif", FontSlantOblique, FontWeightBold ) -> alterFontFamily "sans-serif" sansRBI - + ("monospace", _, FontWeightNormal) -> alterFontFamily "monospace" monoR ("monospace", _, FontWeightBold ) -> alterFontFamily "monospace" monoRB - + (fam, FontSlantNormal , FontWeightNormal) | fam `isFontFamily` serifR -> serifR (fam, FontSlantNormal , FontWeightBold ) | fam `isFontFamily` serifRB -> serifRB (fam, FontSlantItalic , FontWeightNormal) | fam `isFontFamily` serifRI -> serifRI (fam, FontSlantOblique, FontWeightNormal) | fam `isFontFamily` serifRI -> serifRI (fam, FontSlantItalic , FontWeightBold ) | fam `isFontFamily` serifRBI -> serifRBI (fam, FontSlantOblique, FontWeightBold ) | fam `isFontFamily` serifRBI -> serifRBI - + (fam, FontSlantNormal , FontWeightNormal) | fam `isFontFamily` sansR -> sansR (fam, FontSlantNormal , FontWeightBold ) | fam `isFontFamily` sansRB -> sansRB (fam, FontSlantItalic , FontWeightNormal) | fam `isFontFamily` sansRI -> sansRI (fam, FontSlantOblique, FontWeightNormal) | fam `isFontFamily` sansRI -> sansRI (fam, FontSlantItalic , FontWeightBold ) | fam `isFontFamily` sansRBI -> sansRBI (fam, FontSlantOblique, FontWeightBold ) | fam `isFontFamily` sansRBI -> sansRBI - + (fam, _, FontWeightNormal) | fam `isFontFamily` monoR -> monoR (fam, _, FontWeightBold ) | fam `isFontFamily` monoRB -> monoRB - + (_, slant, weight) -> selectFont (fs { _font_name = "sans-serif" }) - + return selectFont -alterFontFamily :: String -> DFont -> DFont + +alterFontFamily :: String -> F.PreparedFont n -> F.PreparedFont n alterFontFamily n (fd, om) = (fd { F.fontDataFamily = n }, om) -isFontFamily :: String -> DFont -> Bool +isFontFamily :: String -> F.PreparedFont n -> Bool isFontFamily n (fd, _) = n == F.fontDataFamily fd - -loadDefaultFont :: FilePath -> IO DFont -loadDefaultFont file = getDataFileName file >>= return . F.outlMap -loadFont :: FilePath -> IO DFont -loadFont = return . F.outlMap - -- | Produce an environment with a custom set of fonts. -- The defult fonts are still loaded as fall back. -customFontEnv :: AlignmentFns -- ^ Alignment functions to use. - -> Double -- ^ The output image width in backend coordinates. - -> Double -- ^ The output image height in backend coordinates. - -> M.Map (String, FontSlant, FontWeight) FilePath -> IO DEnv -customFontEnv alignFns w h fontFiles = do - fonts <- traverse loadFont fontFiles - selectFont <- defaultFonts - return $ DEnv +createEnv :: (Read n, RealFloat n) + => AlignmentFns -- ^ Alignment functions to use. + -> n -- ^ The output image width in backend coordinates. + -> n -- ^ The output image height in backend coordinates. + -> FontSelector n -> DEnv n +createEnv alignFns w h fontSelector = DEnv { envAlignmentFns = alignFns , envFontStyle = def - , envSelectFont = \fs -> - case M.lookup (_font_name fs, _font_slant fs, _font_weight fs) fonts of - Just font -> font - Nothing -> selectFont fs + , envSelectFont = fontSelector , envOutputSize = (w,h) , envUsedGlyphs = M.empty } --- | Produce a default environment with the default fonts. -defaultEnv :: AlignmentFns -- ^ Alignment functions to use. - -> Double -- ^ The output image width in backend coordinates. - -> Double -- ^ The output image height in backend coordinates. - -> IO DEnv -defaultEnv alignFns w h = customFontEnv alignFns w h M.empty +-- | Produce a default environment with just the sans-serif fonts. +defaultEnv :: (Read n, RealFloat n) + => AlignmentFns -- ^ Alignment functions to use. + -> n -- ^ The output image width in backend coordinates. + -> n -- ^ The output image height in backend coordinates. + -> IO (DEnv n) +defaultEnv alignFns w h = do + fontSelector <- loadSansSerifFonts + return (createEnv alignFns w h fontSelector) + -- | Run this backends renderer. -runBackendR :: (D.Backend b R2, D.Renderable (D.Path R2) b) - => DEnv -- ^ Environment to start rendering with. +runBackendR :: ( D.Backend b V2 (N b), D.Renderable (D.Path V2 (N b)) b + , D.TypeableFloat (N b), D.Metric (V b)) + => DEnv (N b) -- ^ Environment to start rendering with. -> Renderable a -- ^ Chart render code. - -> (Diagram b R2, PickFn a) -- ^ The diagram. -runBackendR env r = - let cb = render r (envOutputSize env) + -> (D.QDiagram b V2 (N b) Any, PickFn a) -- ^ The diagram. +runBackendR env r = + let cb = render r (realToFrac w, realToFrac h) + (w,h) = envOutputSize env in runBackend env cb -- | Run this backends renderer. -runBackend :: (D.Backend b R2, D.Renderable (D.Path R2) b) - => DEnv -- ^ Environment to start rendering with. - -> ChartBackend a -- ^ Chart render code. - -> (Diagram b R2, a) -- ^ The diagram. -runBackend env m = +runBackend :: ( D.Backend b V2 (N b), D.Renderable (D.Path V2 (N b)) b + , D.TypeableFloat (N b), D.Metric (V b)) + => DEnv (N b) -- ^ Environment to start rendering with. + -> BackendProgram a -- ^ Chart render code. + -> (D.QDiagram b V2 (N b) Any, a) -- ^ The diagram. +runBackend env m = let (d, x) = evalState (runBackend' TextRenderSvg $ withDefaultStyle m) env in (adjustOutputDiagram env d, x) -- | Run this backends renderer. -runBackendWithGlyphs :: ( D.Backend b R2 - , D.Renderable (D.Path R2) b - , D.Renderable (D2.Text) b) - => DEnv -- ^ Environment to start rendering with. - -> ChartBackend a -- ^ Chart render code. - -> ( Diagram b R2, a +runBackendWithGlyphs :: ( D.Backend b V2 (N b) + , D.Renderable (D.Path V2 (N b)) b + , D.Renderable (D2.Text (N b)) b + , D.TypeableFloat (N b), D.Metric (V b)) + => DEnv (N b) -- ^ Environment to start rendering with. + -> BackendProgram a -- ^ Chart render code. + -> ( D.QDiagram b V2 (N b) Any, a , M.Map (String, FontSlant, FontWeight) (S.Set String)) -runBackendWithGlyphs env m = +runBackendWithGlyphs env m = let ((d, x), env') = runState (runBackend' TextRenderNative $ withDefaultStyle m) env in (adjustOutputDiagram env d, x, envUsedGlyphs env') -- | Flag to decide which technique should ne used to render text. --- The type parameter is the primitive that has to be supported by +-- The type parameter is the primitive that has to be supported by -- a backend when rendering text using this technique. -data TextRender a where - TextRenderNative :: TextRender (D2.Text) - TextRenderSvg :: TextRender (D.Path R2) +data TextRender b a where + TextRenderNative :: TextRender b (D2.Text (N b)) + TextRenderSvg :: TextRender b (D.Path V2 (N b)) -runBackend' :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> ChartBackend a -> DState (Diagram b R2, a) +runBackend' :: (D.Renderable (D.Path V2 (N b)) b, D.Renderable t b, D.TypeableFloat (N b)) + => TextRender b t -> BackendProgram a + -> DState (N b) (D.QDiagram b V2 (N b) Any, a) runBackend' tr m = eval tr $ view $ m where - eval :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> ProgramView ChartBackendInstr a -> DState (Diagram b R2, a) + eval :: (D.Renderable (D.Path V2 (N b)) b, D.Renderable t b, D.TypeableFloat (N b)) + => TextRender b t -> ProgramView ChartBackendInstr a + -> DState (N b) (D.QDiagram b V2 (N b) Any, a) eval tr (Return v) = return (mempty, v) eval tr (StrokePath p :>>= f) = dStrokePath p <># step tr f eval tr (FillPath p :>>= f) = dFillPath p <># step tr f @@ -444,15 +356,16 @@ eval tr (WithLineStyle ls p :>>= f) = dWithLineStyle tr ls p <>= step tr f eval tr (WithClipRegion r p :>>= f) = dWithClipRegion tr r p <>= step tr f - step :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> (v -> ChartBackend a) -> v -> DState (Diagram b R2, a) + step :: (D.Renderable (D.Path V2 (N b)) b, D.Renderable t b, D.TypeableFloat (N b)) + => TextRender b t -> (v -> BackendProgram a) -> v + -> DState (N b) (D.QDiagram b V2 (N b) Any, a) step tr f v = runBackend' tr (f v) - + (<>#) :: (Monad s, Monoid m) => s m -> (() -> s (m, a)) -> s (m, a) (<>#) m f = do ma <- m return (ma, ()) <>= f - + (<>=) :: (Monad s, Monoid m) => s (m, a) -> (a -> s (m, b)) -> s (m, b) (<>=) m f = do (ma, a) <- m @@ -461,7 +374,7 @@ -- | Executes the given state locally, but preserves the changes to the 'envUsedGlyphs' -- map. Assumes that values are never removed from the map inbetween. -dLocal :: DState a -> DState a +dLocal :: DState n a -> DState n a dLocal m = do env <- get x <- m @@ -469,94 +382,101 @@ put $ env { envUsedGlyphs = envUsedGlyphs env' } return x -dStrokePath :: (D.Renderable (D.Path R2) b) - => Path -> DState (Diagram b R2) +dStrokePath :: (D.Renderable (D.Path V2 (N b)) b, D.TypeableFloat (N b)) + => Path -> DState (N b) (D.QDiagram b V2 (N b) Any) dStrokePath p = return $ applyFillStyle noFillStyle $ D.stroke $ convertPath False p -dFillPath :: (D.Renderable (D.Path R2) b) - => Path -> DState (Diagram b R2) +dFillPath :: (D.Renderable (D.Path V2 (N b)) b, D.TypeableFloat (N b)) + => Path -> DState (N b) (D.QDiagram b V2 (N b) Any) dFillPath p = return $ applyLineStyle noLineStyle $ D.stroke $ convertPath True p -dTextSize :: (D.Renderable (D.Path R2) b) - => String -> DState (Diagram b R2, TextSize) +dTextSize :: (D.Renderable (D.Path V2 (N b)) b, D.TypeableFloat (N b)) + => String -> DState (N b) (D.QDiagram b V2 (N b) Any, TextSize) dTextSize text = do env <- get let fs = envFontStyle env let (scaledH, scaledA, scaledD, scaledYB) = calcFontMetrics env - return (mempty, TextSize - { textSizeWidth = D2.width $ F.textSVG' - $ fontStyleToTextOpts env text - , textSizeAscent = scaledA -- scaledH * (a' / h') -- ascent - , textSizeDescent = scaledD -- scaledH * (d' / h') -- descent - , textSizeYBearing = scaledYB -- -scaledH * (capHeight / h) - , textSizeHeight = _font_size $ fs + return (mempty, TextSize + { textSizeWidth = realToFrac $ D2.width + $ F.drop_rect + $ F.fit_height scaledH + $ F.svgText (fontStyleToTextOpts env) text + , textSizeAscent = realToFrac scaledA -- scaledH * (a' / h') -- ascent + , textSizeDescent = realToFrac scaledD -- scaledH * (d' / h') -- descent + , textSizeYBearing = realToFrac scaledYB -- -scaledH * (capHeight / h) + , textSizeHeight = realToFrac $ _font_size fs }) -dAlignmentFns :: (D.Renderable (D.Path R2) b) - => DState (Diagram b R2, AlignmentFns) +dAlignmentFns :: (D.Renderable (D.Path V2 (N b)) b, RealFloat (N b)) + => DState (N b) (D.QDiagram b V2 (N b) Any, AlignmentFns) dAlignmentFns = do env <- get return (mempty, envAlignmentFns env) -dDrawTextSvg :: (D.Renderable (D.Path R2) b) - => Point -> String -> DState (Diagram b R2) +dDrawTextSvg :: (D.Renderable (D.Path V2 (N b)) b, D.TypeableFloat (N b)) + => Point -> String -> DState (N b) (D.QDiagram b V2 (N b) Any) dDrawTextSvg (Point x y) text = do env <- get + let (scaledH, _, _, _) = calcFontMetrics env return $ D.transform (toTransformation $ translate (Vector x y) 1) $ applyFontStyleSVG (envFontStyle env) $ D2.scaleY (-1) - $ F.textSVG_ (fontStyleToTextOpts env text) + $ F.set_envelope + $ F.fit_height scaledH + $ F.svgText (fontStyleToTextOpts env) text -dDrawTextNative :: (D.Renderable D2.Text b) - => Point -> String -> DState (Diagram b R2) +dDrawTextNative :: (D.Renderable (D2.Text (N b)) b, D.TypeableFloat (N b)) + => Point -> String -> DState (N b) (D.QDiagram b V2 (N b) Any) dDrawTextNative (Point x y) text = do env <- get addGlyphsOfString text return $ D.transform (toTransformation $ translate (Vector x y) 1) - $ applyFontStyleText (envFontStyle env) + $ applyFontStyleText (envFontStyle env) $ D2.scaleY (-1) $ D2.baselineText text -dWith :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> (DEnv -> DEnv) -> (Diagram b R2 -> Diagram b R2) - -> ChartBackend a -> DState (Diagram b R2, a) +dWith :: ( D.TypeableFloat (N b), D.Metric V2 + , D.Renderable (D.Path V2 (N b)) b, D.Renderable t b) + => TextRender b t -> (DEnv (N b) -> DEnv (N b)) + -> (D.QDiagram b V2 (N b) Any -> D.QDiagram b V2 (N b) Any) + -> BackendProgram a -> DState (N b) (D.QDiagram b V2 (N b) Any, a) dWith tr envF dF m = dLocal $ do modify envF (ma, a) <- runBackend' tr m return (dF ma, a) -dWithTransform :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> Matrix -> ChartBackend a -> DState (Diagram b R2, a) +dWithTransform :: (D.TypeableFloat (N b), D.Renderable (D.Path V2 (N b)) b, D.Renderable t b) + => TextRender b t -> Matrix -> BackendProgram a -> DState (N b) (D.QDiagram b V2 (N b) Any, a) dWithTransform tr t = dWith tr id $ D.transform (toTransformation t) -dWithLineStyle :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> LineStyle -> ChartBackend a -> DState (Diagram b R2, a) +dWithLineStyle :: (D.TypeableFloat (N b), D.Renderable (D.Path V2 (N b)) b, D.Renderable t b) + => TextRender b t -> LineStyle -> BackendProgram a -> DState (N b) (D.QDiagram b V2 (N b) Any, a) dWithLineStyle tr ls = dWith tr id $ applyLineStyle ls -dWithFillStyle :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> FillStyle -> ChartBackend a -> DState (Diagram b R2, a) +dWithFillStyle :: (D.TypeableFloat (N b), D.Renderable (D.Path V2 (N b)) b, D.Renderable t b) + => TextRender b t -> FillStyle -> BackendProgram a -> DState (N b) (D.QDiagram b V2 (N b) Any, a) dWithFillStyle tr fs = dWith tr id $ applyFillStyle fs -dWithFontStyle :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> FontStyle -> ChartBackend a -> DState (Diagram b R2, a) +dWithFontStyle :: (D.TypeableFloat (N b), D.Renderable (D.Path V2 (N b)) b, D.Renderable t b) + => TextRender b t -> FontStyle -> BackendProgram a -> DState (N b) (D.QDiagram b V2 (N b) Any, a) dWithFontStyle tr fs = dWith tr (\e -> e { envFontStyle = fs }) $ id -dWithClipRegion :: (D.Renderable (D.Path R2) b, D.Renderable t b) - => TextRender t -> Rect -> ChartBackend a -> DState (Diagram b R2, a) +dWithClipRegion :: (D.TypeableFloat (N b), D.Renderable (D.Path V2 (N b)) b, D.Renderable t b) + => TextRender b t -> Rect -> BackendProgram a -> DState (N b) (D.QDiagram b V2 (N b) Any, a) dWithClipRegion tr clip = dWith tr id $ D2.clipBy (convertPath True $ rectPath clip) -- ----------------------------------------------------------------------- -- Converions Helpers -- ----------------------------------------------------------------------- -addGlyphsOfString :: String -> DState () +addGlyphsOfString :: String -> DState n () addGlyphsOfString s = do env <- get let fs = envFontStyle env let fontData = fst $ envSelectFont env fs - let ligatures = ((filter ((>1) . length)) . (M.keys) . F.fontDataGlyphs) fontData + let ligatures = (filter ((>1) . length) . M.keys . F.fontDataGlyphs) fontData let glyphs = fmap T.unpack $ F.characterStrings s ligatures - modify $ \env -> + modify $ \env -> let gKey = (_font_name fs, _font_slant fs, _font_weight fs) gMap = envUsedGlyphs env entry = case M.lookup gKey gMap of @@ -565,14 +485,15 @@ in env { envUsedGlyphs = M.insert gKey entry gMap } return () -pointToP2 :: Point -> P2 -pointToP2 (Point x y) = p2 (x,y) +pointToP2 :: RealFrac n => Point -> P2 n +pointToP2 (Point x y) = p2 (realToFrac x, realToFrac y) -adjustOutputDiagram :: (D.Backend b R2) => DEnv -> Diagram b R2 -> Diagram b R2 -adjustOutputDiagram env d = D2.reflectY $ D2.view (p2 (0,0)) (r2 (envOutputSize env)) d +adjustOutputDiagram :: (D.Backend b V2 (N b), RealFloat (N b)) + => DEnv (N b) -> D.QDiagram b V2 (N b) Any -> D.QDiagram b V2 (N b) Any +adjustOutputDiagram env d = D2.reflectY $ D.rectEnvelope (p2 (0,0)) (r2 (envOutputSize env)) d noLineStyle :: LineStyle -noLineStyle = def +noLineStyle = def { _line_width = 0 , _line_color = transparent } @@ -580,60 +501,64 @@ noFillStyle :: FillStyle noFillStyle = solidFillStyle transparent -toTransformation :: Matrix -> T2 -toTransformation m = Transformation +toTransformation :: RealFloat n => Matrix -> T2 n +toTransformation m = Transformation (applyWithoutTrans m <-> applyWithoutTrans (invert m)) (applyWithoutTrans (transpose m) <-> applyWithoutTrans (transpose (invert m))) - (r2 (x0 m, y0 m)) + (r2 (realToFrac $ x0 m, realToFrac $ y0 m)) transpose :: Matrix -> Matrix transpose (Matrix xx yx xy yy _ _) = Matrix xx xy yx yy 0 0 -- | Apply a given affine transformation to a vector. -applyTransformation :: Matrix -> P2 -> P2 +applyTransformation :: RealFloat n => Matrix -> P2 n -> P2 n applyTransformation m p = let (x,y) = D2.unp2 p - in p2 ( xx m * x + xy m * y + x0 m - , yx m * x + yy m * y + y0 m + get :: RealFloat n => (Matrix -> Double) -> n + get f = realToFrac (f m) + in p2 ( get xx * x + get xy * y + get x0 + , get yx * x + get yy * y + get y0 ) -- | Apply a given affine transformation to a vector. -applyWithoutTrans :: Matrix -> R2 -> R2 +applyWithoutTrans :: RealFloat n => Matrix -> V2 n -> V2 n applyWithoutTrans m v = let (x,y) = D2.unr2 v - in r2 ( xx m * x + xy m * y - , yx m * x + yy m * y + get :: RealFloat n => (Matrix -> Double) -> n + get f = realToFrac (f m) + in r2 ( get xx * x + get xy * y + , get yx * x + get yy * y ) -- | Apply the Chart line style to a diagram. -applyLineStyle :: (D.HasStyle a) => LineStyle -> a -> a -applyLineStyle ls = D.lineWidth (_line_width ls) - . D.lineColor (_line_color ls) - . D.lineCap (convertLineCap $ _line_cap ls) - . D.lineJoin (convertLineJoin $ _line_join ls) - . D.dashing (_line_dashes ls) 0 +applyLineStyle :: (D.TypeableFloat (N a), D.V a ~ V2, D.HasStyle a) => LineStyle -> a -> a +applyLineStyle ls = D.lineWidth (D.global $ realToFrac $ _line_width ls) + . D.lineColor (_line_color ls) + . D.lineCap (convertLineCap $ _line_cap ls) + . D.lineJoin (convertLineJoin $ _line_join ls) + . D.dashing (map (D.global . realToFrac) $ _line_dashes ls) (D.global 0) -- | Apply the Chart fill style to a diagram. -applyFillStyle :: (D.HasStyle a) => FillStyle -> a -> a +applyFillStyle :: (D.TypeableFloat (N a), V a ~ V2, D.HasStyle a) => FillStyle -> a -> a applyFillStyle fs = case fs of FillStyleSolid cl -> D.fillColor cl -- | Apply all pure diagrams properties from the font style. -applyFontStyleSVG :: (D.HasStyle a) => FontStyle -> a -> a -applyFontStyleSVG fs = applyLineStyle noLineStyle +applyFontStyleSVG :: (D.TypeableFloat (N a), D.V a ~ V2, D.HasStyle a) => FontStyle -> a -> a +applyFontStyleSVG fs = applyLineStyle noLineStyle . applyFillStyle (solidFillStyle $ _font_color fs) -applyFontStyleText :: (D.HasStyle a) => FontStyle -> a -> a +applyFontStyleText :: (D.TypeableFloat (N a), D.V a ~ V2, D.HasStyle a) => FontStyle -> a -> a applyFontStyleText fs = D2.font (_font_name fs) - . D2.fontSize (_font_size fs) + . D2.fontSize (D.global $ realToFrac $ _font_size fs) . D2.fontSlant (convertFontSlant $ _font_slant fs) . D2.fontWeight (convertFontWeight $ _font_weight fs) . D.fillColor (_font_color fs) -- | Calculate the font metrics for the currently set font style. -- The returned value will be @(height, ascent, descent, ybearing)@. -calcFontMetrics :: DEnv -> (Double, Double, Double, Double) -calcFontMetrics env = +calcFontMetrics :: RealFloat n => DEnv n -> (n, n, n, n) +calcFontMetrics env = let fs = envFontStyle env font@(fontData,_) = envSelectFont env fs bbox = F.fontDataBoundingBox fontData @@ -645,33 +570,22 @@ d' = (d / h) * h' h' = (a + d) / (1 - d / h) unscaledH = F.bbox_dy $ fontData - scaledHeight = _font_size fs * (h' / h) + scaledHeight = realToFrac (_font_size fs) * (h' / h) scaledAscent = scaledHeight * (a' / h') scaledDescent = scaledHeight * (d' / h') scaledMaxHAdv = -scaledHeight * (capHeight / h) in (scaledHeight, scaledAscent, scaledDescent, scaledMaxHAdv) -fontStyleToTextOpts :: DEnv -> String -> F.TextOpts -fontStyleToTextOpts env text = +fontStyleToTextOpts :: RealFloat n => DEnv n -> F.TextOpts n +fontStyleToTextOpts env = let fs = envFontStyle env font = envSelectFont env fs - (scaledH, _, _, _) = calcFontMetrics env in F.TextOpts - { F.txt = text - , F.fdo = font - , F.mode = F.INSIDE_H + { F.textFont = font , F.spacing = F.KERN , F.underline = False - , F.textWidth = 1 - , F.textHeight = scaledH -- _font_size fs } -fontFromName :: String -> (F.FontData, F.OutlineMap) -fontFromName name = case name of - "serif" -> F.lin - "monospace" -> F.bit - _ -> F.lin - -- | Convert line caps. convertLineCap :: LineCap -> D.LineCap convertLineCap cap = case cap of @@ -697,50 +611,55 @@ FontWeightBold -> D2.FontWeightBold FontWeightNormal -> D2.FontWeightNormal --- | Convert paths. The boolean says wether all trails +-- | Convert paths. The boolean says wether all trails -- of the path shall be closed or remain open. -convertPath :: Bool -> Path -> D.Path R2 -convertPath closeAll path = +convertPath :: (RealFloat n, Ord n) => Bool -> Path -> D.Path V2 n +convertPath closeAll path = let (start, t, restM) = pathToTrail closeAll (Point 0 0) $ makeLinesExplicit path in D.pathFromTrailAt t start <> case restM of Nothing -> mempty Just rest -> convertPath closeAll rest -pathToTrail :: Bool -> Point -> Path - -> (D.Point R2, Trail R2, Maybe Path) -pathToTrail closeAll _ (MoveTo p0 path) = +pathToTrail :: (RealFloat n) + => Bool -> Point -> Path + -> (D.Point V2 n, Trail V2 n, Maybe Path) +pathToTrail closeAll _ (MoveTo p0 path) = let (t, close, rest) = pathToTrail' closeAll path p0 in (pointToP2 p0, makeTrail close t, rest) -pathToTrail closeAll _ path@(Arc c r s _ _) = +pathToTrail closeAll _ path@(Arc c r s _ _) = let p0 = translateP (pointToVec c) $ rotateP s $ Point r 0 (t, close, rest) = pathToTrail' closeAll path p0 in (pointToP2 p0, makeTrail close t, rest) -pathToTrail closeAll _ path@(ArcNeg c r s _ _) = +pathToTrail closeAll _ path@(ArcNeg c r s _ _) = let p0 = translateP (pointToVec c) $ rotateP s $ Point r 0 (t, close, rest) = pathToTrail' closeAll path p0 in (pointToP2 p0, makeTrail close t, rest) -pathToTrail closeAll start path = +pathToTrail closeAll start path = let (t, close, rest) = pathToTrail' closeAll path start in (pointToP2 start, makeTrail close t, rest) -makeTrail :: Bool -> D.Trail' D.Line R2 -> Trail R2 +makeTrail :: Bool -> D.Trail' D.Line V2 n -> Trail V2 n makeTrail True t = D.wrapTrail $ D.closeLine t makeTrail False t = D.wrapTrail $ t -pathToTrail' :: Bool -> Path -> Point -> (D.Trail' D.Line R2, Bool, Maybe Path) +angleToDirection :: RealFloat n => Double -> D.Direction V2 n +angleToDirection a = D.direction $ fmap realToFrac $ D2.V2 (cos a) (sin a) + +pathToTrail' :: (RealFloat n) + => Bool -> Path -> Point -> (D.Trail' D.Line V2 n, Bool, Maybe Path) pathToTrail' closeAll p@(MoveTo _ _) _ = (mempty, False || closeAll, Just p) -pathToTrail' closeAll (LineTo p1 path) p0 = +pathToTrail' closeAll (LineTo p1 path) p0 = let (t, c, rest) = pathToTrail' closeAll path p1 in ( (pointToP2 p0 ~~ pointToP2 p1) <> t, c || closeAll, rest ) -pathToTrail' closeAll (Arc p0 r s e path) _ = +pathToTrail' closeAll (Arc p0 r s e path) _ = let endP = translateP (pointToVec p0) $ rotateP e $ Point r 0 (t, c, rest) = pathToTrail' closeAll path endP - arcTrail = D2.scale r $ D2.arc (Rad s) (Rad e) + arcTrail = D2.scale (realToFrac r) $ D2.arcCCW (angleToDirection s) (angleToDirection e) in ( arcTrail <> t, c || closeAll, rest ) -pathToTrail' closeAll (ArcNeg p0 r s e path) _ = +pathToTrail' closeAll (ArcNeg p0 r s e path) _ = let endP = translateP (pointToVec p0) $ rotateP e $ Point r 0 (t, c, rest) = pathToTrail' closeAll path endP - arcTrail = D2.scale r $ D2.arcCW (Rad s) (Rad e) + arcTrail = D2.scale (realToFrac r) $ D2.arcCW (angleToDirection s) (angleToDirection e) in ( arcTrail <> t, c || closeAll, rest ) pathToTrail' closeAll End _ = (mempty, False || closeAll, Nothing) pathToTrail' closeAll Close _ = (mempty, True || closeAll, Nothing)