Chart-diagrams 1.1 → 1.9.5.1
raw patch · 2 files changed
Files
- Chart-diagrams.cabal +19/−16
- Graphics/Rendering/Chart/Backend/Diagrams.hs +286/−367
Chart-diagrams.cabal view
@@ -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 <jan.bracker@googlemail.com> Maintainer: Jan Bracker <jan.bracker@googlemail.com> 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
Graphics/Rendering/Chart/Backend/Diagrams.hs view
@@ -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)