rasterific-svg 0.1.0.3 → 0.1.1
raw patch · 7 files changed
+1687/−1674 lines, 7 filesdep ~Rasterificdep ~lensdep ~svg-treePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Rasterific, lens, svg-tree
API changes (from Hackage documentation)
Files
- changelog +19/−15
- exec-src/svgrender.hs +115/−115
- rasterific-svg.cabal +5/−5
- src/Graphics/Rasterific/Svg/PathConverter.hs +228/−230
- src/Graphics/Rasterific/Svg/RasterificRender.hs +572/−561
- src/Graphics/Rasterific/Svg/RasterificTextRendering.hs +468/−468
- src/Graphics/Rasterific/Svg/RenderContext.hs +280/−280
changelog view
@@ -1,15 +1,19 @@--*-change-log-*- - -v0.1.0.3 March 2015 - * Fix: Bumping lens dependency - -v0.1.0.2 February 2015 - * Fix: Removing all test suites from distribution package. - * Fix: Lowering some low version bounds. - -v0.1.0.1 February 2015 - * Fix: Removing bench from test suite. - -v0.1 February 2015 - * Initial release - +-*-change-log-*-++v0.1.1 April 2015+ * Fix: Fixing GHC 7.10.1 related warnings+ * Fix: Group transparency.++v0.1.0.3 March 2015+ * Fix: Bumping lens dependency++v0.1.0.2 February 2015+ * Fix: Removing all test suites from distribution package.+ * Fix: Lowering some low version bounds.++v0.1.0.1 February 2015+ * Fix: Removing bench from test suite.++v0.1 February 2015+ * Initial release+
exec-src/svgrender.hs view
@@ -1,115 +1,115 @@- -{-# LANGUAGE CPP #-} -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), pure ) -#endif - -import Control.Applicative( (<$>), (<|>) ) -import Control.Monad( when ) -import Data.Monoid( (<>) ) -import Codec.Picture( writePng ) -import System.FilePath( replaceExtension ) - -import Options.Applicative( Parser - , ParserInfo - , argument - , execParser - , fullDesc - , header - , help - , helper - , info - , long - , metavar - , progDesc - , str - , switch - , auto - , option - ) - -import Graphics.Rasterific.Svg( loadCreateFontCache - , renderSvgDocument - ) -import Graphics.Svg( loadSvgFile - , documentSize ) -import System.Exit( ExitCode( ExitFailure, ExitSuccess ) - , exitWith ) - -data Options = Options - { _inputFile :: !FilePath - , _outputFile :: !FilePath - , _verbose :: !Bool - , _width :: !Int - , _height :: !Int - , _dpi :: !Int - } - -argParser :: Parser Options -argParser = Options - <$> ( argument str - (metavar "SVGINPUTFILE" - <> help "SVG file to render to png")) - <*> ( argument str - (metavar "OUTPUTFILE" - <> help ("Output file name, same as input with" - <> " different extension if unspecified.")) - <|> pure "" ) - <*> ( switch (long "verbose" <> help "Display more information") ) - <*> ( option auto - ( long "width" - <> help "Force the width of the rendered PNG" - <> metavar "WIDTH" ) - <|> pure 0 - ) - <*> ( option auto - ( long "height" - <> help "Force the height of the rendered PNG" - <> metavar "HEIGHT" ) - <|> pure 0 ) - <*> ( option auto - ( long "dpi" - <> help "DPI used for text rendering and various real life sizes" - <> metavar "DPI" ) - <|> pure 96 ) - -progOptions :: ParserInfo Options -progOptions = info (helper <*> argParser) - ( fullDesc - <> progDesc "Convert SVGINPUTFILE into a png OUTPUTFILE" - <> header "svgrender svg file renderer." ) - -outFileName :: Options -> FilePath -outFileName Options { _outputFile = "", _inputFile = inf } = - replaceExtension inf "png" -outFileName opt = _outputFile opt - -fixSize :: Options -> (Int, Int) -> (Int, Int) -fixSize opt (w, h) = (notNull (_width opt) w, notNull (_height opt) h) - where - notNull v v' = if v <= 0 then v' else v - -runConversion :: Options -> IO () -runConversion options = do - cache <- loadCreateFontCache "rasterific-svg-font-cache" - let filename = _inputFile options - whenVerbose = when (_verbose options) . putStrLn - whenVerbose $ "Loading: " ++ filename - - svg <- loadSvgFile filename - case svg of - Nothing -> do - putStrLn $ "Failed to load " ++ filename - exitWith $ ExitFailure 1 - - Just d -> do - let dpi = _dpi options - size = fixSize options $ documentSize dpi d - whenVerbose $ "Rendering at " ++ show size - (finalImage, _) <- renderSvgDocument cache (Just size) dpi d - writePng (outFileName options) finalImage - exitWith ExitSuccess - -main :: IO () -main = execParser progOptions >>= runConversion - ++{-# LANGUAGE CPP #-}+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>), (<*>), pure )+#endif++import Control.Applicative( (<|>) )+import Control.Monad( when )+import Data.Monoid( (<>) )+import Codec.Picture( writePng )+import System.FilePath( replaceExtension )++import Options.Applicative( Parser+ , ParserInfo+ , argument+ , execParser+ , fullDesc+ , header+ , help+ , helper+ , info+ , long+ , metavar+ , progDesc+ , str+ , switch+ , auto+ , option+ )++import Graphics.Rasterific.Svg( loadCreateFontCache+ , renderSvgDocument+ )+import Graphics.Svg( loadSvgFile+ , documentSize )+import System.Exit( ExitCode( ExitFailure, ExitSuccess )+ , exitWith )++data Options = Options+ { _inputFile :: !FilePath+ , _outputFile :: !FilePath+ , _verbose :: !Bool+ , _width :: !Int+ , _height :: !Int+ , _dpi :: !Int+ }++argParser :: Parser Options+argParser = Options+ <$> ( argument str+ (metavar "SVGINPUTFILE"+ <> help "SVG file to render to png"))+ <*> ( argument str+ (metavar "OUTPUTFILE"+ <> help ("Output file name, same as input with"+ <> " different extension if unspecified."))+ <|> pure "" )+ <*> ( switch (long "verbose" <> help "Display more information") )+ <*> ( option auto+ ( long "width"+ <> help "Force the width of the rendered PNG"+ <> metavar "WIDTH" )+ <|> pure 0+ )+ <*> ( option auto+ ( long "height"+ <> help "Force the height of the rendered PNG"+ <> metavar "HEIGHT" )+ <|> pure 0 )+ <*> ( option auto+ ( long "dpi"+ <> help "DPI used for text rendering and various real life sizes"+ <> metavar "DPI" )+ <|> pure 96 )++progOptions :: ParserInfo Options+progOptions = info (helper <*> argParser)+ ( fullDesc+ <> progDesc "Convert SVGINPUTFILE into a png OUTPUTFILE"+ <> header "svgrender svg file renderer." )++outFileName :: Options -> FilePath+outFileName Options { _outputFile = "", _inputFile = inf } =+ replaceExtension inf "png"+outFileName opt = _outputFile opt++fixSize :: Options -> (Int, Int) -> (Int, Int)+fixSize opt (w, h) = (notNull (_width opt) w, notNull (_height opt) h)+ where+ notNull v v' = if v <= 0 then v' else v++runConversion :: Options -> IO ()+runConversion options = do+ cache <- loadCreateFontCache "rasterific-svg-font-cache"+ let filename = _inputFile options+ whenVerbose = when (_verbose options) . putStrLn+ whenVerbose $ "Loading: " ++ filename ++ svg <- loadSvgFile filename+ case svg of+ Nothing -> do+ putStrLn $ "Failed to load " ++ filename+ exitWith $ ExitFailure 1++ Just d -> do+ let dpi = _dpi options+ size = fixSize options $ documentSize dpi d+ whenVerbose $ "Rendering at " ++ show size+ (finalImage, _) <- renderSvgDocument cache (Just size) dpi d+ writePng (outFileName options) finalImage+ exitWith ExitSuccess++main :: IO ()+main = execParser progOptions >>= runConversion+
rasterific-svg.cabal view
@@ -1,7 +1,7 @@ -- Initial svg.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: rasterific-svg -version: 0.1.0.3 +version: 0.1.1 synopsis: SVG renderer based on Rasterific. description: SVG renderer that will let you render svg-tree parsed SVG file to a JuicyPixel image or Rasterific Drawing. @@ -22,7 +22,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/rasterific-svg.git - Tag: v0.1.0.3 + Tag: v0.1.1 library hs-source-dirs: src @@ -44,10 +44,10 @@ , scientific >= 0.3 , JuicyPixels >= 3.2 && < 3.3 , containers >= 0.5 - , Rasterific >= 0.5 && < 0.6 + , Rasterific >= 0.5.2.1 && < 0.6 , FontyFruity >= 0.5 && < 0.6 - , svg-tree >= 0.1 && < 0.2 - , lens >= 4.5 && < 4.9 + , svg-tree >= 0.2 && < 0.3 + , lens >= 4.5 && < 4.10 , linear >= 1.16 , vector >= 0.10 , text >= 1.2
src/Graphics/Rasterific/Svg/PathConverter.hs view
@@ -1,230 +1,228 @@-{-# LANGUAGE CPP #-} -module Graphics.Rasterific.Svg.PathConverter - ( svgPathToPrimitives - , svgPathToRasterificPath - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -#endif - -import Control.Applicative( (<$>) ) - -import Data.List( mapAccumL ) -import Graphics.Rasterific.Linear( (^+^) - , (^-^) - , (^*) - , norm - , nearZero - , zero ) -import qualified Graphics.Rasterific as R -import qualified Linear as L -import Graphics.Svg.Types - -singularize :: [PathCommand] -> [PathCommand] -singularize = concatMap go - where - go (MoveTo _ []) = [] - go (MoveTo o (x: xs)) = MoveTo o [x] : go (LineTo o xs) - go (LineTo o lst) = LineTo o . pure <$> lst - go (HorizontalTo o lst) = HorizontalTo o . pure <$> lst - go (VerticalTo o lst) = VerticalTo o . pure <$> lst - go (CurveTo o lst) = CurveTo o . pure <$> lst - go (SmoothCurveTo o lst) = SmoothCurveTo o . pure <$> lst - go (QuadraticBezier o lst) = QuadraticBezier o . pure <$> lst - go (SmoothQuadraticBezierCurveTo o lst) = - SmoothQuadraticBezierCurveTo o . pure <$> lst - go (ElipticalArc o lst) = ElipticalArc o . pure <$> lst - go EndPath = [EndPath] - -toR :: RPoint -> R.Point -{-# INLINE toR #-} -toR (L.V2 x y) = R.V2 x y - -svgPathToPrimitives :: Bool -> [PathCommand] -> [R.Primitive] -svgPathToPrimitives _ lst | isPathWithArc lst = [] -svgPathToPrimitives shouldClose lst - | shouldClose && not (nearZero $ norm (lastPoint ^-^ firstPoint)) = - concat $ prims ++ [R.line lastPoint firstPoint] - | otherwise = concat prims - where - ((lastPoint, _, firstPoint), prims) = - mapAccumL go (zero, zero, zero) $ singularize lst - - go (latest, p, first) EndPath = - ((first, p, first), R.line latest first) - - go o (HorizontalTo _ []) = (o, []) - go o (VerticalTo _ []) = (o, []) - go o (MoveTo _ []) = (o, []) - go o (LineTo _ []) = (o, []) - go o (CurveTo _ []) = (o, []) - go o (SmoothCurveTo _ []) = (o, []) - go o (QuadraticBezier _ []) = (o, []) - go o (SmoothQuadraticBezierCurveTo _ []) = (o, []) - - go (_, _, _) (MoveTo OriginAbsolute (p:_)) = ((p', p', p'), []) - where p' = toR p - go (o, _, _) (MoveTo OriginRelative (p:_)) = - ((pp, pp, pp), []) where pp = o ^+^ toR p - - go (o@(R.V2 _ y), _, fp) (HorizontalTo OriginAbsolute (c:_)) = - ((p, p, fp), R.line o p) where p = R.V2 c y - go (o@(R.V2 x y), _, fp) (HorizontalTo OriginRelative (c:_)) = - ((p, p, fp), R.line o p) where p = R.V2 (x + c) y - - go (o@(R.V2 x _), _, fp) (VerticalTo OriginAbsolute (c:_)) = - ((p, p, fp), R.line o p) where p = R.V2 x c - go (o@(R.V2 x y), _, fp) (VerticalTo OriginRelative (c:_)) = - ((p, p, fp), R.line o p) where p = R.V2 x (c + y) - - go (o, _, fp) (LineTo OriginRelative (c:_)) = - ((p, p, fp), R.line o p) where p = o ^+^ toR c - - go (o, _, fp) (LineTo OriginAbsolute (p:_)) = - ((p', p', fp), R.line o $ toR p) - where p' = toR p - - go (o, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) = - ((e', c2', fp), - [R.CubicBezierPrim $ R.CubicBezier o (toR c1) c2' e']) - where e' = toR e - c2' = toR c2 - - go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) = - ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) - where c1' = o ^+^ toR c1 - c2' = o ^+^ toR c2 - e' = o ^+^ toR e - - go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) = - ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) - where c1' = o ^* 2 ^-^ control - c2' = toR c2 - e' = toR e - - go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) = - ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) - where c1' = o ^* 2 ^-^ control - c2' = o ^+^ toR c2 - e' = o ^+^ toR e - - go (o, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) = - ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) - where e' = toR e - c1' = toR c1 - - go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) = - ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) - where c1' = o ^+^ toR c1 - e' = o ^+^ toR e - - go (o, control, fp) - (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) = - ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) - where c1' = o ^* 2 ^-^ control - e' = toR e - - go (o, control, fp) - (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) = - ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) - where c1' = o ^* 2 ^-^ control - e' = o ^+^ toR e - - go _ (ElipticalArc _ _) = error "Unimplemented" - - --- | Conversion function between svg path to the rasterific one. -svgPathToRasterificPath :: Bool -> [PathCommand] -> R.Path -svgPathToRasterificPath shouldClose lst = - R.Path firstPoint shouldClose $ concat commands - where - lineTo p = [R.PathLineTo p] - cubicTo e1 e2 e3 = [R.PathCubicBezierCurveTo e1 e2 e3] - quadTo e1 e2 = [R.PathQuadraticBezierCurveTo e1 e2] - - ((_, _, firstPoint), commands) = - mapAccumL go (zero, zero, zero) $ singularize lst - - go (_, p, first) EndPath = - ((first, p, first), []) - - go o (HorizontalTo _ []) = (o, []) - go o (VerticalTo _ []) = (o, []) - go o (MoveTo _ []) = (o, []) - go o (LineTo _ []) = (o, []) - go o (CurveTo _ []) = (o, []) - go o (SmoothCurveTo _ []) = (o, []) - go o (QuadraticBezier _ []) = (o, []) - go o (SmoothQuadraticBezierCurveTo _ []) = (o, []) - - go (_, _, _) (MoveTo OriginAbsolute (p:_)) = - ((pp, pp, pp), []) where pp = toR p - go (o, _, _) (MoveTo OriginRelative (p:_)) = - ((pp, pp, pp), []) where pp = o ^+^ toR p - - go (R.V2 _ y, _, fp) (HorizontalTo OriginAbsolute (c:_)) = - ((p, p, fp), lineTo p) where p = R.V2 c y - go (R.V2 x y, _, fp) (HorizontalTo OriginRelative (c:_)) = - ((p, p, fp), lineTo p) where p = R.V2 (x + c) y - - go (R.V2 x _, _, fp) (VerticalTo OriginAbsolute (c:_)) = - ((p, p, fp), lineTo p) where p = R.V2 x c - go (R.V2 x y, _, fp) (VerticalTo OriginRelative (c:_)) = - ((p, p, fp), lineTo p) where p = R.V2 x (c + y) - - go (o, _, fp) (LineTo OriginRelative (c:_)) = - ((p, p, fp), lineTo p) where p = o ^+^ toR c - - go (_, _, fp) (LineTo OriginAbsolute (p:_)) = - ((p', p', fp), lineTo p') - where p' = toR p - - go (_, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) = - ((e', c2', fp), cubicTo c1' c2' e') - where e' = toR e - c2' = toR c2 - c1' = toR c1 - - go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) = - ((e', c2', fp), cubicTo c1' c2' e') - where c1' = o ^+^ toR c1 - c2' = o ^+^ toR c2 - e' = o ^+^ toR e - - go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) = - ((e', c2', fp), cubicTo c1' c2' e') - where c1' = o ^* 2 ^-^ control - c2' = toR c2 - e' = toR e - - go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) = - ((e', c2', fp), cubicTo c1' c2' e') - where c1' = o ^* 2 ^-^ control - c2' = o ^+^ toR c2 - e' = o ^+^ toR e - - go (_, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) = - ((e', c1', fp), quadTo c1' e') - where e' = toR e - c1' = toR c1 - - go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) = - ((e', c1', fp), quadTo c1' e') - where c1' = o ^+^ toR c1 - e' = o ^+^ toR e - - go (o, control, fp) - (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) = - ((e', c1', fp), quadTo c1' e') - where c1' = o ^* 2 ^-^ control - e' = toR e - - go (o, control, fp) - (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) = - ((e', c1', fp), quadTo c1' e') - where c1' = o ^* 2 ^-^ control - e' = o ^+^ toR e - - go _ (ElipticalArc _ _) = error "Unimplemented" - +{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Svg.PathConverter+ ( svgPathToPrimitives+ , svgPathToRasterificPath+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( pure, (<$>) )+#endif++import Data.List( mapAccumL )+import Graphics.Rasterific.Linear( (^+^)+ , (^-^)+ , (^*)+ , norm+ , nearZero+ , zero )+import qualified Graphics.Rasterific as R+import qualified Linear as L+import Graphics.Svg.Types++singularize :: [PathCommand] -> [PathCommand]+singularize = concatMap go+ where+ go (MoveTo _ []) = []+ go (MoveTo o (x: xs)) = MoveTo o [x] : go (LineTo o xs)+ go (LineTo o lst) = LineTo o . pure <$> lst+ go (HorizontalTo o lst) = HorizontalTo o . pure <$> lst+ go (VerticalTo o lst) = VerticalTo o . pure <$> lst+ go (CurveTo o lst) = CurveTo o . pure <$> lst+ go (SmoothCurveTo o lst) = SmoothCurveTo o . pure <$> lst+ go (QuadraticBezier o lst) = QuadraticBezier o . pure <$> lst+ go (SmoothQuadraticBezierCurveTo o lst) =+ SmoothQuadraticBezierCurveTo o . pure <$> lst+ go (ElipticalArc o lst) = ElipticalArc o . pure <$> lst+ go EndPath = [EndPath]++toR :: RPoint -> R.Point+{-# INLINE toR #-}+toR (L.V2 x y) = R.V2 x y++svgPathToPrimitives :: Bool -> [PathCommand] -> [R.Primitive]+svgPathToPrimitives _ lst | isPathWithArc lst = []+svgPathToPrimitives shouldClose lst+ | shouldClose && not (nearZero $ norm (lastPoint ^-^ firstPoint)) =+ concat $ prims ++ [R.line lastPoint firstPoint]+ | otherwise = concat prims+ where+ ((lastPoint, _, firstPoint), prims) =+ mapAccumL go (zero, zero, zero) $ singularize lst++ go (latest, p, first) EndPath =+ ((first, p, first), R.line latest first)++ go o (HorizontalTo _ []) = (o, [])+ go o (VerticalTo _ []) = (o, [])+ go o (MoveTo _ []) = (o, [])+ go o (LineTo _ []) = (o, [])+ go o (CurveTo _ []) = (o, [])+ go o (SmoothCurveTo _ []) = (o, [])+ go o (QuadraticBezier _ []) = (o, [])+ go o (SmoothQuadraticBezierCurveTo _ []) = (o, [])++ go (_, _, _) (MoveTo OriginAbsolute (p:_)) = ((p', p', p'), [])+ where p' = toR p+ go (o, _, _) (MoveTo OriginRelative (p:_)) =+ ((pp, pp, pp), []) where pp = o ^+^ toR p++ go (o@(R.V2 _ y), _, fp) (HorizontalTo OriginAbsolute (c:_)) =+ ((p, p, fp), R.line o p) where p = R.V2 c y+ go (o@(R.V2 x y), _, fp) (HorizontalTo OriginRelative (c:_)) =+ ((p, p, fp), R.line o p) where p = R.V2 (x + c) y++ go (o@(R.V2 x _), _, fp) (VerticalTo OriginAbsolute (c:_)) =+ ((p, p, fp), R.line o p) where p = R.V2 x c+ go (o@(R.V2 x y), _, fp) (VerticalTo OriginRelative (c:_)) =+ ((p, p, fp), R.line o p) where p = R.V2 x (c + y)++ go (o, _, fp) (LineTo OriginRelative (c:_)) =+ ((p, p, fp), R.line o p) where p = o ^+^ toR c++ go (o, _, fp) (LineTo OriginAbsolute (p:_)) =+ ((p', p', fp), R.line o $ toR p)+ where p' = toR p++ go (o, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) =+ ((e', c2', fp),+ [R.CubicBezierPrim $ R.CubicBezier o (toR c1) c2' e'])+ where e' = toR e+ c2' = toR c2++ go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) =+ ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e'])+ where c1' = o ^+^ toR c1+ c2' = o ^+^ toR c2+ e' = o ^+^ toR e++ go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) =+ ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e'])+ where c1' = o ^* 2 ^-^ control+ c2' = toR c2+ e' = toR e++ go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) =+ ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e'])+ where c1' = o ^* 2 ^-^ control+ c2' = o ^+^ toR c2+ e' = o ^+^ toR e++ go (o, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) =+ ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])+ where e' = toR e+ c1' = toR c1++ go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) =+ ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])+ where c1' = o ^+^ toR c1+ e' = o ^+^ toR e++ go (o, control, fp)+ (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) =+ ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])+ where c1' = o ^* 2 ^-^ control+ e' = toR e++ go (o, control, fp)+ (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) =+ ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])+ where c1' = o ^* 2 ^-^ control+ e' = o ^+^ toR e++ go _ (ElipticalArc _ _) = error "Unimplemented"+++-- | Conversion function between svg path to the rasterific one.+svgPathToRasterificPath :: Bool -> [PathCommand] -> R.Path+svgPathToRasterificPath shouldClose lst =+ R.Path firstPoint shouldClose $ concat commands+ where+ lineTo p = [R.PathLineTo p]+ cubicTo e1 e2 e3 = [R.PathCubicBezierCurveTo e1 e2 e3]+ quadTo e1 e2 = [R.PathQuadraticBezierCurveTo e1 e2]++ ((_, _, firstPoint), commands) =+ mapAccumL go (zero, zero, zero) $ singularize lst+ + go (_, p, first) EndPath =+ ((first, p, first), [])++ go o (HorizontalTo _ []) = (o, [])+ go o (VerticalTo _ []) = (o, [])+ go o (MoveTo _ []) = (o, [])+ go o (LineTo _ []) = (o, [])+ go o (CurveTo _ []) = (o, [])+ go o (SmoothCurveTo _ []) = (o, [])+ go o (QuadraticBezier _ []) = (o, [])+ go o (SmoothQuadraticBezierCurveTo _ []) = (o, [])++ go (_, _, _) (MoveTo OriginAbsolute (p:_)) =+ ((pp, pp, pp), []) where pp = toR p+ go (o, _, _) (MoveTo OriginRelative (p:_)) =+ ((pp, pp, pp), []) where pp = o ^+^ toR p++ go (R.V2 _ y, _, fp) (HorizontalTo OriginAbsolute (c:_)) =+ ((p, p, fp), lineTo p) where p = R.V2 c y+ go (R.V2 x y, _, fp) (HorizontalTo OriginRelative (c:_)) =+ ((p, p, fp), lineTo p) where p = R.V2 (x + c) y++ go (R.V2 x _, _, fp) (VerticalTo OriginAbsolute (c:_)) =+ ((p, p, fp), lineTo p) where p = R.V2 x c+ go (R.V2 x y, _, fp) (VerticalTo OriginRelative (c:_)) =+ ((p, p, fp), lineTo p) where p = R.V2 x (c + y)++ go (o, _, fp) (LineTo OriginRelative (c:_)) =+ ((p, p, fp), lineTo p) where p = o ^+^ toR c++ go (_, _, fp) (LineTo OriginAbsolute (p:_)) =+ ((p', p', fp), lineTo p')+ where p' = toR p++ go (_, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) =+ ((e', c2', fp), cubicTo c1' c2' e')+ where e' = toR e+ c2' = toR c2+ c1' = toR c1++ go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) =+ ((e', c2', fp), cubicTo c1' c2' e')+ where c1' = o ^+^ toR c1+ c2' = o ^+^ toR c2+ e' = o ^+^ toR e++ go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) =+ ((e', c2', fp), cubicTo c1' c2' e')+ where c1' = o ^* 2 ^-^ control+ c2' = toR c2+ e' = toR e++ go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) =+ ((e', c2', fp), cubicTo c1' c2' e')+ where c1' = o ^* 2 ^-^ control+ c2' = o ^+^ toR c2+ e' = o ^+^ toR e++ go (_, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) =+ ((e', c1', fp), quadTo c1' e')+ where e' = toR e+ c1' = toR c1++ go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) =+ ((e', c1', fp), quadTo c1' e')+ where c1' = o ^+^ toR c1+ e' = o ^+^ toR e++ go (o, control, fp)+ (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) =+ ((e', c1', fp), quadTo c1' e')+ where c1' = o ^* 2 ^-^ control+ e' = toR e++ go (o, control, fp)+ (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) =+ ((e', c1', fp), quadTo c1' e')+ where c1' = o ^* 2 ^-^ control+ e' = o ^+^ toR e++ go _ (ElipticalArc _ _) = error "Unimplemented"+
src/Graphics/Rasterific/Svg/RasterificRender.hs view
@@ -1,561 +1,572 @@-{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} -module Graphics.Rasterific.Svg.RasterificRender - ( DrawResult( .. ) - , renderSvgDocument - , drawingOfSvgDocument - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty, mconcat ) -#endif - -import Data.Monoid( Last( .. ), (<>) ) -import Data.Maybe( fromMaybe ) -import Data.Word( Word8 ) -import Control.Monad( foldM ) -import Control.Monad.IO.Class( liftIO ) -import Control.Monad.Trans.State.Strict( modify, runStateT ) -import Control.Applicative( (<$>) ) -import Control.Lens( (&), (.~) ) -import qualified Codec.Picture as CP -import Codec.Picture( PixelRGBA8( .. ) - , PixelRGB16( .. ) - , PixelRGBA16( .. ) - , PixelRGBF( .. ) - , PixelYA16( .. ) - , PixelCMYK8 - , PixelYCbCr8 - , PixelRGB8 - , DynamicImage( .. ) - , pixelMap - , readImage - ) -import Codec.Picture.Types( promoteImage - , promotePixel - , convertPixel - ) - -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Graphics.Rasterific as R -import System.FilePath( (</>), dropFileName ) -import Graphics.Rasterific.Linear( V2( V2 ), (^+^), (^-^), (^*), zero ) -import Graphics.Rasterific.Outline -import qualified Graphics.Rasterific.Transformations as RT -import Graphics.Text.TrueType -import Graphics.Svg.Types hiding ( Dpi ) -import Graphics.Rasterific.Svg.PathConverter -import Graphics.Rasterific.Svg.RenderContext -import Graphics.Rasterific.Svg.RasterificTextRendering - -{-import Debug.Trace-} -{-import Text.Groom-} -{-import Text.Printf-} - --- | Represent a Rasterific drawing with the associated --- image size. -data DrawResult = DrawResult - { -- | Rasterific drawing, can be reused and composed - -- with other elements for scene drawing. - _drawAction :: R.Drawing PixelRGBA8 () - -- | Supposed drawing width of the drawing, ideally - -- represent the final image width. - , _drawWidth :: {-# UNPACK #-}!Int - -- | Supposed drawing height of the drawing, ideally - -- represent the final image height. - , _drawHeight :: {-# UNPACK #-}!Int - } - -renderSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document - -> IO (CP.Image PixelRGBA8, LoadedElements) -renderSvgDocument cache sizes dpi doc = do - (drawing, loaded) <- drawingOfSvgDocument cache sizes dpi doc - let color = PixelRGBA8 0 0 0 0 - img = R.renderDrawing (_drawWidth drawing) (_drawHeight drawing) color - $ _drawAction drawing - return (img, loaded) - -drawingOfSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document - -> IO (DrawResult, LoadedElements) -drawingOfSvgDocument cache sizes dpi doc = case sizes of - Just s -> renderAtSize s - Nothing -> renderAtSize $ documentSize dpi doc - where - uuWidth = toUserUnit dpi <$> _width doc - uuHeight = toUserUnit dpi <$> _height doc - (x1, y1, x2, y2) = case (_viewBox doc, uuWidth, uuHeight) of - (Just v, _, _) -> v - ( _, Just (Num w), Just (Num h)) -> (0, 0, floor w, floor h) - _ -> (0, 0, 1, 1) - - box = (V2 (fromIntegral x1) (fromIntegral y1), - V2 (fromIntegral x2) (fromIntegral y2)) - emptyContext = RenderContext - { _renderViewBox = box - , _initialViewBox = box - , _contextDefinitions = _definitions doc - , _fontCache = cache - , _renderDpi = dpi - , _subRender = subRenderer - , _basePath = _documentLocation doc - } - - subRenderer subDoc = do - (drawing, loaded) <- - liftIO $ renderSvgDocument cache Nothing dpi subDoc - modify (<> loaded) - return drawing - - sizeFitter (V2 0 0, V2 vw vh) (actualWidth, actualHeight) - | aw /= vw || vh /= ah = - R.withTransformation (RT.scale (aw / vw) (ah / vh)) - where - aw = fromIntegral actualWidth - ah = fromIntegral actualHeight - sizeFitter (V2 0 0, _) _ = id - sizeFitter (p@(V2 xs ys), V2 xEnd yEnd) actualSize = - R.withTransformation (RT.translate (negate p)) . - sizeFitter (zero, V2 (xEnd - xs) (yEnd - ys)) actualSize - - renderAtSize (w, h) = do - let stateDraw = mapM (renderSvg emptyContext) $ _elements doc - (elems, s) <- runStateT stateDraw mempty - let drawing = sizeFitter box (w, h) $ sequence_ elems - return (DrawResult drawing w h, s) - -withInfo :: (Monad m, Monad m2) - => (a -> Maybe b) -> a -> (b -> m (m2 ())) -> m (m2 ()) -withInfo accessor val action = - case accessor val of - Nothing -> return $ return () - Just v -> action v - -toTransformationMatrix :: Transformation -> RT.Transformation -toTransformationMatrix = go where - go (TransformMatrix a b c d e f) = - RT.Transformation a b c d e f - go (Translate x y) = RT.translate $ V2 x y - go (Scale xs Nothing) = RT.scale xs xs - go (Scale xs (Just ys)) = RT.scale xs ys - go (Rotate angle Nothing) = - RT.rotate $ toRadian angle - go (Rotate angle (Just (cx, cy))) = - RT.rotateCenter (toRadian angle) $ V2 cx cy - go (SkewX v) = RT.skewX $ toRadian v - go (SkewY v) = RT.skewY $ toRadian v - go TransformUnknown = mempty - -withTransform :: DrawAttributes -> R.Drawing a () - -> R.Drawing a () -withTransform trans draw = - case _transform trans of - Nothing -> draw - Just t -> R.withTransformation fullTrans draw - where fullTrans = F.foldMap toTransformationMatrix t - -withSvgTexture :: RenderContext -> DrawAttributes - -> Texture -> Float - -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -withSvgTexture ctxt attr texture opacity prims = do - mayTexture <- prepareTexture ctxt attr texture opacity prims - case mayTexture of - Nothing -> return $ return () - Just tex -> - let method = fillMethodOfSvg attr in - return . R.withTexture tex $ R.fillWithMethod method prims - -filler :: RenderContext - -> DrawAttributes - -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -filler ctxt info primitives = - withInfo (getLast . _fillColor) info $ \svgTexture -> - let opacity = fromMaybe 1.0 $ _fillOpacity info in - withSvgTexture ctxt info svgTexture opacity primitives - - -drawMarker :: (DrawAttributes -> Last ElementRef) - -> (R.Drawing PixelRGBA8 () -> Bool -> [R.Primitive] -> R.Drawing PixelRGBA8 ()) - -> RenderContext -> DrawAttributes -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -drawMarker accessor placer ctxt info prims = - withInfo (getLast . accessor) info $ \markerName -> - case markerElem markerName of - Nothing -> return mempty - Just (ElementMarker mark) -> do - let subInfo = initialDrawAttributes <> _markerDrawAttributes mark - markerGeometry <- mapM (renderTree ctxt subInfo) - $ _markerElements mark - let fittedGeometry = baseOrientation mark . fit mark $ mconcat markerGeometry - return $ placer fittedGeometry (shouldOrient mark) prims - Just _ -> return mempty - where - markerElem RefNone = Nothing - markerElem (Ref markerName) = - M.lookup markerName $ _contextDefinitions ctxt - - shouldOrient m = case _markerOrient m of - Just OrientationAuto -> True - Nothing -> False - Just (OrientationAngle _) -> False - - baseOrientation m = case _markerOrient m of - Nothing -> id - Just OrientationAuto -> id - Just (OrientationAngle a) -> - R.withTransformation (RT.rotate $ toRadian a) - - units = - fromMaybe MarkerUnitStrokeWidth . _markerUnits - - toNumber n = case toUserUnit (_renderDpi ctxt) n of - Num a -> a - _ -> 1.0 - - toStrokeSize n = do - sw <- toNumber <$> getLast (_strokeWidth info) - v <- toNumber <$> n - return . Num $ sw * v - - negatePoint (a, b) = - (mapNumber negate a, mapNumber negate b) - - fit markerInfo = case units markerInfo of - MarkerUnitUserSpaceOnUse -> - fitBox ctxt info - (Num 0, Num 0) - (_markerWidth markerInfo) - (_markerHeight markerInfo) - (negatePoint $ _markerRefPoint markerInfo) - (_markerViewBox markerInfo) - - MarkerUnitStrokeWidth -> - fitBox ctxt info - (Num 0, Num 0) - (toStrokeSize $ _markerWidth markerInfo) - (toStrokeSize $ _markerHeight markerInfo) - (negatePoint $ _markerRefPoint markerInfo) - (_markerViewBox markerInfo) - -drawEndMarker :: RenderContext -> DrawAttributes -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -drawEndMarker = drawMarker _markerEnd transformLast where - transformLast _ _ [] = return () - transformLast geom shouldOrient lst = R.withTransformation trans geom - where - prim = last lst - pp = R.lastPointOf prim - orient = R.lastTangeantOf prim - trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient - | otherwise = RT.translate pp - -drawMidMarker :: RenderContext -> DrawAttributes -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -drawMidMarker = drawMarker _markerMid transformStart where - transformStart geom shouldOrient = go where - go [] = return () - go [_] = return () - go (prim:rest@(p2:_)) = R.withTransformation trans geom >> go rest - where - pp = R.lastPointOf prim - prevOrient = R.lastTangeantOf prim - nextOrient = R.firstTangeantOf p2 - orient = (prevOrient ^+^ nextOrient) ^* 0.5 - trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient - | otherwise = RT.translate pp - -drawStartMarker :: RenderContext -> DrawAttributes -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -drawStartMarker = drawMarker _markerStart transformStart where - transformStart _ _ [] = return () - transformStart geom shouldOrient (prim:_) = R.withTransformation trans geom - where - pp = R.firstPointOf prim - orient = R.firstTangeantOf prim - trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient - | otherwise = RT.translate pp - - -stroker :: Bool -> RenderContext -> DrawAttributes -> [R.Primitive] - -> IODraw (R.Drawing PixelRGBA8 ()) -stroker withMarker ctxt info primitives = - withInfo (getLast . _strokeWidth) info $ \swidth -> - withInfo (getLast . _strokeColor) info $ \svgTexture -> - let toFloat = lineariseLength ctxt info - realWidth = toFloat swidth - dashOffsetStart = - maybe 0 toFloat . getLast $ _strokeOffset info - primsList = case getLast $ _strokeDashArray info of - Just pat -> - dashedStrokize dashOffsetStart (toFloat <$> pat) - realWidth (joinOfSvg info) (capOfSvg info) primitives - Nothing -> - [strokize realWidth (joinOfSvg info) (capOfSvg info) primitives] - opacity = fromMaybe 1.0 $ _strokeOpacity info - strokerAction acc prims = - (acc <>) <$> - withSvgTexture ctxt info svgTexture opacity prims - - in do - geom <- - if withMarker then do - start <- drawStartMarker ctxt info primitives - mid <- drawMidMarker ctxt info primitives - end <- drawEndMarker ctxt info primitives - return $ start <> mid <> end - else return mempty - final <- foldM strokerAction mempty primsList - return (final <> geom) - -mergeContext :: RenderContext -> DrawAttributes -> RenderContext -mergeContext ctxt _attr = ctxt - -viewBoxOfTree :: Tree -> Maybe (Int, Int, Int, Int) -viewBoxOfTree (SymbolTree (Symbol g)) = _groupViewBox g -viewBoxOfTree _ = Nothing - -geometryOfNamedElement :: RenderContext -> String -> Tree -geometryOfNamedElement ctxt str = - maybe None extractGeometry . M.lookup str $ _contextDefinitions ctxt - where - extractGeometry e = case e of - ElementLinearGradient _ -> None - ElementRadialGradient _ -> None - ElementPattern _ -> None - ElementMarker _ -> None - ElementMask _ -> None - ElementClipPath _ -> None - ElementGeometry g -> g - -imgToPixelRGBA8 :: DynamicImage -> CP.Image PixelRGBA8 -imgToPixelRGBA8 img = case img of - ImageY8 i -> promoteImage i - ImageY16 i -> - pixelMap (\y -> let v = w2b y in PixelRGBA8 v v v 255) i - ImageYF i -> - pixelMap (\f -> let v = f2b f in PixelRGBA8 v v v 255) i - ImageYA8 i -> promoteImage i - ImageYA16 i -> - pixelMap (\(PixelYA16 y a) -> let v = w2b y in PixelRGBA8 v v v (w2b a)) i - ImageRGB8 i -> promoteImage i - ImageRGB16 i -> pixelMap rgb162Rgba8 i - ImageRGBF i -> pixelMap rgbf2rgba8 i - ImageRGBA8 i -> i - ImageRGBA16 i -> pixelMap rgba162Rgba8 i - ImageYCbCr8 i -> pixelMap (promotePixel . yCbCr2Rgb) i - ImageCMYK8 i -> pixelMap (promotePixel . cmyk2Rgb) i - ImageCMYK16 i -> pixelMap (rgb162Rgba8 . convertPixel) i - where - yCbCr2Rgb :: PixelYCbCr8 -> PixelRGB8 - yCbCr2Rgb = convertPixel - - cmyk2Rgb :: PixelCMYK8 -> PixelRGB8 - cmyk2Rgb = convertPixel - - w2b v = fromIntegral $ v `div` 257 - f2b :: Float -> Word8 - f2b v = floor . max 0 . min 255 $ v * 255 - - rgbf2rgba8 (PixelRGBF r g b) = - PixelRGBA8 (f2b r) (f2b g) (f2b b) 255 - rgba162Rgba8 (PixelRGBA16 r g b a) = - PixelRGBA8 (w2b r) (w2b g) (w2b b) (w2b a) - rgb162Rgba8 (PixelRGB16 r g b)= - PixelRGBA8 (w2b r) (w2b g) (w2b b) 255 - - -renderImage :: RenderContext -> DrawAttributes -> Image - -> IODraw (R.Drawing PixelRGBA8 ()) -renderImage ctxt attr imgInfo = do - let rootFolder = dropFileName $ _basePath ctxt - realPath = rootFolder </> _imageHref imgInfo - eimg <- liftIO $ readImage realPath - let srect = RectangleTree $ defaultSvg - { _rectUpperLeftCorner = _imageCornerUpperLeft imgInfo - , _rectDrawAttributes = - _imageDrawAttributes imgInfo & fillColor .~ Last (Just FillNone) - , _rectWidth = _imageWidth imgInfo - , _rectHeight = _imageHeight imgInfo - } - - case eimg of - Left _ -> renderTree ctxt attr srect - Right img -> do - let pAttr = _imageDrawAttributes imgInfo - info = attr <> pAttr - context' = mergeContext ctxt pAttr - p' = linearisePoint context' info $ _imageCornerUpperLeft imgInfo - w' = lineariseXLength context' info $ _imageWidth imgInfo - h' = lineariseYLength context' info $ _imageHeight imgInfo - filling = R.drawImageAtSize (imgToPixelRGBA8 img) 0 p' w' h' - stroking <- stroker False context' info $ R.rectangle p' w' h' - return . withTransform pAttr $ filling <> stroking - -initialDrawAttributes :: DrawAttributes -initialDrawAttributes = mempty - { _strokeWidth = Last . Just $ Num 1.0 - , _strokeLineCap = Last $ Just CapButt - , _strokeLineJoin = Last $ Just JoinMiter - , _strokeMiterLimit = Last $ Just 4.0 - , _strokeOpacity = Just 1.0 - , _fillColor = Last . Just . ColorRef $ PixelRGBA8 0 0 0 255 - , _fillOpacity = Just 1.0 - , _fillRule = Last $ Just FillNonZero - , _fontSize = Last . Just $ Num 16 - , _textAnchor = Last $ Just TextAnchorStart - } - - -renderSvg :: RenderContext -> Tree -> IODraw (R.Drawing PixelRGBA8 ()) -renderSvg initialContext = renderTree initialContext initialDrawAttributes - - -fitBox :: RenderContext -> DrawAttributes - -> Point -> Maybe Number -> Maybe Number -> Point - -> Maybe (Int, Int, Int, Int) - -> R.Drawing px () - -> R.Drawing px () -fitBox ctxt attr basePoint mwidth mheight preTranslate viewbox = - let origin = linearisePoint ctxt attr basePoint - preShift = linearisePoint ctxt attr preTranslate - w = lineariseXLength ctxt attr <$> mwidth - h = lineariseYLength ctxt attr <$> mheight - in - case viewbox of - Nothing -> R.withTransformation (RT.translate origin) - (Just (xs, ys, xe, ye)) -> - let boxOrigin = V2 (fromIntegral xs) (fromIntegral ys) - boxEnd = V2 (fromIntegral xe) (fromIntegral ye) - V2 bw bh = abs $ boxEnd ^-^ boxOrigin - xScaleFactor = case w of - Just wpx -> wpx / bw - Nothing -> 1.0 - yScaleFactor = case h of - Just hpx -> hpx / bh - Nothing -> 1.0 - in - R.withTransformation $ RT.translate origin - <> RT.scale xScaleFactor yScaleFactor - <> RT.translate (negate boxOrigin ^+^ preShift) - -fitUse :: RenderContext -> DrawAttributes -> Use -> Tree - -> R.Drawing px () - -> R.Drawing px () -fitUse ctxt attr useElement subTree = - fitBox ctxt attr - (_useBase useElement) - (_useWidth useElement) - (_useHeight useElement) - (Num 0, Num 0) - (viewBoxOfTree subTree) - -renderTree :: RenderContext -> DrawAttributes -> Tree -> IODraw (R.Drawing PixelRGBA8 ()) -renderTree = go where - go _ _ None = return mempty - go ctxt attr (TextTree tp stext) = renderText ctxt attr tp stext - go ctxt attr (ImageTree i) = renderImage ctxt attr i - go ctxt attr (UseTree useData (Just subTree)) = do - sub <- go ctxt attr' subTree - return . fitUse ctxt attr useData subTree - $ withTransform pAttr sub - where - pAttr = _useDrawAttributes useData - attr' = attr <> pAttr - - go ctxt attr (UseTree useData Nothing) = do - sub <- go ctxt attr' subTree - return . fitUse ctxt attr useData subTree - $ withTransform pAttr sub - where - pAttr = _useDrawAttributes useData - attr' = attr <> pAttr - subTree = geometryOfNamedElement ctxt $ _useName useData - - go ctxt attr (SymbolTree (Symbol g)) = go ctxt attr $ GroupTree g - go ctxt attr (GroupTree (Group groupAttr subTrees _)) = do - subTrees' <- mapM (go context' attr') subTrees - return . withTransform groupAttr $ sequence_ subTrees' - where attr' = attr <> groupAttr - context' = mergeContext ctxt groupAttr - - go ctxt attr (RectangleTree (Rectangle pAttr p w h (rx, ry))) = do - let info = attr <> pAttr - context' = mergeContext ctxt pAttr - p' = linearisePoint context' info p - w' = lineariseXLength context' info w - h' = lineariseYLength context' info h - - rx' = lineariseXLength context' info rx - ry' = lineariseXLength context' info ry - rect = case (rx', ry') of - (0, 0) -> R.rectangle p' w' h' - (v, 0) -> R.roundedRectangle p' w' h' v v - (0, v) -> R.roundedRectangle p' w' h' v v - (vx, vy) -> R.roundedRectangle p' w' h' vx vy - - filling <- filler context' info rect - stroking <- stroker False context' info rect - return . withTransform pAttr $ filling <> stroking - - go ctxt attr (CircleTree (Circle pAttr p r)) = do - let info = attr <> pAttr - context' = mergeContext ctxt pAttr - p' = linearisePoint context' info p - r' = lineariseLength context' info r - c = R.circle p' r' - filling <- filler context' info c - stroking <- stroker False context' info c - return . withTransform pAttr $ filling <> stroking - - go ctxt attr (EllipseTree (Ellipse pAttr p rx ry)) = do - let info = attr <> pAttr - context' = mergeContext ctxt pAttr - p' = linearisePoint context' info p - rx' = lineariseXLength context' info rx - ry' = lineariseYLength context' info ry - c = R.ellipse p' rx' ry' - filling <- filler context' info c - stroking <- stroker False context' info c - return . withTransform pAttr $ filling <> stroking - - go ctxt attr (PolyLineTree (PolyLine pAttr points)) = - go ctxt (dropFillColor attr) - . PathTree . Path (dropFillColor pAttr) - $ toPath points - where - dropFillColor v = v { _fillColor = Last Nothing } - toPath [] = [] - toPath (x:xs) = - [ MoveTo OriginAbsolute [x] - , LineTo OriginAbsolute xs - ] - - go ctxt attr (PolygonTree (Polygon pAttr points)) = - go ctxt attr . PathTree . Path pAttr $ toPath points - where - toPath [] = [] - toPath (x:xs) = - [ MoveTo OriginAbsolute [x] - , LineTo OriginAbsolute xs - , EndPath - ] - - go ctxt attr (LineTree (Line pAttr p1 p2)) = do - let info = attr <> pAttr - context' = mergeContext ctxt pAttr - p1' = linearisePoint context' info p1 - p2' = linearisePoint context' info p2 - stroking <- stroker True context' info $ R.line p1' p2' - return $ withTransform pAttr stroking - - go ctxt attr (PathTree (Path pAttr p)) = do - let info = attr <> pAttr - strokePrimitives = svgPathToPrimitives False p - fillPrimitives = svgPathToPrimitives True p - filling <- filler ctxt info fillPrimitives - stroking <- stroker True ctxt info strokePrimitives - return . withTransform pAttr $ filling <> stroking - +{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Svg.RasterificRender+ ( DrawResult( .. )+ , renderSvgDocument+ , drawingOfSvgDocument+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+import Data.Monoid( mempty, mconcat )+#endif++import Data.Monoid( Last( .. ), (<>) )+import Data.Maybe( fromMaybe )+import Data.Word( Word8 )+import Control.Monad( foldM )+import Control.Monad.IO.Class( liftIO )+import Control.Monad.Trans.State.Strict( modify, runStateT )+import Control.Lens( (&), (.~) )+import qualified Codec.Picture as CP+import Codec.Picture( PixelRGBA8( .. )+ , PixelRGB16( .. )+ , PixelRGBA16( .. )+ , PixelRGBF( .. )+ , PixelYA16( .. )+ , PixelCMYK8+ , PixelYCbCr8+ , PixelRGB8+ , DynamicImage( .. )+ , pixelMap+ , readImage+ )+import Codec.Picture.Types( promoteImage+ , promotePixel+ , convertPixel+ )++import qualified Data.Foldable as F+import qualified Data.Map as M+import qualified Graphics.Rasterific as R+import System.FilePath( (</>), dropFileName )+import Graphics.Rasterific.Linear( V2( V2 ), (^+^), (^-^), (^*), zero )+import Graphics.Rasterific.Outline+import qualified Graphics.Rasterific.Transformations as RT+import Graphics.Text.TrueType+import Graphics.Svg.Types hiding ( Dpi )+import Graphics.Rasterific.Svg.PathConverter+import Graphics.Rasterific.Svg.RenderContext+import Graphics.Rasterific.Svg.RasterificTextRendering++{-import Debug.Trace-}+{-import Text.Groom-}+{-import Text.Printf-}++-- | Represent a Rasterific drawing with the associated+-- image size.+data DrawResult = DrawResult+ { -- | Rasterific drawing, can be reused and composed+ -- with other elements for scene drawing.+ _drawAction :: R.Drawing PixelRGBA8 ()+ -- | Supposed drawing width of the drawing, ideally+ -- represent the final image width.+ , _drawWidth :: {-# UNPACK #-}!Int+ -- | Supposed drawing height of the drawing, ideally+ -- represent the final image height.+ , _drawHeight :: {-# UNPACK #-}!Int+ }++renderSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document+ -> IO (CP.Image PixelRGBA8, LoadedElements)+renderSvgDocument cache sizes dpi doc = do+ (drawing, loaded) <- drawingOfSvgDocument cache sizes dpi doc+ let color = PixelRGBA8 0 0 0 0+ img = R.renderDrawing (_drawWidth drawing) (_drawHeight drawing) color+ $ _drawAction drawing+ return (img, loaded)++drawingOfSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document+ -> IO (DrawResult, LoadedElements)+drawingOfSvgDocument cache sizes dpi doc = case sizes of+ Just s -> renderAtSize s+ Nothing -> renderAtSize $ documentSize dpi doc+ where+ uuWidth = toUserUnit dpi <$> _width doc+ uuHeight = toUserUnit dpi <$> _height doc+ (x1, y1, x2, y2) = case (_viewBox doc, uuWidth, uuHeight) of+ (Just v, _, _) -> v+ ( _, Just (Num w), Just (Num h)) -> (0, 0, floor w, floor h)+ _ -> (0, 0, 1, 1)++ box = (V2 (fromIntegral x1) (fromIntegral y1),+ V2 (fromIntegral x2) (fromIntegral y2))+ emptyContext = RenderContext+ { _renderViewBox = box+ , _initialViewBox = box+ , _contextDefinitions = _definitions doc+ , _fontCache = cache+ , _renderDpi = dpi+ , _subRender = subRenderer+ , _basePath = _documentLocation doc+ }++ subRenderer subDoc = do+ (drawing, loaded) <-+ liftIO $ renderSvgDocument cache Nothing dpi subDoc+ modify (<> loaded)+ return drawing++ sizeFitter (V2 0 0, V2 vw vh) (actualWidth, actualHeight)+ | aw /= vw || vh /= ah =+ R.withTransformation (RT.scale (aw / vw) (ah / vh))+ where+ aw = fromIntegral actualWidth+ ah = fromIntegral actualHeight+ sizeFitter (V2 0 0, _) _ = id+ sizeFitter (p@(V2 xs ys), V2 xEnd yEnd) actualSize =+ R.withTransformation (RT.translate (negate p)) .+ sizeFitter (zero, V2 (xEnd - xs) (yEnd - ys)) actualSize++ renderAtSize (w, h) = do+ let stateDraw = mapM (renderSvg emptyContext) $ _elements doc+ (elems, s) <- runStateT stateDraw mempty+ let drawing = sizeFitter box (w, h) $ sequence_ elems+ return (DrawResult drawing w h, s)++withInfo :: (Monad m, Monad m2)+ => (a -> Maybe b) -> a -> (b -> m (m2 ())) -> m (m2 ())+withInfo accessor val action =+ case accessor val of+ Nothing -> return $ return ()+ Just v -> action v++toTransformationMatrix :: Transformation -> RT.Transformation+toTransformationMatrix = go where+ go (TransformMatrix a b c d e f) =+ RT.Transformation a b c d e f+ go (Translate x y) = RT.translate $ V2 x y+ go (Scale xs Nothing) = RT.scale xs xs+ go (Scale xs (Just ys)) = RT.scale xs ys+ go (Rotate angle Nothing) =+ RT.rotate $ toRadian angle+ go (Rotate angle (Just (cx, cy))) =+ RT.rotateCenter (toRadian angle) $ V2 cx cy+ go (SkewX v) = RT.skewX $ toRadian v+ go (SkewY v) = RT.skewY $ toRadian v+ go TransformUnknown = mempty++withTransform :: DrawAttributes -> R.Drawing a ()+ -> R.Drawing a ()+withTransform trans draw =+ case _transform trans of+ Nothing -> draw+ Just t -> R.withTransformation fullTrans draw+ where fullTrans = F.foldMap toTransformationMatrix t++withSvgTexture :: RenderContext -> DrawAttributes+ -> Texture -> Float+ -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+withSvgTexture ctxt attr texture opacity prims = do+ mayTexture <- prepareTexture ctxt attr texture opacity prims+ case mayTexture of+ Nothing -> return $ return ()+ Just tex ->+ let method = fillMethodOfSvg attr in+ return . R.withTexture tex $ R.fillWithMethod method prims++filler :: RenderContext+ -> DrawAttributes+ -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+filler ctxt info primitives =+ withInfo (getLast . _fillColor) info $ \svgTexture ->+ let opacity = fromMaybe 1.0 $ _fillOpacity info in+ withSvgTexture ctxt info svgTexture opacity primitives+++drawMarker :: (DrawAttributes -> Last ElementRef)+ -> (R.Drawing PixelRGBA8 () -> Bool -> [R.Primitive] -> R.Drawing PixelRGBA8 ())+ -> RenderContext -> DrawAttributes -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+drawMarker accessor placer ctxt info prims =+ withInfo (getLast . accessor) info $ \markerName ->+ case markerElem markerName of+ Nothing -> return mempty+ Just (ElementMarker mark) -> do+ let subInfo = initialDrawAttributes <> _markerDrawAttributes mark+ markerGeometry <- mapM (renderTree ctxt subInfo)+ $ _markerElements mark+ let fittedGeometry = baseOrientation mark . fit mark $ mconcat markerGeometry+ return $ placer fittedGeometry (shouldOrient mark) prims+ Just _ -> return mempty+ where+ markerElem RefNone = Nothing+ markerElem (Ref markerName) =+ M.lookup markerName $ _contextDefinitions ctxt++ shouldOrient m = case _markerOrient m of+ Just OrientationAuto -> True+ Nothing -> False+ Just (OrientationAngle _) -> False++ baseOrientation m = case _markerOrient m of+ Nothing -> id+ Just OrientationAuto -> id+ Just (OrientationAngle a) -> + R.withTransformation (RT.rotate $ toRadian a)++ units =+ fromMaybe MarkerUnitStrokeWidth . _markerUnits++ toNumber n = case toUserUnit (_renderDpi ctxt) n of+ Num a -> a+ _ -> 1.0++ toStrokeSize n = do+ sw <- toNumber <$> getLast (_strokeWidth info)+ v <- toNumber <$> n+ return . Num $ sw * v++ negatePoint (a, b) =+ (mapNumber negate a, mapNumber negate b)++ fit markerInfo = case units markerInfo of+ MarkerUnitUserSpaceOnUse ->+ fitBox ctxt info+ (Num 0, Num 0)+ (_markerWidth markerInfo)+ (_markerHeight markerInfo)+ (negatePoint $ _markerRefPoint markerInfo)+ (_markerViewBox markerInfo)++ MarkerUnitStrokeWidth ->+ fitBox ctxt info+ (Num 0, Num 0)+ (toStrokeSize $ _markerWidth markerInfo)+ (toStrokeSize $ _markerHeight markerInfo)+ (negatePoint $ _markerRefPoint markerInfo)+ (_markerViewBox markerInfo)++drawEndMarker :: RenderContext -> DrawAttributes -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+drawEndMarker = drawMarker _markerEnd transformLast where+ transformLast _ _ [] = return ()+ transformLast geom shouldOrient lst = R.withTransformation trans geom+ where+ prim = last lst+ pp = R.lastPointOf prim+ orient = R.lastTangeantOf prim+ trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient+ | otherwise = RT.translate pp++drawMidMarker :: RenderContext -> DrawAttributes -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+drawMidMarker = drawMarker _markerMid transformStart where+ transformStart geom shouldOrient = go where+ go [] = return ()+ go [_] = return ()+ go (prim:rest@(p2:_)) = R.withTransformation trans geom >> go rest+ where+ pp = R.lastPointOf prim+ prevOrient = R.lastTangeantOf prim+ nextOrient = R.firstTangeantOf p2+ orient = (prevOrient ^+^ nextOrient) ^* 0.5+ trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient+ | otherwise = RT.translate pp++drawStartMarker :: RenderContext -> DrawAttributes -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+drawStartMarker = drawMarker _markerStart transformStart where+ transformStart _ _ [] = return ()+ transformStart geom shouldOrient (prim:_) = R.withTransformation trans geom+ where+ pp = R.firstPointOf prim+ orient = R.firstTangeantOf prim+ trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient+ | otherwise = RT.translate pp++applyGroupOpacity :: DrawAttributes -> R.Drawing PixelRGBA8 () -> R.Drawing PixelRGBA8 ()+applyGroupOpacity attrs sub = case _groupOpacity attrs of+ Nothing -> sub+ Just 1.0 -> sub+ Just opa ->+ R.withGroupOpacity (floor . max 0 . min 255 $ opa * 255) sub++stroker :: Bool -> RenderContext -> DrawAttributes -> [R.Primitive]+ -> IODraw (R.Drawing PixelRGBA8 ())+stroker withMarker ctxt info primitives =+ withInfo (getLast . _strokeWidth) info $ \swidth ->+ withInfo (getLast . _strokeColor) info $ \svgTexture ->+ let toFloat = lineariseLength ctxt info+ realWidth = toFloat swidth+ dashOffsetStart =+ maybe 0 toFloat . getLast $ _strokeOffset info+ primsList = case getLast $ _strokeDashArray info of+ Just pat ->+ dashedStrokize dashOffsetStart (toFloat <$> pat)+ realWidth (joinOfSvg info) (capOfSvg info) primitives+ Nothing ->+ [strokize realWidth (joinOfSvg info) (capOfSvg info) primitives]+ opacity = fromMaybe 1.0 $ _strokeOpacity info+ strokerAction acc prims =+ (acc <>) <$>+ withSvgTexture ctxt info svgTexture opacity prims+ + in do+ geom <-+ if withMarker then do+ start <- drawStartMarker ctxt info primitives+ mid <- drawMidMarker ctxt info primitives+ end <- drawEndMarker ctxt info primitives+ return $ start <> mid <> end+ else return mempty+ final <- foldM strokerAction mempty primsList+ return (final <> geom)++mergeContext :: RenderContext -> DrawAttributes -> RenderContext+mergeContext ctxt _attr = ctxt++viewBoxOfTree :: Tree -> Maybe (Int, Int, Int, Int)+viewBoxOfTree (SymbolTree (Symbol g)) = _groupViewBox g+viewBoxOfTree _ = Nothing++geometryOfNamedElement :: RenderContext -> String -> Tree+geometryOfNamedElement ctxt str =+ maybe None extractGeometry . M.lookup str $ _contextDefinitions ctxt+ where+ extractGeometry e = case e of+ ElementLinearGradient _ -> None+ ElementRadialGradient _ -> None+ ElementPattern _ -> None+ ElementMarker _ -> None+ ElementMask _ -> None+ ElementClipPath _ -> None+ ElementGeometry g -> g++imgToPixelRGBA8 :: DynamicImage -> CP.Image PixelRGBA8+imgToPixelRGBA8 img = case img of+ ImageY8 i -> promoteImage i+ ImageY16 i ->+ pixelMap (\y -> let v = w2b y in PixelRGBA8 v v v 255) i+ ImageYF i ->+ pixelMap (\f -> let v = f2b f in PixelRGBA8 v v v 255) i+ ImageYA8 i -> promoteImage i+ ImageYA16 i ->+ pixelMap (\(PixelYA16 y a) -> let v = w2b y in PixelRGBA8 v v v (w2b a)) i+ ImageRGB8 i -> promoteImage i+ ImageRGB16 i -> pixelMap rgb162Rgba8 i+ ImageRGBF i -> pixelMap rgbf2rgba8 i+ ImageRGBA8 i -> i+ ImageRGBA16 i -> pixelMap rgba162Rgba8 i+ ImageYCbCr8 i -> pixelMap (promotePixel . yCbCr2Rgb) i+ ImageCMYK8 i -> pixelMap (promotePixel . cmyk2Rgb) i+ ImageCMYK16 i -> pixelMap (rgb162Rgba8 . convertPixel) i+ where+ yCbCr2Rgb :: PixelYCbCr8 -> PixelRGB8+ yCbCr2Rgb = convertPixel++ cmyk2Rgb :: PixelCMYK8 -> PixelRGB8+ cmyk2Rgb = convertPixel++ w2b v = fromIntegral $ v `div` 257+ f2b :: Float -> Word8+ f2b v = floor . max 0 . min 255 $ v * 255++ rgbf2rgba8 (PixelRGBF r g b) =+ PixelRGBA8 (f2b r) (f2b g) (f2b b) 255+ rgba162Rgba8 (PixelRGBA16 r g b a) =+ PixelRGBA8 (w2b r) (w2b g) (w2b b) (w2b a)+ rgb162Rgba8 (PixelRGB16 r g b)=+ PixelRGBA8 (w2b r) (w2b g) (w2b b) 255+++renderImage :: RenderContext -> DrawAttributes -> Image+ -> IODraw (R.Drawing PixelRGBA8 ())+renderImage ctxt attr imgInfo = do+ let rootFolder = dropFileName $ _basePath ctxt+ realPath = rootFolder </> _imageHref imgInfo+ eimg <- liftIO $ readImage realPath + let srect = RectangleTree $ defaultSvg+ { _rectUpperLeftCorner = _imageCornerUpperLeft imgInfo+ , _rectDrawAttributes =+ _imageDrawAttributes imgInfo & fillColor .~ Last (Just FillNone)+ , _rectWidth = _imageWidth imgInfo+ , _rectHeight = _imageHeight imgInfo+ }++ case eimg of+ Left _ -> renderTree ctxt attr srect+ Right img -> do+ let pAttr = _imageDrawAttributes imgInfo+ info = attr <> pAttr+ context' = mergeContext ctxt pAttr+ p' = linearisePoint context' info $ _imageCornerUpperLeft imgInfo+ w' = lineariseXLength context' info $ _imageWidth imgInfo+ h' = lineariseYLength context' info $ _imageHeight imgInfo+ filling = R.drawImageAtSize (imgToPixelRGBA8 img) 0 p' w' h'+ stroking <- stroker False context' info $ R.rectangle p' w' h'+ return . applyGroupOpacity attr . withTransform pAttr $ filling <> stroking++initialDrawAttributes :: DrawAttributes+initialDrawAttributes = mempty+ { _strokeWidth = Last . Just $ Num 1.0+ , _strokeLineCap = Last $ Just CapButt+ , _strokeLineJoin = Last $ Just JoinMiter+ , _strokeMiterLimit = Last $ Just 4.0+ , _strokeOpacity = Just 1.0+ , _fillColor = Last . Just . ColorRef $ PixelRGBA8 0 0 0 255+ , _fillOpacity = Just 1.0+ , _fillRule = Last $ Just FillNonZero+ , _fontSize = Last . Just $ Num 16+ , _textAnchor = Last $ Just TextAnchorStart+ }+++renderSvg :: RenderContext -> Tree -> IODraw (R.Drawing PixelRGBA8 ())+renderSvg initialContext = renderTree initialContext initialDrawAttributes+++fitBox :: RenderContext -> DrawAttributes+ -> Point -> Maybe Number -> Maybe Number -> Point+ -> Maybe (Int, Int, Int, Int)+ -> R.Drawing px ()+ -> R.Drawing px ()+fitBox ctxt attr basePoint mwidth mheight preTranslate viewbox =+ let origin = linearisePoint ctxt attr basePoint+ preShift = linearisePoint ctxt attr preTranslate+ w = lineariseXLength ctxt attr <$> mwidth+ h = lineariseYLength ctxt attr <$> mheight+ in+ case viewbox of+ Nothing -> R.withTransformation (RT.translate origin)+ (Just (xs, ys, xe, ye)) ->+ let boxOrigin = V2 (fromIntegral xs) (fromIntegral ys)+ boxEnd = V2 (fromIntegral xe) (fromIntegral ye)+ V2 bw bh = abs $ boxEnd ^-^ boxOrigin+ xScaleFactor = case w of+ Just wpx -> wpx / bw+ Nothing -> 1.0+ yScaleFactor = case h of+ Just hpx -> hpx / bh+ Nothing -> 1.0+ in+ R.withTransformation $ RT.translate origin+ <> RT.scale xScaleFactor yScaleFactor+ <> RT.translate (negate boxOrigin ^+^ preShift)++fitUse :: RenderContext -> DrawAttributes -> Use -> Tree+ -> R.Drawing px ()+ -> R.Drawing px ()+fitUse ctxt attr useElement subTree =+ fitBox ctxt attr+ (_useBase useElement)+ (_useWidth useElement)+ (_useHeight useElement)+ (Num 0, Num 0)+ (viewBoxOfTree subTree)++renderTree :: RenderContext -> DrawAttributes -> Tree -> IODraw (R.Drawing PixelRGBA8 ())+renderTree = go where+ go _ _ None = return mempty+ go ctxt attr (TextTree tp stext) = renderText ctxt attr tp stext+ go ctxt attr (ImageTree i) = renderImage ctxt attr i+ go ctxt attr (UseTree useData (Just subTree)) = do+ sub <- go ctxt attr' subTree+ return . fitUse ctxt attr useData subTree+ $ withTransform pAttr sub+ where+ pAttr = _useDrawAttributes useData+ attr' = attr <> pAttr++ go ctxt attr (UseTree useData Nothing) = do+ sub <- go ctxt attr' subTree+ return . fitUse ctxt attr useData subTree+ $ withTransform pAttr sub+ where+ pAttr = _useDrawAttributes useData+ attr' = attr <> pAttr+ subTree = geometryOfNamedElement ctxt $ _useName useData++ go ctxt attr (SymbolTree (Symbol g)) = go ctxt attr $ GroupTree g+ go ctxt attr (GroupTree (Group groupAttr subTrees _)) = do+ subTrees' <- mapM (go context' attr') subTrees+ return . applyGroupOpacity groupAttr+ . withTransform groupAttr $ sequence_ subTrees'+ where attr' = attr <> groupAttr+ context' = mergeContext ctxt groupAttr++ go ctxt attr (RectangleTree (Rectangle pAttr p w h (rx, ry))) = do+ let info = attr <> pAttr+ context' = mergeContext ctxt pAttr+ p' = linearisePoint context' info p+ w' = lineariseXLength context' info w+ h' = lineariseYLength context' info h++ rx' = lineariseXLength context' info rx+ ry' = lineariseXLength context' info ry+ rect = case (rx', ry') of+ (0, 0) -> R.rectangle p' w' h'+ (v, 0) -> R.roundedRectangle p' w' h' v v+ (0, v) -> R.roundedRectangle p' w' h' v v+ (vx, vy) -> R.roundedRectangle p' w' h' vx vy++ filling <- filler context' info rect+ stroking <- stroker False context' info rect+ return . applyGroupOpacity pAttr+ . withTransform pAttr $ filling <> stroking++ go ctxt attr (CircleTree (Circle pAttr p r)) = do+ let info = attr <> pAttr+ context' = mergeContext ctxt pAttr+ p' = linearisePoint context' info p+ r' = lineariseLength context' info r+ c = R.circle p' r'+ filling <- filler context' info c+ stroking <- stroker False context' info c+ return . applyGroupOpacity pAttr+ . withTransform pAttr $ filling <> stroking++ go ctxt attr (EllipseTree (Ellipse pAttr p rx ry)) = do+ let info = attr <> pAttr+ context' = mergeContext ctxt pAttr+ p' = linearisePoint context' info p+ rx' = lineariseXLength context' info rx+ ry' = lineariseYLength context' info ry+ c = R.ellipse p' rx' ry'+ filling <- filler context' info c+ stroking <- stroker False context' info c+ return . applyGroupOpacity pAttr+ . withTransform pAttr $ filling <> stroking++ go ctxt attr (PolyLineTree (PolyLine pAttr points)) =+ go ctxt (dropFillColor attr)+ . PathTree . Path (dropFillColor pAttr)+ $ toPath points+ where+ dropFillColor v = v { _fillColor = Last Nothing }+ toPath [] = []+ toPath (x:xs) =+ [ MoveTo OriginAbsolute [x]+ , LineTo OriginAbsolute xs+ ]++ go ctxt attr (PolygonTree (Polygon pAttr points)) =+ go ctxt attr . PathTree . Path pAttr $ toPath points+ where+ toPath [] = []+ toPath (x:xs) =+ [ MoveTo OriginAbsolute [x]+ , LineTo OriginAbsolute xs+ , EndPath+ ]++ go ctxt attr (LineTree (Line pAttr p1 p2)) = do+ let info = attr <> pAttr+ context' = mergeContext ctxt pAttr+ p1' = linearisePoint context' info p1+ p2' = linearisePoint context' info p2+ stroking <- stroker True context' info $ R.line p1' p2'+ return . applyGroupOpacity pAttr $ withTransform pAttr stroking++ go ctxt attr (PathTree (Path pAttr p)) = do+ let info = attr <> pAttr+ strokePrimitives = svgPathToPrimitives False p+ fillPrimitives = svgPathToPrimitives True p+ filling <- filler ctxt info fillPrimitives+ stroking <- stroker True ctxt info strokePrimitives+ return . applyGroupOpacity pAttr + . withTransform pAttr $ filling <> stroking+
src/Graphics/Rasterific/Svg/RasterificTextRendering.hs view
@@ -1,468 +1,468 @@-{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} -module Graphics.Rasterific.Svg.RasterificTextRendering - ( renderText ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>) ) -import Data.Monoid( mappend, mempty ) -#endif - -import Control.Monad( foldM ) -import Control.Monad.IO.Class( liftIO ) -import Control.Monad.Identity( Identity ) -import Control.Monad.Trans.State.Strict( execState - , StateT - , modify - , gets ) -import Control.Applicative( (<$>), (<|>) ) -import Control.Lens( at, (?=) ) -import qualified Control.Lens as L -import Codec.Picture( PixelRGBA8( .. ) ) -import qualified Data.Foldable as F -import Data.Monoid( (<>), Last( .. ), First( .. ) ) -import Data.Maybe( fromMaybe ) -import qualified Data.Text as T -import Graphics.Rasterific.Linear( (^+^), (^-^) ) -import Graphics.Rasterific hiding ( Path, Line, Texture, transform ) -import qualified Graphics.Rasterific as R -import qualified Graphics.Rasterific.Outline as RO -import Graphics.Rasterific.Immediate -import qualified Graphics.Rasterific.Transformations as RT -import Graphics.Rasterific.PathWalker -import Graphics.Text.TrueType -import Graphics.Svg.Types -import Graphics.Rasterific.Svg.RenderContext -import Graphics.Rasterific.Svg.PathConverter -{-import Graphics.Svg.XmlParser-} - -{-import Debug.Trace-} -{-import Text.Printf-} - -loadFont :: FilePath -> IODraw (Maybe Font) -loadFont fontPath = do - loaded <- L.use $ loadedFonts . at fontPath - case loaded of - Just v -> return $ Just v - Nothing -> do - file <- liftIO $ loadFontFile fontPath - case file of - Left _ -> return Nothing - Right f -> do - loadedFonts . at fontPath ?= f - return $ Just f - -data RenderableString px = RenderableString - { _renderableAttributes :: !DrawAttributes - , _renderableSize :: !Float - , _renderableFont :: !Font - , _renderableString :: ![(Char, CharInfo px)] - } - -data CharInfo px = CharInfo - { _charX :: Maybe Number - , _charY :: Maybe Number - , _charDx :: Maybe Number - , _charDy :: Maybe Number - , _charRotate :: Maybe Float - , _charStroke :: Maybe (Float, R.Texture px, R.Join, (R.Cap, R.Cap)) - } - -emptyCharInfo :: CharInfo px -emptyCharInfo = CharInfo - { _charX = Nothing - , _charY = Nothing - , _charDx = Nothing - , _charDy = Nothing - , _charRotate = Nothing - , _charStroke = Nothing - } - -propagateTextInfo :: TextInfo -> TextInfo -> TextInfo -propagateTextInfo parent current = TextInfo - { _textInfoX = combine _textInfoX - , _textInfoY = combine _textInfoY - , _textInfoDX = combine _textInfoDX - , _textInfoDY = combine _textInfoDY - , _textInfoRotate = combine _textInfoRotate - , _textInfoLength = _textInfoLength current - } - where - combine f = case f current of - [] -> f parent - lst -> lst - -textInfoRests :: TextInfo -> TextInfo -> TextInfo - -> TextInfo -textInfoRests this parent sub = TextInfo - { _textInfoX = decideWith _textInfoX - , _textInfoY = decideWith _textInfoY - , _textInfoDX = decideWith _textInfoDX - , _textInfoDY = decideWith _textInfoDY - , _textInfoRotate = decideWith _textInfoRotate - , _textInfoLength = _textInfoLength parent - } - where - decideWith f = decide (f this) (f parent) (f sub) - - decide [] _ ssub = ssub - decide _ top _ = top - -unconsTextInfo :: RenderContext -> DrawAttributes -> TextInfo - -> IODraw (CharInfo PixelRGBA8, TextInfo) -unconsTextInfo ctxt attr nfo = do - texture <- textureOf ctxt attr _strokeColor _strokeOpacity - return (charInfo texture, restText) - where - unconsInf lst = case lst of - [] -> (Nothing, []) - (x:xs) -> (Just x, xs) - - (xC, xRest) = unconsInf $ _textInfoX nfo - (yC, yRest) = unconsInf $ _textInfoY nfo - (dxC, dxRest) = unconsInf $ _textInfoDX nfo - (dyC, dyRest) = unconsInf $ _textInfoDY nfo - (rotateC, rotateRest) = unconsInf $ _textInfoRotate nfo - - restText = TextInfo - { _textInfoX = xRest - , _textInfoY = yRest - , _textInfoDX = dxRest - , _textInfoDY = dyRest - , _textInfoRotate = rotateRest - , _textInfoLength = _textInfoLength nfo - } - - sWidth = - lineariseLength ctxt attr <$> getLast (_strokeWidth attr) - - charInfo tex = CharInfo - { _charX = xC - , _charY = yC - , _charDx = dxC - , _charDy = dyC - , _charRotate = rotateC - , _charStroke = - (,, joinOfSvg attr, capOfSvg attr) <$> sWidth <*> tex - } - -repeatLast :: [a] -> [a] -repeatLast = go where - go lst = case lst of - [] -> [] - [x] -> repeat x - (x:xs) -> x : go xs - -infinitizeTextInfo :: TextInfo -> TextInfo -infinitizeTextInfo nfo = - nfo { _textInfoRotate = repeatLast $ _textInfoRotate nfo } - - --- | Monadic version of mapAccumL -mapAccumLM :: Monad m - => (acc -> x -> m (acc, y)) -- ^ combining funcction - -> acc -- ^ initial state - -> [x] -- ^ inputs - -> m (acc, [y]) -- ^ final state, outputs -mapAccumLM _ s [] = return (s, []) -mapAccumLM f s (x:xs) = do - (s1, x') <- f s x - (s2, xs') <- mapAccumLM f s1 xs - return (s2, x' : xs') - -mixWithRenderInfo :: RenderContext -> DrawAttributes - -> TextInfo -> String - -> IODraw (TextInfo, [(Char, CharInfo PixelRGBA8)]) -mixWithRenderInfo ctxt attr = mapAccumLM go where - go info c = do - (thisInfo, rest) <- unconsTextInfo ctxt attr info - return (rest, (c, thisInfo)) - - -data LetterTransformerState = LetterTransformerState - { _charactersInfos :: ![CharInfo PixelRGBA8] - , _characterCurrent :: !(CharInfo PixelRGBA8) - , _currentCharDelta :: !R.Point - , _currentAbsoluteDelta :: !R.Point - , _currentDrawing :: Drawing PixelRGBA8 () - , _stringBounds :: !PlaneBound - } - -type GlyphPlacer = StateT LetterTransformerState Identity - -unconsCurrentLetter :: GlyphPlacer () -unconsCurrentLetter = modify $ \s -> - case _charactersInfos s of - [] -> s - (x:xs) -> s { _charactersInfos = xs - , _characterCurrent = x - } - -prepareCharRotation :: CharInfo px -> R.PlaneBound -> RT.Transformation -prepareCharRotation info bounds = case _charRotate info of - Nothing -> mempty - Just angle -> RT.rotateCenter (toRadian angle) lowerLeftCorner - where - lowerLeftCorner = boundLowerLeftCorner bounds - -prepareCharTranslation :: RenderContext -> CharInfo px -> R.PlaneBound - -> R.Point -> R.Point - -> (R.Point, R.Point, RT.Transformation) -prepareCharTranslation ctxt info bounds prevDelta prevAbsolute = go where - lowerLeftCorner = boundLowerLeftCorner bounds - toRPoint a b = linearisePoint ctxt mempty (a, b) - mzero = Just $ Num 0 - V2 pmx pmy = Just . Num <$> prevAbsolute - - mayForcedPoint = case (_charX info, _charY info) of - (Nothing, Nothing) -> Nothing - (mx, my) -> toRPoint <$> (mx <|> pmx) <*> (my <|> pmy) - - delta = fromMaybe 0 $ - toRPoint <$> (_charDx info <|> mzero) - <*> (_charDy info <|> mzero) - - go = case mayForcedPoint of - Nothing -> - let newDelta = prevDelta ^+^ delta - trans = RT.translate $ newDelta ^+^ prevAbsolute in - (newDelta, prevAbsolute, trans) - - Just p -> - let newDelta = prevDelta ^+^ delta - positionDelta = p ^-^ lowerLeftCorner - trans = RT.translate $ positionDelta ^+^ newDelta in - (newDelta, positionDelta, trans) - -transformPlaceGlyph :: RenderContext - -> RT.Transformation - -> R.PlaneBound - -> DrawOrder PixelRGBA8 - -> GlyphPlacer () -transformPlaceGlyph ctxt pathTransformation bounds order = do - unconsCurrentLetter - info <- gets _characterCurrent - delta <- gets _currentCharDelta - absoluteDelta <- gets _currentAbsoluteDelta - let rotateTrans = prepareCharRotation info bounds - (newDelta, newAbsolute, placement) = - prepareCharTranslation ctxt info bounds delta absoluteDelta - finalTrans = pathTransformation <> placement <> rotateTrans - newGeometry = - R.transform (RT.applyTransformation finalTrans) $ _orderPrimitives order - newOrder = order { _orderPrimitives = newGeometry } - - - stroking Nothing = return () - stroking (Just (w, texture, rjoin, cap)) = - orderToDrawing $ newOrder { - _orderPrimitives = stroker <$> _orderPrimitives newOrder, - _orderTexture = texture - } - where - stroker = RO.strokize w rjoin cap - - modify $ \s -> s - { _currentCharDelta = newDelta - , _currentAbsoluteDelta = newAbsolute - , _stringBounds = _stringBounds s <> bounds - , _currentDrawing = do - _currentDrawing s - orderToDrawing newOrder - stroking $ _charStroke info - } - -prepareFontFamilies :: DrawAttributes -> [String] -prepareFontFamilies = (++ defaultFont) - . fmap replaceDefault - . fromMaybe [] - . getLast - . _fontFamily - where - defaultFont = ["Arial"] - -- using "safe" web font, hoping they are present on - -- the system. - replaceDefault s = case s of - "monospace" -> "Courier New" - "sans-serif" -> "Arial" - "serif" -> "Times New Roman" - _ -> s - -fontOfAttributes :: FontCache -> DrawAttributes -> IODraw (Maybe Font) -fontOfAttributes fontCache attr = case fontFilename of - Nothing -> return Nothing - Just fn -> loadFont fn - where - fontFilename = - getFirst . F.foldMap fontFinder $ prepareFontFamilies attr - noStyle = FontStyle - { _fontStyleBold = False - , _fontStyleItalic = False } - - italic = noStyle { _fontStyleItalic = True } - - style = case getLast $ _fontStyle attr of - Nothing -> noStyle - Just FontStyleNormal -> noStyle - Just FontStyleItalic -> italic - Just FontStyleOblique -> italic - - fontFinder ff = - First $ findFontInCache fontCache descriptor - where descriptor = FontDescriptor - { _descriptorFamilyName = T.pack ff - , _descriptorStyle = style } - - -prepareRenderableString :: RenderContext -> DrawAttributes -> Text - -> IODraw [RenderableString PixelRGBA8] -prepareRenderableString ctxt ini_attr root = - fst <$> everySpan ini_attr mempty (_textRoot root) where - - everySpan attr originalInfo tspan = - foldM (everyContent subAttr) (mempty, nfo) $ _spanContent tspan - where - subAttr = attr <> _spanDrawAttributes tspan - nfo = propagateTextInfo originalInfo - . infinitizeTextInfo - $ _spanInfo tspan - - everyContent _attr (acc, info) (SpanTextRef _) = return (acc, info) - everyContent attr (acc, info) (SpanSub thisSpan) = do - let thisTextInfo = _spanInfo thisSpan - (drawn, newInfo) <- everySpan attr info thisSpan - return (acc <> drawn, textInfoRests thisTextInfo info newInfo) - everyContent attr (acc, info) (SpanText txt) = do - font <- fontOfAttributes (_fontCache ctxt) attr - case font of - Nothing -> return (acc, info) - Just f -> do - (info', str) <- mixWithRenderInfo ctxt attr info $ T.unpack txt - let finalStr = RenderableString attr size f str - return (acc <> [finalStr], info') - - where - size = case getLast $ _fontSize attr of - Just v -> lineariseLength ctxt attr v - Nothing -> 16 - - -anchorStringRendering :: TextAnchor -> LetterTransformerState - -> Drawing PixelRGBA8 () -anchorStringRendering anchor st = case anchor of - TextAnchorStart -> _currentDrawing st - TextAnchorMiddle -> - withTransformation (RT.translate (V2 (negate $ stringWidth / 2) 0)) $ - _currentDrawing st - TextAnchorEnd -> - withTransformation (RT.translate (V2 (- stringWidth) 0)) $ _currentDrawing st - where - stringWidth = boundWidth $ _stringBounds st - -notWhiteSpace :: (Char, a) -> Bool -notWhiteSpace (c, _) = c /= ' ' && c /= '\t' - -initialLetterTransformerState :: [RenderableString PixelRGBA8] -> LetterTransformerState -initialLetterTransformerState str = LetterTransformerState - { _charactersInfos = - fmap snd . filter notWhiteSpace . concat $ _renderableString <$> str - , _characterCurrent = emptyCharInfo - , _currentCharDelta = V2 0 0 - , _currentAbsoluteDelta = V2 0 0 - , _currentDrawing = mempty - , _stringBounds = mempty - } - -executePlacer :: Monad m => PathDrawer m px -> [DrawOrder px] -> m () -executePlacer placer = F.mapM_ exec where - exec order | bounds == mempty = return () - | otherwise = placer mempty bounds order - where - bounds = F.foldMap (F.foldMap planeBounds) - $ _orderPrimitives order - -textureOf :: RenderContext - -> DrawAttributes - -> (DrawAttributes -> Last Texture) - -> (DrawAttributes -> Maybe Float) - -> IODraw (Maybe (R.Texture PixelRGBA8)) -textureOf ctxt attr colorAccessor opacityAccessor = - case getLast $ colorAccessor attr of - Nothing -> return Nothing - Just svgTexture -> - prepareTexture ctxt attr svgTexture opacity [] - where opacity = fromMaybe 1.0 $ opacityAccessor attr - -renderString :: RenderContext -> Maybe (Float, R.Path) -> TextAnchor - -> [RenderableString PixelRGBA8] - -> IODraw (Drawing PixelRGBA8 ()) -renderString ctxt mayPath anchor str = do - textRanges <- mapM toFillTextRange str - - case mayPath of - Just (offset, tPath) -> - return . pathPlacer offset tPath $ fillOrders textRanges - Nothing -> return . linePlacer $ fillOrders textRanges - where - fillOrders = - drawOrdersOfDrawing swidth sheight (_renderDpi ctxt) background - . printTextRanges 0 - - pixelToPt s = pixelSizeInPointAtDpi s $ _renderDpi ctxt - (mini, maxi) = _renderViewBox ctxt - V2 swidth sheight = floor <$> (maxi ^-^ mini) - background = PixelRGBA8 0 0 0 0 - - pathPlacer offset tPath = - anchorStringRendering anchor - . flip execState (initialLetterTransformerState str) - . drawOrdersOnPath (transformPlaceGlyph ctxt) offset 0 tPath - - linePlacer = - anchorStringRendering anchor - . flip execState (initialLetterTransformerState str) - . executePlacer (transformPlaceGlyph ctxt) - - toFillTextRange renderable = do - mayTexture <- textureOf ctxt (_renderableAttributes renderable) - _fillColor _fillOpacity - return TextRange - { _textFont = _renderableFont renderable - , _textSize = pixelToPt $ _renderableSize renderable - , _text = fst <$> _renderableString renderable - , _textTexture = mayTexture - } - -startOffsetOfPath :: RenderContext -> DrawAttributes -> R.Path -> Number - -> Float -startOffsetOfPath _ _ _ (Num i) = i -startOffsetOfPath _ attr _ (Em i) = emTransform attr i -startOffsetOfPath _ _ tPath (Percent p) = - p * RO.approximatePathLength tPath -startOffsetOfPath ctxt attr tPath num = - startOffsetOfPath ctxt attr tPath $ stripUnits ctxt num - -renderText :: RenderContext - -> DrawAttributes - -> Maybe TextPath - -> Text - -> IODraw (Drawing PixelRGBA8 ()) -renderText ctxt attr ppath stext = - prepareRenderableString ctxt attr stext >>= renderString ctxt pathInfo anchor - where - renderPath = - svgPathToRasterificPath False . _textPathData <$> ppath - - offset = do - rpath <- renderPath - mayOffset <- _textPathStartOffset <$> ppath - return $ startOffsetOfPath ctxt attr rpath mayOffset - - pathInfo = (,) <$> (offset <|> return 0) <*> renderPath - - anchor = fromMaybe TextAnchorStart - . getLast - . _textAnchor - . mappend attr - . _spanDrawAttributes $ _textRoot stext - +{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Svg.RasterificTextRendering+ ( renderText ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+import Data.Monoid( mappend, mempty )+#endif++import Control.Monad( foldM )+import Control.Monad.IO.Class( liftIO )+import Control.Monad.Identity( Identity )+import Control.Monad.Trans.State.Strict( execState+ , StateT+ , modify+ , gets )+import Control.Applicative( (<|>) )+import Control.Lens( at, (?=) )+import qualified Control.Lens as L+import Codec.Picture( PixelRGBA8( .. ) )+import qualified Data.Foldable as F+import Data.Monoid( (<>), Last( .. ), First( .. ) )+import Data.Maybe( fromMaybe )+import qualified Data.Text as T+import Graphics.Rasterific.Linear( (^+^), (^-^) )+import Graphics.Rasterific hiding ( Path, Line, Texture, transform )+import qualified Graphics.Rasterific as R+import qualified Graphics.Rasterific.Outline as RO+import Graphics.Rasterific.Immediate+import qualified Graphics.Rasterific.Transformations as RT+import Graphics.Rasterific.PathWalker+import Graphics.Text.TrueType+import Graphics.Svg.Types+import Graphics.Rasterific.Svg.RenderContext+import Graphics.Rasterific.Svg.PathConverter+{-import Graphics.Svg.XmlParser-}++{-import Debug.Trace-}+{-import Text.Printf-}++loadFont :: FilePath -> IODraw (Maybe Font)+loadFont fontPath = do+ loaded <- L.use $ loadedFonts . at fontPath+ case loaded of+ Just v -> return $ Just v+ Nothing -> do+ file <- liftIO $ loadFontFile fontPath+ case file of+ Left _ -> return Nothing+ Right f -> do+ loadedFonts . at fontPath ?= f+ return $ Just f++data RenderableString px = RenderableString+ { _renderableAttributes :: !DrawAttributes+ , _renderableSize :: !Float+ , _renderableFont :: !Font+ , _renderableString :: ![(Char, CharInfo px)]+ }++data CharInfo px = CharInfo+ { _charX :: Maybe Number+ , _charY :: Maybe Number+ , _charDx :: Maybe Number+ , _charDy :: Maybe Number+ , _charRotate :: Maybe Float+ , _charStroke :: Maybe (Float, R.Texture px, R.Join, (R.Cap, R.Cap))+ }++emptyCharInfo :: CharInfo px+emptyCharInfo = CharInfo+ { _charX = Nothing+ , _charY = Nothing+ , _charDx = Nothing+ , _charDy = Nothing+ , _charRotate = Nothing+ , _charStroke = Nothing+ }++propagateTextInfo :: TextInfo -> TextInfo -> TextInfo+propagateTextInfo parent current = TextInfo+ { _textInfoX = combine _textInfoX+ , _textInfoY = combine _textInfoY+ , _textInfoDX = combine _textInfoDX+ , _textInfoDY = combine _textInfoDY+ , _textInfoRotate = combine _textInfoRotate+ , _textInfoLength = _textInfoLength current+ }+ where+ combine f = case f current of+ [] -> f parent+ lst -> lst++textInfoRests :: TextInfo -> TextInfo -> TextInfo+ -> TextInfo+textInfoRests this parent sub = TextInfo+ { _textInfoX = decideWith _textInfoX+ , _textInfoY = decideWith _textInfoY+ , _textInfoDX = decideWith _textInfoDX+ , _textInfoDY = decideWith _textInfoDY+ , _textInfoRotate = decideWith _textInfoRotate+ , _textInfoLength = _textInfoLength parent+ }+ where+ decideWith f = decide (f this) (f parent) (f sub)++ decide [] _ ssub = ssub + decide _ top _ = top++unconsTextInfo :: RenderContext -> DrawAttributes -> TextInfo+ -> IODraw (CharInfo PixelRGBA8, TextInfo)+unconsTextInfo ctxt attr nfo = do+ texture <- textureOf ctxt attr _strokeColor _strokeOpacity+ return (charInfo texture, restText)+ where+ unconsInf lst = case lst of+ [] -> (Nothing, [])+ (x:xs) -> (Just x, xs)++ (xC, xRest) = unconsInf $ _textInfoX nfo+ (yC, yRest) = unconsInf $ _textInfoY nfo+ (dxC, dxRest) = unconsInf $ _textInfoDX nfo+ (dyC, dyRest) = unconsInf $ _textInfoDY nfo+ (rotateC, rotateRest) = unconsInf $ _textInfoRotate nfo++ restText = TextInfo+ { _textInfoX = xRest+ , _textInfoY = yRest+ , _textInfoDX = dxRest+ , _textInfoDY = dyRest+ , _textInfoRotate = rotateRest+ , _textInfoLength = _textInfoLength nfo+ }++ sWidth =+ lineariseLength ctxt attr <$> getLast (_strokeWidth attr)++ charInfo tex = CharInfo+ { _charX = xC+ , _charY = yC+ , _charDx = dxC+ , _charDy = dyC+ , _charRotate = rotateC+ , _charStroke =+ (,, joinOfSvg attr, capOfSvg attr) <$> sWidth <*> tex+ }++repeatLast :: [a] -> [a]+repeatLast = go where+ go lst = case lst of+ [] -> []+ [x] -> repeat x+ (x:xs) -> x : go xs++infinitizeTextInfo :: TextInfo -> TextInfo+infinitizeTextInfo nfo =+ nfo { _textInfoRotate = repeatLast $ _textInfoRotate nfo }+++-- | Monadic version of mapAccumL+mapAccumLM :: Monad m+ => (acc -> x -> m (acc, y)) -- ^ combining funcction+ -> acc -- ^ initial state+ -> [x] -- ^ inputs+ -> m (acc, [y]) -- ^ final state, outputs+mapAccumLM _ s [] = return (s, [])+mapAccumLM f s (x:xs) = do+ (s1, x') <- f s x+ (s2, xs') <- mapAccumLM f s1 xs+ return (s2, x' : xs')++mixWithRenderInfo :: RenderContext -> DrawAttributes+ -> TextInfo -> String+ -> IODraw (TextInfo, [(Char, CharInfo PixelRGBA8)])+mixWithRenderInfo ctxt attr = mapAccumLM go where+ go info c = do+ (thisInfo, rest) <- unconsTextInfo ctxt attr info+ return (rest, (c, thisInfo))+++data LetterTransformerState = LetterTransformerState + { _charactersInfos :: ![CharInfo PixelRGBA8]+ , _characterCurrent :: !(CharInfo PixelRGBA8)+ , _currentCharDelta :: !R.Point+ , _currentAbsoluteDelta :: !R.Point+ , _currentDrawing :: Drawing PixelRGBA8 ()+ , _stringBounds :: !PlaneBound+ }++type GlyphPlacer = StateT LetterTransformerState Identity++unconsCurrentLetter :: GlyphPlacer ()+unconsCurrentLetter = modify $ \s ->+ case _charactersInfos s of+ [] -> s+ (x:xs) -> s { _charactersInfos = xs+ , _characterCurrent = x+ }++prepareCharRotation :: CharInfo px -> R.PlaneBound -> RT.Transformation+prepareCharRotation info bounds = case _charRotate info of+ Nothing -> mempty+ Just angle -> RT.rotateCenter (toRadian angle) lowerLeftCorner+ where+ lowerLeftCorner = boundLowerLeftCorner bounds++prepareCharTranslation :: RenderContext -> CharInfo px -> R.PlaneBound+ -> R.Point -> R.Point+ -> (R.Point, R.Point, RT.Transformation)+prepareCharTranslation ctxt info bounds prevDelta prevAbsolute = go where+ lowerLeftCorner = boundLowerLeftCorner bounds+ toRPoint a b = linearisePoint ctxt mempty (a, b)+ mzero = Just $ Num 0+ V2 pmx pmy = Just . Num <$> prevAbsolute++ mayForcedPoint = case (_charX info, _charY info) of+ (Nothing, Nothing) -> Nothing+ (mx, my) -> toRPoint <$> (mx <|> pmx) <*> (my <|> pmy)++ delta = fromMaybe 0 $+ toRPoint <$> (_charDx info <|> mzero)+ <*> (_charDy info <|> mzero)++ go = case mayForcedPoint of+ Nothing ->+ let newDelta = prevDelta ^+^ delta+ trans = RT.translate $ newDelta ^+^ prevAbsolute in+ (newDelta, prevAbsolute, trans)++ Just p ->+ let newDelta = prevDelta ^+^ delta+ positionDelta = p ^-^ lowerLeftCorner+ trans = RT.translate $ positionDelta ^+^ newDelta in+ (newDelta, positionDelta, trans)++transformPlaceGlyph :: RenderContext+ -> RT.Transformation+ -> R.PlaneBound+ -> DrawOrder PixelRGBA8+ -> GlyphPlacer ()+transformPlaceGlyph ctxt pathTransformation bounds order = do+ unconsCurrentLetter + info <- gets _characterCurrent+ delta <- gets _currentCharDelta+ absoluteDelta <- gets _currentAbsoluteDelta+ let rotateTrans = prepareCharRotation info bounds+ (newDelta, newAbsolute, placement) =+ prepareCharTranslation ctxt info bounds delta absoluteDelta+ finalTrans = pathTransformation <> placement <> rotateTrans+ newGeometry =+ R.transform (RT.applyTransformation finalTrans) $ _orderPrimitives order+ newOrder = order { _orderPrimitives = newGeometry }++ + stroking Nothing = return ()+ stroking (Just (w, texture, rjoin, cap)) =+ orderToDrawing $ newOrder {+ _orderPrimitives = stroker <$> _orderPrimitives newOrder,+ _orderTexture = texture+ }+ where+ stroker = RO.strokize w rjoin cap++ modify $ \s -> s+ { _currentCharDelta = newDelta+ , _currentAbsoluteDelta = newAbsolute+ , _stringBounds = _stringBounds s <> bounds+ , _currentDrawing = do+ _currentDrawing s+ orderToDrawing newOrder+ stroking $ _charStroke info+ }++prepareFontFamilies :: DrawAttributes -> [String]+prepareFontFamilies = (++ defaultFont)+ . fmap replaceDefault+ . fromMaybe []+ . getLast + . _fontFamily+ where+ defaultFont = ["Arial"]+ -- using "safe" web font, hoping they are present on+ -- the system.+ replaceDefault s = case s of+ "monospace" -> "Courier New"+ "sans-serif" -> "Arial"+ "serif" -> "Times New Roman"+ _ -> s++fontOfAttributes :: FontCache -> DrawAttributes -> IODraw (Maybe Font)+fontOfAttributes fontCache attr = case fontFilename of+ Nothing -> return Nothing+ Just fn -> loadFont fn+ where+ fontFilename =+ getFirst . F.foldMap fontFinder $ prepareFontFamilies attr+ noStyle = FontStyle+ { _fontStyleBold = False+ , _fontStyleItalic = False }++ italic = noStyle { _fontStyleItalic = True }++ style = case getLast $ _fontStyle attr of+ Nothing -> noStyle+ Just FontStyleNormal -> noStyle+ Just FontStyleItalic -> italic+ Just FontStyleOblique -> italic++ fontFinder ff =+ First $ findFontInCache fontCache descriptor+ where descriptor = FontDescriptor+ { _descriptorFamilyName = T.pack ff+ , _descriptorStyle = style }+++prepareRenderableString :: RenderContext -> DrawAttributes -> Text+ -> IODraw [RenderableString PixelRGBA8]+prepareRenderableString ctxt ini_attr root =+ fst <$> everySpan ini_attr mempty (_textRoot root) where++ everySpan attr originalInfo tspan =+ foldM (everyContent subAttr) (mempty, nfo) $ _spanContent tspan+ where+ subAttr = attr <> _spanDrawAttributes tspan+ nfo = propagateTextInfo originalInfo+ . infinitizeTextInfo+ $ _spanInfo tspan++ everyContent _attr (acc, info) (SpanTextRef _) = return (acc, info)+ everyContent attr (acc, info) (SpanSub thisSpan) = do+ let thisTextInfo = _spanInfo thisSpan+ (drawn, newInfo) <- everySpan attr info thisSpan+ return (acc <> drawn, textInfoRests thisTextInfo info newInfo)+ everyContent attr (acc, info) (SpanText txt) = do+ font <- fontOfAttributes (_fontCache ctxt) attr+ case font of+ Nothing -> return (acc, info)+ Just f -> do+ (info', str) <- mixWithRenderInfo ctxt attr info $ T.unpack txt+ let finalStr = RenderableString attr size f str+ return (acc <> [finalStr], info')+ + where+ size = case getLast $ _fontSize attr of+ Just v -> lineariseLength ctxt attr v+ Nothing -> 16+++anchorStringRendering :: TextAnchor -> LetterTransformerState+ -> Drawing PixelRGBA8 ()+anchorStringRendering anchor st = case anchor of+ TextAnchorStart -> _currentDrawing st+ TextAnchorMiddle ->+ withTransformation (RT.translate (V2 (negate $ stringWidth / 2) 0)) $+ _currentDrawing st+ TextAnchorEnd ->+ withTransformation (RT.translate (V2 (- stringWidth) 0)) $ _currentDrawing st+ where+ stringWidth = boundWidth $ _stringBounds st++notWhiteSpace :: (Char, a) -> Bool+notWhiteSpace (c, _) = c /= ' ' && c /= '\t'++initialLetterTransformerState :: [RenderableString PixelRGBA8] -> LetterTransformerState+initialLetterTransformerState str = LetterTransformerState + { _charactersInfos =+ fmap snd . filter notWhiteSpace . concat $ _renderableString <$> str+ , _characterCurrent = emptyCharInfo+ , _currentCharDelta = V2 0 0+ , _currentAbsoluteDelta = V2 0 0+ , _currentDrawing = mempty+ , _stringBounds = mempty+ }++executePlacer :: Monad m => PathDrawer m px -> [DrawOrder px] -> m ()+executePlacer placer = F.mapM_ exec where+ exec order | bounds == mempty = return ()+ | otherwise = placer mempty bounds order+ where+ bounds = F.foldMap (F.foldMap planeBounds)+ $ _orderPrimitives order++textureOf :: RenderContext+ -> DrawAttributes+ -> (DrawAttributes -> Last Texture)+ -> (DrawAttributes -> Maybe Float)+ -> IODraw (Maybe (R.Texture PixelRGBA8))+textureOf ctxt attr colorAccessor opacityAccessor =+ case getLast $ colorAccessor attr of+ Nothing -> return Nothing+ Just svgTexture ->+ prepareTexture ctxt attr svgTexture opacity []+ where opacity = fromMaybe 1.0 $ opacityAccessor attr+ +renderString :: RenderContext -> Maybe (Float, R.Path) -> TextAnchor+ -> [RenderableString PixelRGBA8]+ -> IODraw (Drawing PixelRGBA8 ())+renderString ctxt mayPath anchor str = do+ textRanges <- mapM toFillTextRange str++ case mayPath of+ Just (offset, tPath) ->+ return . pathPlacer offset tPath $ fillOrders textRanges+ Nothing -> return . linePlacer $ fillOrders textRanges+ where+ fillOrders =+ drawOrdersOfDrawing swidth sheight (_renderDpi ctxt) background+ . printTextRanges 0++ pixelToPt s = pixelSizeInPointAtDpi s $ _renderDpi ctxt+ (mini, maxi) = _renderViewBox ctxt+ V2 swidth sheight = floor <$> (maxi ^-^ mini)+ background = PixelRGBA8 0 0 0 0++ pathPlacer offset tPath =+ anchorStringRendering anchor+ . flip execState (initialLetterTransformerState str)+ . drawOrdersOnPath (transformPlaceGlyph ctxt) offset 0 tPath++ linePlacer =+ anchorStringRendering anchor+ . flip execState (initialLetterTransformerState str)+ . executePlacer (transformPlaceGlyph ctxt)+ + toFillTextRange renderable = do+ mayTexture <- textureOf ctxt (_renderableAttributes renderable)+ _fillColor _fillOpacity + return TextRange+ { _textFont = _renderableFont renderable+ , _textSize = pixelToPt $ _renderableSize renderable+ , _text = fst <$> _renderableString renderable+ , _textTexture = mayTexture+ }++startOffsetOfPath :: RenderContext -> DrawAttributes -> R.Path -> Number+ -> Float+startOffsetOfPath _ _ _ (Num i) = i+startOffsetOfPath _ attr _ (Em i) = emTransform attr i+startOffsetOfPath _ _ tPath (Percent p) =+ p * RO.approximatePathLength tPath+startOffsetOfPath ctxt attr tPath num =+ startOffsetOfPath ctxt attr tPath $ stripUnits ctxt num++renderText :: RenderContext+ -> DrawAttributes+ -> Maybe TextPath+ -> Text+ -> IODraw (Drawing PixelRGBA8 ())+renderText ctxt attr ppath stext =+ prepareRenderableString ctxt attr stext >>= renderString ctxt pathInfo anchor+ where+ renderPath =+ svgPathToRasterificPath False . _textPathData <$> ppath++ offset = do+ rpath <- renderPath+ mayOffset <- _textPathStartOffset <$> ppath+ return $ startOffsetOfPath ctxt attr rpath mayOffset++ pathInfo = (,) <$> (offset <|> return 0) <*> renderPath++ anchor = fromMaybe TextAnchorStart+ . getLast+ . _textAnchor+ . mappend attr+ . _spanDrawAttributes $ _textRoot stext+
src/Graphics/Rasterific/Svg/RenderContext.hs view
@@ -1,280 +1,280 @@-{-# LANGUAGE CPP #-} -module Graphics.Rasterific.Svg.RenderContext - ( RenderContext( .. ) - , LoadedElements( .. ) - , loadedFonts - , loadedImages - , IODraw - , ViewBox - , toRadian - , capOfSvg - , joinOfSvg - , stripUnits - , boundingBoxLength - , lineariseXLength - , lineariseYLength - , linearisePoint - , lineariseLength - , prepareTexture - , documentOfPattern - , fillAlphaCombine - , fillMethodOfSvg - , emTransform - ) - where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( .. ) ) -#endif - -import Control.Monad.Trans.State.Strict( StateT ) -import Control.Applicative( (<$>) ) -import Codec.Picture( PixelRGBA8( .. ) ) -import qualified Codec.Picture as CP -import qualified Data.Foldable as F -import qualified Data.Map as M -import Data.Monoid( Last( .. ) ) -import Control.Lens( Lens', lens ) - -import Graphics.Rasterific.Linear( (^-^) ) -import qualified Graphics.Rasterific as R -import qualified Graphics.Rasterific.Texture as RT -import Graphics.Text.TrueType -import Graphics.Svg.Types - -toRadian :: Float -> Float -toRadian v = v / 180 * pi - -data RenderContext = RenderContext - { _initialViewBox :: (R.Point, R.Point) - , _renderViewBox :: (R.Point, R.Point) - , _renderDpi :: Int - , _contextDefinitions :: M.Map String Element - , _fontCache :: FontCache - , _subRender :: Document -> IODraw (CP.Image PixelRGBA8) - , _basePath :: FilePath - } - -data LoadedElements = LoadedElements - { _loadedFonts :: M.Map FilePath Font - , _loadedImages :: M.Map FilePath (CP.Image PixelRGBA8) - } - -instance Monoid LoadedElements where - mempty = LoadedElements mempty mempty - mappend (LoadedElements a b) (LoadedElements a' b') = - LoadedElements (a `mappend` a') (b `mappend` b') - -loadedFonts :: Lens' LoadedElements (M.Map FilePath Font) -loadedFonts = lens _loadedFonts (\a b -> a { _loadedFonts = b }) - -loadedImages :: Lens' LoadedElements (M.Map FilePath (CP.Image PixelRGBA8)) -loadedImages = lens _loadedImages (\a b -> a { _loadedImages = b }) - -type IODraw = StateT LoadedElements IO - -type ViewBox = (R.Point, R.Point) - -capOfSvg :: DrawAttributes -> (R.Cap, R.Cap) -capOfSvg attrs = - case getLast $ _strokeLineCap attrs of - Nothing -> (R.CapStraight 1, R.CapStraight 1) - Just CapSquare -> (R.CapStraight 1, R.CapStraight 1) - Just CapButt -> (R.CapStraight 0, R.CapStraight 0) - Just CapRound -> (R.CapRound, R.CapRound) - - -joinOfSvg :: DrawAttributes -> R.Join -joinOfSvg attrs = - case (getLast $ _strokeLineJoin attrs, getLast $ _strokeMiterLimit attrs) of - (Nothing, _) -> R.JoinRound - (Just JoinMiter, Just _) -> R.JoinMiter 0 - (Just JoinMiter, Nothing) -> R.JoinMiter 0 - (Just JoinBevel, _) -> R.JoinMiter 5 - (Just JoinRound, _) -> R.JoinRound - -stripUnits :: RenderContext -> Number -> Number -stripUnits ctxt = toUserUnit (_renderDpi ctxt) - -boundingBoxLength :: RenderContext -> DrawAttributes -> R.PlaneBound -> Number - -> Float -boundingBoxLength ctxt attr (R.PlaneBound mini maxi) = go where - R.V2 actualWidth actualHeight = - abs <$> (maxi ^-^ mini) - two = 2 :: Int - coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two) - / sqrt 2 - go num = case num of - Num n -> n - Em n -> emTransform attr n - Percent p -> p * coeff - _ -> go $ stripUnits ctxt num - -boundbingBoxLinearise :: RenderContext -> DrawAttributes -> R.PlaneBound -> Point - -> R.Point -boundbingBoxLinearise - ctxt attr (R.PlaneBound mini@(R.V2 xi yi) maxi) (xp, yp) = R.V2 (finalX xp) (finalY yp) - where - R.V2 w h = abs <$> (maxi ^-^ mini) - finalX nu = case nu of - Num n -> n - Em n -> emTransform attr n - Percent p -> p * w + xi - _ -> finalX $ stripUnits ctxt nu - - finalY nu = case nu of - Num n -> n - Em n -> emTransform attr n - Percent p -> p * h + yi - _ -> finalY $ stripUnits ctxt nu - -lineariseXLength :: RenderContext -> DrawAttributes -> Number - -> Coord -lineariseXLength _ _ (Num i) = i -lineariseXLength _ attr (Em i) = emTransform attr i -lineariseXLength ctxt _ (Percent p) = abs (xe - xs) * p - where - (R.V2 xs _, R.V2 xe _) = _renderViewBox ctxt -lineariseXLength ctxt attr num = - lineariseXLength ctxt attr $ stripUnits ctxt num - -lineariseYLength :: RenderContext -> DrawAttributes -> Number - -> Coord -lineariseYLength _ _ (Num i) = i -lineariseYLength _ attr (Em n) = emTransform attr n -lineariseYLength ctxt _ (Percent p) = abs (ye - ys) * p - where - (R.V2 _ ys, R.V2 _ ye) = _renderViewBox ctxt -lineariseYLength ctxt attr num = - lineariseYLength ctxt attr $ stripUnits ctxt num - - -linearisePoint :: RenderContext -> DrawAttributes -> Point - -> R.Point -linearisePoint ctxt attr (p1, p2) = - R.V2 (xs + lineariseXLength ctxt attr p1) - (ys + lineariseYLength ctxt attr p2) - where (R.V2 xs ys, _) = _renderViewBox ctxt - -emTransform :: DrawAttributes -> Float -> Float -emTransform attr n = case getLast $ _fontSize attr of - Nothing -> 16 * n - Just (Num v) -> v * n - Just _ -> 16 * n - -lineariseLength :: RenderContext -> DrawAttributes -> Number - -> Coord -lineariseLength _ _ (Num i) = i -lineariseLength _ attr (Em i) = - emTransform attr i -lineariseLength ctxt _ (Percent v) = v * coeff - where - (R.V2 x1 y1, R.V2 x2 y2) = _renderViewBox ctxt - actualWidth = abs $ x2 - x1 - actualHeight = abs $ y2 - y1 - two = 2 :: Int - coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two) - / sqrt 2 -lineariseLength ctxt attr num = - lineariseLength ctxt attr $ stripUnits ctxt num - -prepareLinearGradientTexture - :: RenderContext -> DrawAttributes - -> LinearGradient -> Float -> [R.Primitive] - -> R.Texture PixelRGBA8 -prepareLinearGradientTexture ctxt attr grad opa prims = - let bounds = F.foldMap R.planeBounds prims - lineariser = case _linearGradientUnits grad of - CoordUserSpace -> linearisePoint ctxt attr - CoordBoundingBox -> boundbingBoxLinearise ctxt attr bounds - gradient = - [(offset, fillAlphaCombine opa color) - | GradientStop offset color <- _linearGradientStops grad] - startPoint = lineariser $ _linearGradientStart grad - stopPoint = lineariser $ _linearGradientStop grad - in - RT.linearGradientTexture gradient startPoint stopPoint - -prepareRadialGradientTexture - :: RenderContext -> DrawAttributes - -> RadialGradient -> Float -> [R.Primitive] - -> R.Texture PixelRGBA8 -prepareRadialGradientTexture ctxt attr grad opa prims = - let bounds = F.foldMap R.planeBounds prims - (lineariser, lengthLinearise) = case _radialGradientUnits grad of - CoordUserSpace -> - (linearisePoint ctxt attr, lineariseLength ctxt attr) - CoordBoundingBox -> - (boundbingBoxLinearise ctxt attr bounds, - boundingBoxLength ctxt attr bounds) - gradient = - [(offset, fillAlphaCombine opa color) - | GradientStop offset color <- _radialGradientStops grad] - center = lineariser $ _radialGradientCenter grad - radius = lengthLinearise $ _radialGradientRadius grad - in - case (_radialGradientFocusX grad, - _radialGradientFocusY grad) of - (Nothing, Nothing) -> - RT.radialGradientTexture gradient center radius - (Just fx, Nothing) -> - RT.radialGradientWithFocusTexture gradient center radius - $ lineariser (fx, snd $ _radialGradientCenter grad) - (Nothing, Just fy) -> - RT.radialGradientWithFocusTexture gradient center radius - $ lineariser (fst $ _radialGradientCenter grad, fy) - (Just fx, Just fy) -> - RT.radialGradientWithFocusTexture gradient center radius - $ lineariser (fx, fy) - -fillMethodOfSvg :: DrawAttributes -> R.FillMethod -fillMethodOfSvg attr = case getLast $ _fillRule attr of - Nothing -> R.FillWinding - Just FillNonZero -> R.FillWinding - Just FillEvenOdd -> R.FillEvenOdd - -fillAlphaCombine :: Float -> PixelRGBA8 -> PixelRGBA8 -fillAlphaCombine opacity (PixelRGBA8 r g b a) = - PixelRGBA8 r g b alpha - where - a' = fromIntegral a / 255.0 - alpha = floor . max 0 . min 255 $ opacity * a' * 255 - -documentOfPattern :: Pattern -> String -> Document -documentOfPattern pat loc = Document - { _viewBox = _patternViewBox pat - , _width = return $ _patternWidth pat - , _height = return $ _patternHeight pat - , _elements = _patternElements pat - , _definitions = M.empty - , _styleRules = [] - , _description = "" - , _documentLocation = loc - } - -prepareTexture :: RenderContext -> DrawAttributes - -> Texture -> Float - -> [R.Primitive] - -> IODraw (Maybe (R.Texture PixelRGBA8)) -prepareTexture _ _ FillNone _opacity _ = return Nothing -prepareTexture _ _ (ColorRef color) opacity _ = - return . Just . RT.uniformTexture $ fillAlphaCombine opacity color -prepareTexture ctxt attr (TextureRef ref) opacity prims = - maybe (return Nothing) prepare $ - M.lookup ref (_contextDefinitions ctxt) - where - prepare (ElementGeometry _) = return Nothing - prepare (ElementMarker _) = return Nothing - prepare (ElementMask _) = return Nothing - prepare (ElementClipPath _) = return Nothing - prepare (ElementLinearGradient grad) = - return . Just $ prepareLinearGradientTexture ctxt - attr grad opacity prims - prepare (ElementRadialGradient grad) = - return . Just $ prepareRadialGradientTexture ctxt - attr grad opacity prims - prepare (ElementPattern pat) = do - patternPicture <- _subRender ctxt $ documentOfPattern pat (_basePath ctxt) - return . Just . RT.withSampler R.SamplerRepeat - $ RT.sampledImageTexture patternPicture - +{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Svg.RenderContext+ ( RenderContext( .. )+ , LoadedElements( .. )+ , loadedFonts+ , loadedImages+ , IODraw+ , ViewBox+ , toRadian+ , capOfSvg+ , joinOfSvg + , stripUnits+ , boundingBoxLength+ , lineariseXLength+ , lineariseYLength+ , linearisePoint+ , lineariseLength+ , prepareTexture+ , documentOfPattern+ , fillAlphaCombine+ , fillMethodOfSvg+ , emTransform+ )+ where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+import Data.Monoid( Monoid( .. ) )+#endif++import Control.Monad.Trans.State.Strict( StateT )+import Codec.Picture( PixelRGBA8( .. ) )+import qualified Codec.Picture as CP+import qualified Data.Foldable as F+import qualified Data.Map as M+import Data.Monoid( Last( .. ) )+import Control.Lens( Lens', lens )++import Graphics.Rasterific.Linear( (^-^) )+import qualified Graphics.Rasterific as R+import qualified Graphics.Rasterific.Texture as RT+import Graphics.Text.TrueType+import Graphics.Svg.Types++toRadian :: Float -> Float+toRadian v = v / 180 * pi++data RenderContext = RenderContext+ { _initialViewBox :: (R.Point, R.Point)+ , _renderViewBox :: (R.Point, R.Point)+ , _renderDpi :: Int+ , _contextDefinitions :: M.Map String Element+ , _fontCache :: FontCache+ , _subRender :: Document -> IODraw (CP.Image PixelRGBA8)+ , _basePath :: FilePath+ }++data LoadedElements = LoadedElements+ { _loadedFonts :: M.Map FilePath Font+ , _loadedImages :: M.Map FilePath (CP.Image PixelRGBA8)+ }++instance Monoid LoadedElements where+ mempty = LoadedElements mempty mempty+ mappend (LoadedElements a b) (LoadedElements a' b') =+ LoadedElements (a `mappend` a') (b `mappend` b')++loadedFonts :: Lens' LoadedElements (M.Map FilePath Font)+loadedFonts = lens _loadedFonts (\a b -> a { _loadedFonts = b })++loadedImages :: Lens' LoadedElements (M.Map FilePath (CP.Image PixelRGBA8))+loadedImages = lens _loadedImages (\a b -> a { _loadedImages = b })++type IODraw = StateT LoadedElements IO++type ViewBox = (R.Point, R.Point)++capOfSvg :: DrawAttributes -> (R.Cap, R.Cap)+capOfSvg attrs =+ case getLast $ _strokeLineCap attrs of+ Nothing -> (R.CapStraight 1, R.CapStraight 1)+ Just CapSquare -> (R.CapStraight 1, R.CapStraight 1)+ Just CapButt -> (R.CapStraight 0, R.CapStraight 0)+ Just CapRound -> (R.CapRound, R.CapRound)+++joinOfSvg :: DrawAttributes -> R.Join+joinOfSvg attrs =+ case (getLast $ _strokeLineJoin attrs, getLast $ _strokeMiterLimit attrs) of+ (Nothing, _) -> R.JoinRound+ (Just JoinMiter, Just _) -> R.JoinMiter 0+ (Just JoinMiter, Nothing) -> R.JoinMiter 0+ (Just JoinBevel, _) -> R.JoinMiter 5+ (Just JoinRound, _) -> R.JoinRound++stripUnits :: RenderContext -> Number -> Number+stripUnits ctxt = toUserUnit (_renderDpi ctxt)++boundingBoxLength :: RenderContext -> DrawAttributes -> R.PlaneBound -> Number+ -> Float+boundingBoxLength ctxt attr (R.PlaneBound mini maxi) = go where+ R.V2 actualWidth actualHeight =+ abs <$> (maxi ^-^ mini)+ two = 2 :: Int+ coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two)+ / sqrt 2+ go num = case num of+ Num n -> n+ Em n -> emTransform attr n+ Percent p -> p * coeff+ _ -> go $ stripUnits ctxt num++boundbingBoxLinearise :: RenderContext -> DrawAttributes -> R.PlaneBound -> Point+ -> R.Point+boundbingBoxLinearise+ ctxt attr (R.PlaneBound mini@(R.V2 xi yi) maxi) (xp, yp) = R.V2 (finalX xp) (finalY yp)+ where+ R.V2 w h = abs <$> (maxi ^-^ mini)+ finalX nu = case nu of+ Num n -> n+ Em n -> emTransform attr n+ Percent p -> p * w + xi+ _ -> finalX $ stripUnits ctxt nu++ finalY nu = case nu of+ Num n -> n+ Em n -> emTransform attr n+ Percent p -> p * h + yi+ _ -> finalY $ stripUnits ctxt nu++lineariseXLength :: RenderContext -> DrawAttributes -> Number+ -> Coord+lineariseXLength _ _ (Num i) = i+lineariseXLength _ attr (Em i) = emTransform attr i+lineariseXLength ctxt _ (Percent p) = abs (xe - xs) * p+ where+ (R.V2 xs _, R.V2 xe _) = _renderViewBox ctxt+lineariseXLength ctxt attr num =+ lineariseXLength ctxt attr $ stripUnits ctxt num++lineariseYLength :: RenderContext -> DrawAttributes -> Number+ -> Coord+lineariseYLength _ _ (Num i) = i+lineariseYLength _ attr (Em n) = emTransform attr n+lineariseYLength ctxt _ (Percent p) = abs (ye - ys) * p+ where+ (R.V2 _ ys, R.V2 _ ye) = _renderViewBox ctxt+lineariseYLength ctxt attr num =+ lineariseYLength ctxt attr $ stripUnits ctxt num+++linearisePoint :: RenderContext -> DrawAttributes -> Point+ -> R.Point+linearisePoint ctxt attr (p1, p2) =+ R.V2 (xs + lineariseXLength ctxt attr p1)+ (ys + lineariseYLength ctxt attr p2)+ where (R.V2 xs ys, _) = _renderViewBox ctxt++emTransform :: DrawAttributes -> Float -> Float+emTransform attr n = case getLast $ _fontSize attr of+ Nothing -> 16 * n+ Just (Num v) -> v * n+ Just _ -> 16 * n++lineariseLength :: RenderContext -> DrawAttributes -> Number+ -> Coord+lineariseLength _ _ (Num i) = i+lineariseLength _ attr (Em i) =+ emTransform attr i+lineariseLength ctxt _ (Percent v) = v * coeff+ where+ (R.V2 x1 y1, R.V2 x2 y2) = _renderViewBox ctxt+ actualWidth = abs $ x2 - x1+ actualHeight = abs $ y2 - y1+ two = 2 :: Int+ coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two)+ / sqrt 2+lineariseLength ctxt attr num =+ lineariseLength ctxt attr $ stripUnits ctxt num++prepareLinearGradientTexture+ :: RenderContext -> DrawAttributes+ -> LinearGradient -> Float -> [R.Primitive]+ -> R.Texture PixelRGBA8+prepareLinearGradientTexture ctxt attr grad opa prims =+ let bounds = F.foldMap R.planeBounds prims+ lineariser = case _linearGradientUnits grad of+ CoordUserSpace -> linearisePoint ctxt attr+ CoordBoundingBox -> boundbingBoxLinearise ctxt attr bounds+ gradient =+ [(offset, fillAlphaCombine opa color)+ | GradientStop offset color <- _linearGradientStops grad]+ startPoint = lineariser $ _linearGradientStart grad+ stopPoint = lineariser $ _linearGradientStop grad+ in+ RT.linearGradientTexture gradient startPoint stopPoint++prepareRadialGradientTexture+ :: RenderContext -> DrawAttributes+ -> RadialGradient -> Float -> [R.Primitive]+ -> R.Texture PixelRGBA8+prepareRadialGradientTexture ctxt attr grad opa prims =+ let bounds = F.foldMap R.planeBounds prims+ (lineariser, lengthLinearise) = case _radialGradientUnits grad of+ CoordUserSpace ->+ (linearisePoint ctxt attr, lineariseLength ctxt attr)+ CoordBoundingBox ->+ (boundbingBoxLinearise ctxt attr bounds,+ boundingBoxLength ctxt attr bounds)+ gradient =+ [(offset, fillAlphaCombine opa color)+ | GradientStop offset color <- _radialGradientStops grad]+ center = lineariser $ _radialGradientCenter grad+ radius = lengthLinearise $ _radialGradientRadius grad+ in+ case (_radialGradientFocusX grad,+ _radialGradientFocusY grad) of+ (Nothing, Nothing) ->+ RT.radialGradientTexture gradient center radius+ (Just fx, Nothing) ->+ RT.radialGradientWithFocusTexture gradient center radius+ $ lineariser (fx, snd $ _radialGradientCenter grad)+ (Nothing, Just fy) ->+ RT.radialGradientWithFocusTexture gradient center radius+ $ lineariser (fst $ _radialGradientCenter grad, fy)+ (Just fx, Just fy) ->+ RT.radialGradientWithFocusTexture gradient center radius+ $ lineariser (fx, fy)++fillMethodOfSvg :: DrawAttributes -> R.FillMethod+fillMethodOfSvg attr = case getLast $ _fillRule attr of+ Nothing -> R.FillWinding+ Just FillNonZero -> R.FillWinding+ Just FillEvenOdd -> R.FillEvenOdd++fillAlphaCombine :: Float -> PixelRGBA8 -> PixelRGBA8+fillAlphaCombine opacity (PixelRGBA8 r g b a) =+ PixelRGBA8 r g b alpha+ where+ a' = fromIntegral a / 255.0+ alpha = floor . max 0 . min 255 $ opacity * a' * 255++documentOfPattern :: Pattern -> String -> Document+documentOfPattern pat loc = Document+ { _viewBox = _patternViewBox pat+ , _width = return $ _patternWidth pat+ , _height = return $ _patternHeight pat+ , _elements = _patternElements pat+ , _definitions = M.empty+ , _styleRules = []+ , _description = ""+ , _documentLocation = loc+ }++prepareTexture :: RenderContext -> DrawAttributes+ -> Texture -> Float+ -> [R.Primitive]+ -> IODraw (Maybe (R.Texture PixelRGBA8))+prepareTexture _ _ FillNone _opacity _ = return Nothing+prepareTexture _ _ (ColorRef color) opacity _ =+ return . Just . RT.uniformTexture $ fillAlphaCombine opacity color+prepareTexture ctxt attr (TextureRef ref) opacity prims =+ maybe (return Nothing) prepare $+ M.lookup ref (_contextDefinitions ctxt)+ where+ prepare (ElementGeometry _) = return Nothing+ prepare (ElementMarker _) = return Nothing+ prepare (ElementMask _) = return Nothing+ prepare (ElementClipPath _) = return Nothing+ prepare (ElementLinearGradient grad) =+ return . Just $ prepareLinearGradientTexture ctxt + attr grad opacity prims+ prepare (ElementRadialGradient grad) =+ return . Just $ prepareRadialGradientTexture ctxt+ attr grad opacity prims+ prepare (ElementPattern pat) = do+ patternPicture <- _subRender ctxt $ documentOfPattern pat (_basePath ctxt)+ return . Just . RT.withSampler R.SamplerRepeat+ $ RT.sampledImageTexture patternPicture+