summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVincentBerthoux <>2016-11-20 16:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-11-20 16:05:00 (GMT)
commite550e1d8cfb2b3c9cd8e912162e79420c28c4ea7 (patch)
tree29495ce7e23aca7156f82c96b65257b34f65f138
parent0f1d6992da684dadeff346b243947616c76aa85e (diff)
version 0.3.2.10.3.2.1
-rw-r--r--changelog.md174
-rw-r--r--exec-src/svgrender.hs256
-rw-r--r--rasterific-svg.cabal146
-rw-r--r--src/Graphics/Rasterific/Svg/RasterificRender.hs1193
-rw-r--r--src/Graphics/Rasterific/Svg/RasterificTextRendering.hs936
-rw-r--r--src/Graphics/Rasterific/Svg/RenderContext.hs612
6 files changed, 1661 insertions, 1656 deletions
diff --git a/changelog.md b/changelog.md
index 27c7a67..0d661d4 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,84 +1,90 @@
-Change log
-==========
-
-v0.3.2 October 2016
--------------------
- * Bumping Rasterific dep
- * Bumping svg-tree dep
- * Adding SVG2 gradient mesh rendering
-
-v0.3.1.2 May 2016
------------------
- * Fix: Bumping for GHC 8.0
-
-v0.3.1.1 March 2016
--------------------
- * Fix: Bumping to svg-tree 0.5
- * Fix: Bumping linear to 0.20
-
-v0.3 February 2016
-------------------
- * Fix: Updating to handle svg-tree 0.4
-
-v0.2.3.2 October 2015
----------------------
- * Fix: bumping optparse-applicative upper bound
-
-v0.2.3.1 May 2015
------------------
- * Fix: Bumping Rasterific version to compiler
- without problems with GHC 7.6
-
-v0.2.3 May 2015
----------------
-
- * Adding: PDF output
- * Fix: font cache created in temp dir
-
-v0.2.2.1 May 2015
------------------
-
- * Fix: GHC < 7.10 compilation
-
-v0.2.2 May 2015
----------------
-
- * Fix: lens upper bound, and removing it.
-
-v0.2.1 May 2015
----------------
-
- * Adding: support for arc in path
-
-v0.2 April 2015
----------------
-
- * Bumping: using svg-tree 0.3
-
-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
-
+Change log
+==========
+
+v0.3.2.1 November 2016
+----------------------
+ * Fix: handling of "matrix()" transform
+ * Fix: stroking with evenodd fill method.
+ * Fix: handling of miter-limit value
+
+v0.3.2 October 2016
+-------------------
+ * Bumping Rasterific dep
+ * Bumping svg-tree dep
+ * Adding SVG2 gradient mesh rendering
+
+v0.3.1.2 May 2016
+-----------------
+ * Fix: Bumping for GHC 8.0
+
+v0.3.1.1 March 2016
+-------------------
+ * Fix: Bumping to svg-tree 0.5
+ * Fix: Bumping linear to 0.20
+
+v0.3 February 2016
+------------------
+ * Fix: Updating to handle svg-tree 0.4
+
+v0.2.3.2 October 2015
+---------------------
+ * Fix: bumping optparse-applicative upper bound
+
+v0.2.3.1 May 2015
+-----------------
+ * Fix: Bumping Rasterific version to compiler
+ without problems with GHC 7.6
+
+v0.2.3 May 2015
+---------------
+
+ * Adding: PDF output
+ * Fix: font cache created in temp dir
+
+v0.2.2.1 May 2015
+-----------------
+
+ * Fix: GHC < 7.10 compilation
+
+v0.2.2 May 2015
+---------------
+
+ * Fix: lens upper bound, and removing it.
+
+v0.2.1 May 2015
+---------------
+
+ * Adding: support for arc in path
+
+v0.2 April 2015
+---------------
+
+ * Bumping: using svg-tree 0.3
+
+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
+
diff --git a/exec-src/svgrender.hs b/exec-src/svgrender.hs
index 145e9d9..8da8057 100644
--- a/exec-src/svgrender.hs
+++ b/exec-src/svgrender.hs
@@ -1,128 +1,128 @@
-
-{-# LANGUAGE CPP #-}
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<$>), (<*>), pure )
-#endif
-
-import Control.Applicative( (<|>) )
-import Control.Monad( when )
-import qualified Data.ByteString.Lazy as LB
-import Data.Monoid( (<>) )
-import Codec.Picture( writePng )
-import System.Directory( getTemporaryDirectory )
-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
- , pdfOfSvgDocument
- )
-import Graphics.Svg( loadSvgFile
- , documentSize )
-import System.Exit( ExitCode( ExitFailure, ExitSuccess )
- , exitWith )
-
-data Options = Options
- { _inputFile :: !FilePath
- , _outputFile :: !FilePath
- , _verbose :: !Bool
- , _asPdf :: !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") )
- <*> ( switch (long "pdf" <> help "Convert to a PDF" ) )
- <*> ( 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 or pdf 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
- tempDir <- getTemporaryDirectory
- cache <- loadCreateFontCache $ tempDir </> "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
- if _asPdf options then do
- whenVerbose $ "Writing PDF at " ++ outFileName options
- (doc, _) <- pdfOfSvgDocument cache (Just size) dpi d
- LB.writeFile (outFileName options) doc
- exitWith ExitSuccess
- else do
- whenVerbose $ "Writing PNG at " ++ outFileName options
- (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 qualified Data.ByteString.Lazy as LB
+import Data.Monoid( (<>) )
+import Codec.Picture( writePng )
+import System.Directory( getTemporaryDirectory )
+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
+ , pdfOfSvgDocument
+ )
+import Graphics.Svg( loadSvgFile
+ , documentSize )
+import System.Exit( ExitCode( ExitFailure, ExitSuccess )
+ , exitWith )
+
+data Options = Options
+ { _inputFile :: !FilePath
+ , _outputFile :: !FilePath
+ , _verbose :: !Bool
+ , _asPdf :: !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") )
+ <*> ( switch (long "pdf" <> help "Convert to a PDF" ) )
+ <*> ( 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 or pdf 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
+ tempDir <- getTemporaryDirectory
+ cache <- loadCreateFontCache $ tempDir </> "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
+ if _asPdf options then do
+ whenVerbose $ "Writing PDF at " ++ outFileName options
+ (doc, _) <- pdfOfSvgDocument cache (Just size) dpi d
+ LB.writeFile (outFileName options) doc
+ exitWith ExitSuccess
+ else do
+ whenVerbose $ "Writing PNG at " ++ outFileName options
+ (finalImage, _) <- renderSvgDocument cache (Just size) dpi d
+ writePng (outFileName options) finalImage
+ exitWith ExitSuccess
+
+main :: IO ()
+main = execParser progOptions >>= runConversion
+
diff --git a/rasterific-svg.cabal b/rasterific-svg.cabal
index 84d752a..b40871d 100644
--- a/rasterific-svg.cabal
+++ b/rasterific-svg.cabal
@@ -1,73 +1,73 @@
--- Initial svg.cabal generated by cabal init. For further documentation,
--- see http://haskell.org/cabal/users-guide/
-name: rasterific-svg
-version: 0.3.2
-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.
-license: BSD3
-license-file: LICENSE
-author: Vincent Berthoux
-maintainer: Vincent Berthoux
--- copyright:
-extra-source-files: changelog.md, README.md
-category: Graphics, Svg
-build-type: Simple
-cabal-version: >=1.10
-
-Source-Repository head
- Type: git
- Location: git://github.com/Twinside/rasterific-svg.git
-
-Source-Repository this
- Type: git
- Location: git://github.com/Twinside/rasterific-svg.git
- Tag: v0.3.2
-
-library
- hs-source-dirs: src
- default-language: Haskell2010
- Ghc-options: -O3 -Wall
- -- -auto-all
- exposed-modules: Graphics.Rasterific.Svg
- other-modules: Graphics.Rasterific.Svg.RenderContext
- , Graphics.Rasterific.Svg.PathConverter
- , Graphics.Rasterific.Svg.MeshConverter
- , Graphics.Rasterific.Svg.RasterificRender
- , Graphics.Rasterific.Svg.RasterificTextRendering
-
- build-depends: base >= 4.5 && < 5
- , directory
- , bytestring >= 0.10
- , filepath
- , binary >= 0.7
- , scientific >= 0.3
- , JuicyPixels >= 3.2 && < 3.3
- , containers >= 0.5
- , Rasterific >= 0.7 && < 0.8
- , FontyFruity >= 0.5.2.1 && < 0.6
- , svg-tree >= 0.6 && < 0.7
- , lens >= 4.5 && < 5
- , linear >= 1.20
- , vector >= 0.10
- , text >= 1.2
- , transformers >= 0.3 && < 0.6
- , mtl >= 2.1 && < 2.3
- , primitive
-
-Executable svgrender
- default-language: Haskell2010
- hs-source-dirs: exec-src
- Main-Is: svgrender.hs
- Ghc-options: -O3 -Wall
- Build-Depends: base >= 4.6
- , optparse-applicative >= 0.11 && < 0.14
- , directory >= 1.0
- , bytestring
- , rasterific-svg
- , Rasterific
- , JuicyPixels
- , filepath
- , FontyFruity
- , svg-tree
-
+-- Initial svg.cabal generated by cabal init. For further documentation,
+-- see http://haskell.org/cabal/users-guide/
+name: rasterific-svg
+version: 0.3.2.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.
+license: BSD3
+license-file: LICENSE
+author: Vincent Berthoux
+maintainer: Vincent Berthoux
+-- copyright:
+extra-source-files: changelog.md, README.md
+category: Graphics, Svg
+build-type: Simple
+cabal-version: >=1.10
+
+Source-Repository head
+ Type: git
+ Location: git://github.com/Twinside/rasterific-svg.git
+
+Source-Repository this
+ Type: git
+ Location: git://github.com/Twinside/rasterific-svg.git
+ Tag: v0.3.2.1
+
+library
+ hs-source-dirs: src
+ default-language: Haskell2010
+ Ghc-options: -O3 -Wall
+ -- -auto-all
+ exposed-modules: Graphics.Rasterific.Svg
+ other-modules: Graphics.Rasterific.Svg.RenderContext
+ , Graphics.Rasterific.Svg.PathConverter
+ , Graphics.Rasterific.Svg.MeshConverter
+ , Graphics.Rasterific.Svg.RasterificRender
+ , Graphics.Rasterific.Svg.RasterificTextRendering
+
+ build-depends: base >= 4.5 && < 5
+ , directory
+ , bytestring >= 0.10
+ , filepath
+ , binary >= 0.7
+ , scientific >= 0.3
+ , JuicyPixels >= 3.2 && < 3.3
+ , containers >= 0.5
+ , Rasterific >= 0.7 && < 0.8
+ , FontyFruity >= 0.5.2.1 && < 0.6
+ , svg-tree >= 0.6 && < 0.7
+ , lens >= 4.5 && < 5
+ , linear >= 1.20
+ , vector >= 0.10
+ , text >= 1.2
+ , transformers >= 0.3 && < 0.6
+ , mtl >= 2.1 && < 2.3
+ , primitive
+
+Executable svgrender
+ default-language: Haskell2010
+ hs-source-dirs: exec-src
+ Main-Is: svgrender.hs
+ Ghc-options: -O3 -Wall
+ Build-Depends: base >= 4.6
+ , optparse-applicative >= 0.11 && < 0.14
+ , directory >= 1.0
+ , bytestring
+ , rasterific-svg
+ , Rasterific
+ , JuicyPixels
+ , filepath
+ , FontyFruity
+ , svg-tree
+
diff --git a/src/Graphics/Rasterific/Svg/RasterificRender.hs b/src/Graphics/Rasterific/Svg/RasterificRender.hs
index d4b9396..d965d41 100644
--- a/src/Graphics/Rasterific/Svg/RasterificRender.hs
+++ b/src/Graphics/Rasterific/Svg/RasterificRender.hs
@@ -1,597 +1,596 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE CPP #-}
-module Graphics.Rasterific.Svg.RasterificRender
- ( DrawResult( .. )
- , renderSvgDocument
- , drawingOfSvgDocument
- , pdfOfSvgDocument
- ) 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.ByteString.Lazy as LB
-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 Graphics.Rasterific.Svg.MeshConverter
-
-{-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)
-
-pdfOfSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document
- -> IO (LB.ByteString, LoadedElements)
-pdfOfSvgDocument cache sizes dpi doc = do
- (drawing, loaded) <- drawingOfSvgDocument cache sizes dpi doc
- let img = R.renderDrawingAtDpiToPDF (_drawWidth drawing) (_drawHeight drawing) dpi $ _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 (xx1, yy1, xx2, yy2), _, _) ->
- (realToFrac xx1, realToFrac yy1, realToFrac xx2, realToFrac yy2)
- ( _, Just (Num w), Just (Num h)) ->
- (0, 0, integralClamp w, integralClamp h)
- _ -> (0, 0, 1, 1)
-
- integralClamp = fromIntegral . (\a -> a :: Int) . floor
-
- box = (V2 x1 y1, V2 x2 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 $ drawingOfSvgDocument cache Nothing dpi subDoc
- modify (<> loaded)
- return $ _drawAction 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
- rf = realToFrac
-
- go (TransformMatrix a b c d e f) =
- RT.Transformation (rf a) (rf b) (rf c) (rf d) (rf e) (rf f)
- go (Translate x y) = RT.translate $ V2 (rf x) (rf y)
- go (Scale xs Nothing) = RT.scale (rf xs) (rf xs)
- go (Scale xs (Just ys)) = RT.scale (rf xs) (rf ys)
- go (Rotate angle Nothing) =
- RT.rotate . toRadian $ rf angle
- go (Rotate angle (Just (cx, cy))) =
- RT.rotateCenter (toRadian $ rf angle) $ V2 (rf cx) (rf cy)
- go (SkewX v) = RT.skewX . toRadian $ rf v
- go (SkewY v) = RT.skewY . toRadian $ rf 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 $ realToFrac 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 (Double, Double, Double, Double)
-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 (Double, Double, Double, Double)
- -> 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 (realToFrac xs) (realToFrac ys)
- boxEnd = V2 (realToFrac xe) (realToFrac 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 (MeshGradientTree mesh) =
- return $ do
- R.renderMeshPatch interp rasterificMesh
- where
- rasterificMesh = convertGradientMesh mempty mempty mesh
- interp = case _meshGradientType mesh of
- GradientBilinear -> R.PatchBilinear
- GradientBicubic -> R.PatchBicubic
-
- 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
-
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+module Graphics.Rasterific.Svg.RasterificRender
+ ( DrawResult( .. )
+ , renderSvgDocument
+ , drawingOfSvgDocument
+ , pdfOfSvgDocument
+ ) 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.ByteString.Lazy as LB
+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 Graphics.Rasterific.Svg.MeshConverter
+
+{-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)
+
+pdfOfSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document
+ -> IO (LB.ByteString, LoadedElements)
+pdfOfSvgDocument cache sizes dpi doc = do
+ (drawing, loaded) <- drawingOfSvgDocument cache sizes dpi doc
+ let img = R.renderDrawingAtDpiToPDF (_drawWidth drawing) (_drawHeight drawing) dpi $ _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 (xx1, yy1, xx2, yy2), _, _) ->
+ (realToFrac xx1, realToFrac yy1, realToFrac xx2, realToFrac yy2)
+ ( _, Just (Num w), Just (Num h)) ->
+ (0, 0, integralClamp w, integralClamp h)
+ _ -> (0, 0, 1, 1)
+
+ integralClamp = fromIntegral . (\a -> a :: Int) . floor
+
+ box = (V2 x1 y1, V2 x2 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 $ drawingOfSvgDocument cache Nothing dpi subDoc
+ modify (<> loaded)
+ return $ _drawAction 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
+ rf = realToFrac
+ go (TransformMatrix a d b e c f) =
+ RT.Transformation (rf a) (rf b) (rf c) (rf d) (rf e) (rf f)
+ go (Translate x y) = RT.translate $ V2 (rf x) (rf y)
+ go (Scale xs Nothing) = RT.scale (rf xs) (rf xs)
+ go (Scale xs (Just ys)) = RT.scale (rf xs) (rf ys)
+ go (Rotate angle Nothing) =
+ RT.rotate . toRadian $ rf angle
+ go (Rotate angle (Just (cx, cy))) =
+ RT.rotateCenter (toRadian $ rf angle) $ V2 (rf cx) (rf cy)
+ go (SkewX v) = RT.skewX . toRadian $ rf v
+ go (SkewY v) = RT.skewY . toRadian $ rf 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 :: R.FillMethod -> RenderContext -> DrawAttributes
+ -> Texture -> Float
+ -> [R.Primitive]
+ -> IODraw (R.Drawing PixelRGBA8 ())
+withSvgTexture fillMethod ctxt attr texture opacity prims = do
+ mayTexture <- prepareTexture ctxt attr texture opacity prims
+ case mayTexture of
+ Nothing -> return $ return ()
+ Just tex ->
+ return . R.withTexture tex $ R.fillWithMethod fillMethod 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 (fillMethodOfSvg info) 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 $ realToFrac 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 R.FillWinding 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 (Double, Double, Double, Double)
+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
+ ElementMeshGradient _ -> 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 (Double, Double, Double, Double)
+ -> 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 (realToFrac xs) (realToFrac ys)
+ boxEnd = V2 (realToFrac xe) (realToFrac 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 (MeshGradientTree mesh) =
+ return $ do
+ R.renderMeshPatch interp rasterificMesh
+ where
+ rasterificMesh = convertGradientMesh mempty mempty mesh
+ interp = case _meshGradientType mesh of
+ GradientBilinear -> R.PatchBilinear
+ GradientBicubic -> R.PatchBicubic
+
+ 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
+
diff --git a/src/Graphics/Rasterific/Svg/RasterificTextRendering.hs b/src/Graphics/Rasterific/Svg/RasterificTextRendering.hs
index 678b5e0..8a07e7c 100644
--- a/src/Graphics/Rasterific/Svg/RasterificTextRendering.hs
+++ b/src/Graphics/Rasterific/Svg/RasterificTextRendering.hs
@@ -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 = realToFrac <$> 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 . realToFrac <$> 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 = (realToFrac <$> 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) = realToFrac i
-startOffsetOfPath _ attr _ (Em i) = emTransform attr $ realToFrac i
-startOffsetOfPath _ _ tPath (Percent p) =
- realToFrac 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 = realToFrac <$> 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 . realToFrac <$> 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 = (realToFrac <$> 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) = realToFrac i
+startOffsetOfPath _ attr _ (Em i) = emTransform attr $ realToFrac i
+startOffsetOfPath _ _ tPath (Percent p) =
+ realToFrac 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
+
diff --git a/src/Graphics/Rasterific/Svg/RenderContext.hs b/src/Graphics/Rasterific/Svg/RenderContext.hs
index 3958f2c..5c3c334 100644
--- a/src/Graphics/Rasterific/Svg/RenderContext.hs
+++ b/src/Graphics/Rasterific/Svg/RenderContext.hs
@@ -1,306 +1,306 @@
-{-# LANGUAGE CPP #-}
-module Graphics.Rasterific.Svg.RenderContext
- ( RenderContext( .. )
- , LoadedElements( .. )
- , loadedFonts
- , loadedImages
- , IODraw
- , ViewBox
- , toRadian
- , capOfSvg
- , joinOfSvg
- , stripUnits
- , boundingBoxLength
- , boundbingBoxLinearise
- , 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
-import Graphics.Rasterific.Svg.MeshConverter
-
-toRadian :: Floating a => a -> a
-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 (R.Drawing 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')
-
-globalBounds :: RenderContext -> R.PlaneBound
-globalBounds RenderContext { _renderViewBox = (p1, p2) } =
- R.PlaneBound p1 p2
-
-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 :: Float
- go num = case num of
- Num n -> realToFrac n
- Em n -> emTransform attr $ realToFrac n
- Percent p -> realToFrac 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 -> realToFrac n
- Em n -> emTransform attr $ realToFrac n
- Percent p -> realToFrac p * w + xi
- _ -> finalX $ stripUnits ctxt nu
-
- finalY nu = case nu of
- Num n -> realToFrac n
- Em n -> emTransform attr $ realToFrac n
- Percent p -> realToFrac p * h + yi
- _ -> finalY $ stripUnits ctxt nu
-
-lineariseXLength :: RenderContext -> DrawAttributes -> Number
- -> Float
-lineariseXLength _ _ (Num i) = realToFrac i
-lineariseXLength _ attr (Em i) = emTransform attr $ realToFrac i
-lineariseXLength ctxt _ (Percent p) = abs (xe - xs) * realToFrac p
- where
- (R.V2 xs _, R.V2 xe _) = _renderViewBox ctxt
-lineariseXLength ctxt attr num =
- lineariseXLength ctxt attr $ stripUnits ctxt num
-
-lineariseYLength :: RenderContext -> DrawAttributes -> Number
- -> Float
-lineariseYLength _ _ (Num i) = realToFrac i
-lineariseYLength _ attr (Em n) = emTransform attr $ realToFrac n
-lineariseYLength ctxt _ (Percent p) = abs (ye - ys) * (realToFrac 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 * realToFrac n
- Just (Num v) -> realToFrac v * n
- Just _ -> 16 * n
-
-lineariseLength :: RenderContext -> DrawAttributes -> Number
- -> Float
-lineariseLength _ _ (Num i) = realToFrac i
-lineariseLength _ attr (Em i) = emTransform attr $ realToFrac i
-lineariseLength ctxt _ (Percent v) = realToFrac 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
-
-prepareGradientMeshTexture
- :: RenderContext -> DrawAttributes
- -> MeshGradient -> [R.Primitive]
- -> R.Texture PixelRGBA8
-prepareGradientMeshTexture ctxt _attr mesh prims =
- let bounds = F.foldMap R.planeBounds prims
- strip (x, y) = (stripUnits ctxt x, stripUnits ctxt y)
- mesh' = mapMeshBaseCoordiantes strip mesh
- interp = case _meshGradientType mesh of
- GradientBilinear -> R.PatchBilinear
- GradientBicubic -> R.PatchBicubic
- in
- RT.meshPatchTexture interp $ convertGradientMesh (globalBounds ctxt) bounds mesh'
-
-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
- toA = maybe 1 id
- gradient =
- [(offset, fillAlphaCombine (opa * toA opa2) color)
- | GradientStop offset color _ opa2 <- _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)
- toA = maybe 1 id
- gradient =
- [(offset, fillAlphaCombine (opa * toA opa2) color)
- | GradientStop offset color _ opa2 <- _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 (ElementMeshGradient mesh) =
- return . Just $ prepareGradientMeshTexture ctxt attr mesh prims
- 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
- let doc = documentOfPattern pat (_basePath ctxt)
- dpi = _renderDpi ctxt
- w = floor . lineariseXLength ctxt attr $ _patternWidth pat
- h = floor . lineariseYLength ctxt attr $ _patternHeight pat
- patDrawing <- _subRender ctxt doc
- return . Just $ RT.patternTexture w h dpi (PixelRGBA8 0 0 0 0) patDrawing
-
+{-# LANGUAGE CPP #-}
+module Graphics.Rasterific.Svg.RenderContext
+ ( RenderContext( .. )
+ , LoadedElements( .. )
+ , loadedFonts
+ , loadedImages
+ , IODraw
+ , ViewBox
+ , toRadian
+ , capOfSvg
+ , joinOfSvg
+ , stripUnits
+ , boundingBoxLength
+ , boundbingBoxLinearise
+ , 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
+import Graphics.Rasterific.Svg.MeshConverter
+
+toRadian :: Floating a => a -> a
+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 (R.Drawing 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')
+
+globalBounds :: RenderContext -> R.PlaneBound
+globalBounds RenderContext { _renderViewBox = (p1, p2) } =
+ R.PlaneBound p1 p2
+
+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 v) -> R.JoinMiter $ 1 / realToFrac v
+ (Just JoinMiter, _) -> 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 :: Float
+ go num = case num of
+ Num n -> realToFrac n
+ Em n -> emTransform attr $ realToFrac n
+ Percent p -> realToFrac 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 -> realToFrac n
+ Em n -> emTransform attr $ realToFrac n
+ Percent p -> realToFrac p * w + xi
+ _ -> finalX $ stripUnits ctxt nu
+
+ finalY nu = case nu of
+ Num n -> realToFrac n
+ Em n -> emTransform attr $ realToFrac n
+ Percent p -> realToFrac p * h + yi
+ _ -> finalY $ stripUnits ctxt nu
+
+lineariseXLength :: RenderContext -> DrawAttributes -> Number
+ -> Float
+lineariseXLength _ _ (Num i) = realToFrac i
+lineariseXLength _ attr (Em i) = emTransform attr $ realToFrac i
+lineariseXLength ctxt _ (Percent p) = abs (xe - xs) * realToFrac p
+ where
+ (R.V2 xs _, R.V2 xe _) = _renderViewBox ctxt
+lineariseXLength ctxt attr num =
+ lineariseXLength ctxt attr $ stripUnits ctxt num
+
+lineariseYLength :: RenderContext -> DrawAttributes -> Number
+ -> Float
+lineariseYLength _ _ (Num i) = realToFrac i
+lineariseYLength _ attr (Em n) = emTransform attr $ realToFrac n
+lineariseYLength ctxt _ (Percent p) = abs (ye - ys) * (realToFrac 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 * realToFrac n
+ Just (Num v) -> realToFrac v * n
+ Just _ -> 16 * n
+
+lineariseLength :: RenderContext -> DrawAttributes -> Number
+ -> Float
+lineariseLength _ _ (Num i) = realToFrac i
+lineariseLength _ attr (Em i) = emTransform attr $ realToFrac i
+lineariseLength ctxt _ (Percent v) = realToFrac 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
+
+prepareGradientMeshTexture
+ :: RenderContext -> DrawAttributes
+ -> MeshGradient -> [R.Primitive]
+ -> R.Texture PixelRGBA8
+prepareGradientMeshTexture ctxt _attr mesh prims =
+ let bounds = F.foldMap R.planeBounds prims
+ strip (x, y) = (stripUnits ctxt x, stripUnits ctxt y)
+ mesh' = mapMeshBaseCoordiantes strip mesh
+ interp = case _meshGradientType mesh of
+ GradientBilinear -> R.PatchBilinear
+ GradientBicubic -> R.PatchBicubic
+ in
+ RT.meshPatchTexture interp $ convertGradientMesh (globalBounds ctxt) bounds mesh'
+
+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
+ toA = maybe 1 id
+ gradient =
+ [(offset, fillAlphaCombine (opa * toA opa2) color)
+ | GradientStop offset color _ opa2 <- _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)
+ toA = maybe 1 id
+ gradient =
+ [(offset, fillAlphaCombine (opa * toA opa2) color)
+ | GradientStop offset color _ opa2 <- _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 (ElementMeshGradient mesh) =
+ return . Just $ prepareGradientMeshTexture ctxt attr mesh prims
+ 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
+ let doc = documentOfPattern pat (_basePath ctxt)
+ dpi = _renderDpi ctxt
+ w = floor . lineariseXLength ctxt attr $ _patternWidth pat
+ h = floor . lineariseYLength ctxt attr $ _patternHeight pat
+ patDrawing <- _subRender ctxt doc
+ return . Just $ RT.patternTexture w h dpi (PixelRGBA8 0 0 0 0) patDrawing
+