rasterific-svg (empty) → 0.1
raw patch · 11 files changed
+2070/−0 lines, 11 filesdep +FontyFruitydep +JuicyPixelsdep +Rasterificsetup-changed
Dependencies added: FontyFruity, JuicyPixels, Rasterific, attoparsec, base, binary, blaze-html, bytestring, containers, criterion, deepseq, directory, filepath, lens, linear, mtl, optparse-applicative, rasterific-svg, scientific, svg-tree, text, transformers, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- exec-src/benching.hs +18/−0
- exec-src/svgrender.hs +115/−0
- exec-src/svgtest.hs +119/−0
- rasterific-svg.cabal +109/−0
- src/Graphics/Rasterific/Svg.hs +138/−0
- src/Graphics/Rasterific/Svg/PathConverter.hs +230/−0
- src/Graphics/Rasterific/Svg/RasterificRender.hs +561/−0
- src/Graphics/Rasterific/Svg/RasterificTextRendering.hs +468/−0
- src/Graphics/Rasterific/Svg/RenderContext.hs +280/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Vincent Berthoux + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vincent Berthoux nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ exec-src/benching.hs view
@@ -0,0 +1,18 @@+import Criterion +import Criterion.Main +import Control.Applicative( (<$>) ) +import Graphics.Text.TrueType( emptyFontCache ) +import Graphics.Svg +import Graphics.Rasterific.Svg + +main :: IO () +main = do + f <- loadSvgFile "test/tiger.svg" + {-cache <- loadCreateFontCache-} + case f of + Nothing -> putStrLn "Error while loading SVG" + Just doc -> do + let loader = fst <$> renderSvgDocument emptyFontCache Nothing 96 doc + defaultMainWith defaultConfig + [ bench "Tiger render" $ whnfIO loader ] +
+ exec-src/svgrender.hs view
@@ -0,0 +1,115 @@+ +{-# LANGUAGE CPP #-} +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), pure ) +#endif + +import Control.Applicative( (<$>), (<|>) ) +import Control.Monad( when ) +import Data.Monoid( (<>) ) +import Codec.Picture( writePng ) +import System.FilePath( replaceExtension ) + +import Options.Applicative( Parser + , ParserInfo + , argument + , execParser + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , progDesc + , str + , switch + , auto + , option + ) + +import Graphics.Rasterific.Svg( loadCreateFontCache + , renderSvgDocument + ) +import Graphics.Svg( loadSvgFile + , documentSize ) +import System.Exit( ExitCode( ExitFailure, ExitSuccess ) + , exitWith ) + +data Options = Options + { _inputFile :: !FilePath + , _outputFile :: !FilePath + , _verbose :: !Bool + , _width :: !Int + , _height :: !Int + , _dpi :: !Int + } + +argParser :: Parser Options +argParser = Options + <$> ( argument str + (metavar "SVGINPUTFILE" + <> help "SVG file to render to png")) + <*> ( argument str + (metavar "OUTPUTFILE" + <> help ("Output file name, same as input with" + <> " different extension if unspecified.")) + <|> pure "" ) + <*> ( switch (long "verbose" <> help "Display more information") ) + <*> ( option auto + ( long "width" + <> help "Force the width of the rendered PNG" + <> metavar "WIDTH" ) + <|> pure 0 + ) + <*> ( option auto + ( long "height" + <> help "Force the height of the rendered PNG" + <> metavar "HEIGHT" ) + <|> pure 0 ) + <*> ( option auto + ( long "dpi" + <> help "DPI used for text rendering and various real life sizes" + <> metavar "DPI" ) + <|> pure 96 ) + +progOptions :: ParserInfo Options +progOptions = info (helper <*> argParser) + ( fullDesc + <> progDesc "Convert SVGINPUTFILE into a png OUTPUTFILE" + <> header "svgrender svg file renderer." ) + +outFileName :: Options -> FilePath +outFileName Options { _outputFile = "", _inputFile = inf } = + replaceExtension inf "png" +outFileName opt = _outputFile opt + +fixSize :: Options -> (Int, Int) -> (Int, Int) +fixSize opt (w, h) = (notNull (_width opt) w, notNull (_height opt) h) + where + notNull v v' = if v <= 0 then v' else v + +runConversion :: Options -> IO () +runConversion options = do + cache <- loadCreateFontCache "rasterific-svg-font-cache" + let filename = _inputFile options + whenVerbose = when (_verbose options) . putStrLn + whenVerbose $ "Loading: " ++ filename + + svg <- loadSvgFile filename + case svg of + Nothing -> do + putStrLn $ "Failed to load " ++ filename + exitWith $ ExitFailure 1 + + Just d -> do + let dpi = _dpi options + size = fixSize options $ documentSize dpi d + whenVerbose $ "Rendering at " ++ show size + (finalImage, _) <- renderSvgDocument cache (Just size) dpi d + writePng (outFileName options) finalImage + exitWith ExitSuccess + +main :: IO () +main = execParser progOptions >>= runConversion +
+ exec-src/svgtest.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE CPP #-} +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( foldMap ) +#endif + +import Control.Applicative( (<$>) ) +import Control.Monad( forM_ ) +import Data.Monoid( (<>) ) +import Data.List( isSuffixOf, sort ) +import System.Environment( getArgs ) +import System.Directory( createDirectoryIfMissing + , getDirectoryContents + ) +import qualified Text.Blaze.Html5 as HT +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as H +import qualified Text.Blaze.Html.Renderer.String as H +import System.FilePath( dropExtension, (</>), (<.>), splitFileName ) + +import Codec.Picture( writePng ) + +import Graphics.Text.TrueType( FontCache ) +import Graphics.Rasterific.Svg +import Graphics.Svg hiding ( text, path ) +{-import Debug.Trace-} +{-import Text.Printf-} +{-import Text.Groom-} + +loadRender :: [String] -> IO () +loadRender [] = putStrLn "not enough arguments" +loadRender [_] = putStrLn "not enough arguments" +loadRender (svgfilename:pngfilename:_) = do + f <- loadSvgFile svgfilename + case f of + Nothing -> putStrLn "Error while loading SVG" + Just doc -> do + cache <- loadCreateFontCache "fonty-texture-cache" + (finalImage, _) <- renderSvgDocument cache Nothing 96 doc + writePng pngfilename finalImage + +testOutputFolder :: FilePath +testOutputFolder = "gen_test" + +img :: FilePath -> Int -> Int -> H.Html +img path _w _h = H.img H.! H.src (H.toValue path) + +table :: [H.Html] -> [[H.Html]] -> H.Html +table headers cells = + H.table $ header <> foldMap (H.tr . foldMap H.td) cells + where header = H.tr $ foldMap H.th headers + +testFileOfPath :: FilePath -> FilePath +testFileOfPath path = testOutputFolder </> base <.> "png" + where (_, base) = splitFileName path + +svgTestFileOfPath :: FilePath -> FilePath +svgTestFileOfPath path = testOutputFolder </> base <.> "svg" + where (_, base) = splitFileName path + + +text :: String -> H.Html +text txt = H.toHtml txt <> H.br + +generateFileInfo :: FilePath -> [H.Html] +generateFileInfo path = + [ text path, img path 0 0 + , img pngRef 0 0 + , img (testFileOfPath path) 0 0 + , img (svgTestFileOfPath path) 0 0] + where + pngRef = dropExtension path <.> "png" + +toHtmlDocument :: H.Html -> String +toHtmlDocument html = H.renderHtml $ + H.html $ H.head (HT.title $ H.toHtml "Test results") + <> H.body html + +analyzeFolder :: FontCache -> FilePath -> IO () +analyzeFolder cache folder = do + createDirectoryIfMissing True testOutputFolder + fileList <- sort . filter (".svg" `isSuffixOf`) <$> getDirectoryContents folder + let hdr = H.toHtml <$> ["name", "W3C Svg", "W3C ref PNG", "mine", "svgmine"] + all_table = + table hdr . map generateFileInfo $ map (folder </>) fileList + doc = toHtmlDocument all_table + (_, folderBase) = splitFileName folder + + print fileList + + writeFile (folder </> ".." </> folderBase <.> "html") doc + forM_ fileList $ \p -> do + let realFilename = folder </> p + putStrLn $ "Loading: " ++ realFilename + svg <- loadSvgFile realFilename + {-putStrLn $ groom svg-} + case svg of + Nothing -> putStrLn $ "Failed to load " ++ p + Just d -> do + putStrLn $ " => Rendering " ++ show (documentSize 96 d) + (finalImage, _) <- renderSvgDocument cache Nothing 96 d + writePng (testFileOfPath p) finalImage + + putStrLn " => XMLize" + saveXmlFile (svgTestFileOfPath p) d + + +testSuite :: IO () +testSuite = do + cache <- loadCreateFontCache "rasterific-svg-font-cache" + analyzeFolder cache "w3csvg" + {-analyzeFolder cache "test"-} + +main :: IO () +main = do + args <- getArgs + case args of + "test":_ -> testSuite + _ -> loadRender args +
+ rasterific-svg.cabal view
@@ -0,0 +1,109 @@+-- Initial svg.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ +name: rasterific-svg +version: 0.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: +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.1 + +library + hs-source-dirs: src + default-language: Haskell2010 + Ghc-options: -O3 -Wall + ghc-prof-options: -Wall -prof + -- -auto-all + exposed-modules: Graphics.Rasterific.Svg + other-modules: Graphics.Rasterific.Svg.RenderContext + , Graphics.Rasterific.Svg.PathConverter + , Graphics.Rasterific.Svg.RasterificRender + , Graphics.Rasterific.Svg.RasterificTextRendering + + build-depends: base >= 4.6 && < 4.9 + , directory + , bytestring >= 0.10 + , filepath + , binary >= 0.7 + , scientific >= 0.3 + , JuicyPixels >= 3.2 && < 3.3 + , containers >= 0.5 + , Rasterific >= 0.5 && < 0.6 + , FontyFruity >= 0.5 && < 0.6 + , svg-tree >= 0.1 && < 0.2 + , lens >= 4.5 + , linear >= 1.16 + , transformers >= 0.4 + , vector >= 0.10 + , text >= 1.2 + , mtl >= 2.2 + , lens >= 4.7 + +Executable svgrender + default-language: Haskell2010 + hs-source-dirs: exec-src + Main-Is: svgrender.hs + Ghc-options: -O3 -Wall + ghc-prof-options: -rtsopts -Wall -prof + Build-Depends: base >= 4.6 + , optparse-applicative >= 0.11 && < 0.12 + , rasterific-svg + , Rasterific + , JuicyPixels + , filepath + , FontyFruity + , svg-tree + +Test-Suite svgtest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: exec-src + Main-Is: svgtest.hs + Ghc-options: -O3 -Wall + ghc-prof-options: -rtsopts -Wall -prof -auto-all + Build-Depends: base >= 4.6 + , linear + , rasterific-svg + , Rasterific + , JuicyPixels + , directory + , filepath + , attoparsec + , text + , FontyFruity + , binary + , bytestring + , svg-tree + , blaze-html + +Test-Suite bench + type: exitcode-stdio-1.0 + hs-source-dirs: exec-src + Main-Is: benching.hs + default-language: Haskell2010 + Ghc-options: -O3 -Wall + ghc-prof-options: -rtsopts -Wall -prof -auto-all + Build-Depends: base >= 4.6 + , rasterific-svg + , Rasterific + , JuicyPixels + , FontyFruity + , criterion >= 1.0 + , deepseq + , svg-tree +
+ src/Graphics/Rasterific/Svg.hs view
@@ -0,0 +1,138 @@+-- | Svg renderer based on Rasterific. +-- +-- Here is a simple example of loading a SVG file (using svg-tree) +-- rendering it to a picture, and saving it to a PNG (using Juicy.Pixels) +-- +-- @ +-- import Codec.Picture( writePng ) +-- import Graphics.Svg( loadSvgFile ) +-- import Graphics.Rasterific.Svg( loadCreateFontCache +-- , renderSvgDocument +-- ) +-- loadRender :: FilePath -> FilePath -> IO () +-- loadRender svgfilename pngfilename = do +-- f <- loadSvgFile svgfilename +-- case f of +-- Nothing -> putStrLn "Error while loading SVG" +-- Just doc -> do +-- cache <- loadCreateFontCache "fonty-texture-cache" +-- (finalImage, _) <- renderSvgDocument cache Nothing 96 doc +-- writePng pngfilename finalImage +-- @ +-- +module Graphics.Rasterific.Svg + ( -- * Main functions + drawingOfSvgDocument + , renderSvgDocument + , loadCreateFontCache + -- * Types + , LoadedElements( .. ) + , Result( .. ) + , DrawResult( .. ) + , Dpi + -- * Other helper functions + , renderSvgFile + ) where + +import qualified Data.ByteString.Lazy as B +import Graphics.Rasterific.Svg.RasterificRender( DrawResult( .. ) ) +import qualified Graphics.Rasterific.Svg.RasterificRender as RR +import Data.Binary( encodeFile, decodeOrFail ) +import Graphics.Svg.Types hiding ( Dpi ) +import Graphics.Svg hiding ( Dpi ) +import Graphics.Rasterific.Svg.RenderContext + +import System.Directory( doesFileExist ) +import Graphics.Text.TrueType + + +import qualified Codec.Picture as CP +import Codec.Picture( PixelRGBA8( .. ) + , writePng ) + +{-import Graphics.Svg.CssParser-} + +-- | Render an svg document to an image. +-- If you provide a size, the document will be stretched to +-- match the provided size. +-- +-- The DPI parameter really should depend of your screen, but +-- a good default value is 96 +-- +-- The use of the IO Monad is there to allow loading of fonts +-- and referenced images. +renderSvgDocument :: FontCache -- ^ Structure used to access fonts + -> Maybe (Int, Int) -- ^ Optional document size + -> Dpi -- ^ Current resolution for text and elements + -> Document -- ^ Svg document + -> IO (CP.Image PixelRGBA8, LoadedElements) +renderSvgDocument cache size dpi = + RR.renderSvgDocument cache size dpi . applyCSSRules . resolveUses + +-- | Render an svg document to a Rasterific Drawing. +-- If you provide a size, the document will be stretched to +-- match the provided size. +-- +-- The DPI parameter really should depend of your screen, but +-- a good default value is 96 +-- +-- The use of the IO Monad is there to allow loading of fonts +-- and referenced images. +drawingOfSvgDocument :: FontCache -- ^ Structure used to access fonts + -> Maybe (Int, Int) -- ^ Optional document size + -> Dpi -- ^ Current resolution for text and elements + -> Document -- ^ Svg document + -> IO (DrawResult, LoadedElements) +drawingOfSvgDocument cache size dpi = + RR.drawingOfSvgDocument cache size dpi . applyCSSRules . resolveUses + +-- | Rendering status. +data Result + = ResultSuccess -- ^ No problem found + | ResultError String -- ^ Error with message + deriving (Eq, Show) + +-- | Convert an SVG file to a PNG file, return True +-- if the operation went without problems. +-- +-- This function will call loadCreateFontCache with +-- the filename "fonty-texture-cache" +renderSvgFile :: FilePath -> FilePath -> IO Result +renderSvgFile svgfilename pngfilename = do + f <- loadSvgFile svgfilename + case f of + Nothing -> return $ ResultError "Error while loading SVG" + Just doc -> do + cache <- loadCreateFontCache "fonty-texture-cache" + (finalImage, _) <- renderSvgDocument cache Nothing 96 doc + writePng pngfilename finalImage + return ResultSuccess + +-- | This function will create a font cache, +-- a structure allowing to quickly match a font +-- family name and style to a specific true type font +-- on disk. +-- +-- The cache is saved on disk at the filepath given +-- as parameter. If a cache is found it is automatically +-- loaded from the file. +-- +-- Creating the cache is a rather long operation (especially +-- on Windows), that's why you may want to keep the cache +-- around. +loadCreateFontCache :: FilePath -> IO FontCache +loadCreateFontCache filename = do + exist <- doesFileExist filename + if exist then loadCache else createWrite + where + loadCache = do + bstr <- B.readFile filename + case decodeOrFail bstr of + Left _ -> createWrite + Right (_, _, v) -> return v + + createWrite = do + cache <- buildCache + encodeFile filename cache + return cache +
+ src/Graphics/Rasterific/Svg/PathConverter.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Svg.PathConverter + ( svgPathToPrimitives + , svgPathToRasterificPath + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +#endif + +import Control.Applicative( (<$>) ) + +import Data.List( mapAccumL ) +import Graphics.Rasterific.Linear( (^+^) + , (^-^) + , (^*) + , norm + , nearZero + , zero ) +import qualified Graphics.Rasterific as R +import qualified Linear as L +import Graphics.Svg.Types + +singularize :: [PathCommand] -> [PathCommand] +singularize = concatMap go + where + go (MoveTo _ []) = [] + go (MoveTo o (x: xs)) = MoveTo o [x] : go (LineTo o xs) + go (LineTo o lst) = LineTo o . pure <$> lst + go (HorizontalTo o lst) = HorizontalTo o . pure <$> lst + go (VerticalTo o lst) = VerticalTo o . pure <$> lst + go (CurveTo o lst) = CurveTo o . pure <$> lst + go (SmoothCurveTo o lst) = SmoothCurveTo o . pure <$> lst + go (QuadraticBezier o lst) = QuadraticBezier o . pure <$> lst + go (SmoothQuadraticBezierCurveTo o lst) = + SmoothQuadraticBezierCurveTo o . pure <$> lst + go (ElipticalArc o lst) = ElipticalArc o . pure <$> lst + go EndPath = [EndPath] + +toR :: RPoint -> R.Point +{-# INLINE toR #-} +toR (L.V2 x y) = R.V2 x y + +svgPathToPrimitives :: Bool -> [PathCommand] -> [R.Primitive] +svgPathToPrimitives _ lst | isPathWithArc lst = [] +svgPathToPrimitives shouldClose lst + | shouldClose && not (nearZero $ norm (lastPoint ^-^ firstPoint)) = + concat $ prims ++ [R.line lastPoint firstPoint] + | otherwise = concat prims + where + ((lastPoint, _, firstPoint), prims) = + mapAccumL go (zero, zero, zero) $ singularize lst + + go (latest, p, first) EndPath = + ((first, p, first), R.line latest first) + + go o (HorizontalTo _ []) = (o, []) + go o (VerticalTo _ []) = (o, []) + go o (MoveTo _ []) = (o, []) + go o (LineTo _ []) = (o, []) + go o (CurveTo _ []) = (o, []) + go o (SmoothCurveTo _ []) = (o, []) + go o (QuadraticBezier _ []) = (o, []) + go o (SmoothQuadraticBezierCurveTo _ []) = (o, []) + + go (_, _, _) (MoveTo OriginAbsolute (p:_)) = ((p', p', p'), []) + where p' = toR p + go (o, _, _) (MoveTo OriginRelative (p:_)) = + ((pp, pp, pp), []) where pp = o ^+^ toR p + + go (o@(R.V2 _ y), _, fp) (HorizontalTo OriginAbsolute (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 c y + go (o@(R.V2 x y), _, fp) (HorizontalTo OriginRelative (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 (x + c) y + + go (o@(R.V2 x _), _, fp) (VerticalTo OriginAbsolute (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 x c + go (o@(R.V2 x y), _, fp) (VerticalTo OriginRelative (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 x (c + y) + + go (o, _, fp) (LineTo OriginRelative (c:_)) = + ((p, p, fp), R.line o p) where p = o ^+^ toR c + + go (o, _, fp) (LineTo OriginAbsolute (p:_)) = + ((p', p', fp), R.line o $ toR p) + where p' = toR p + + go (o, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) = + ((e', c2', fp), + [R.CubicBezierPrim $ R.CubicBezier o (toR c1) c2' e']) + where e' = toR e + c2' = toR c2 + + go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) = + ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) + where c1' = o ^+^ toR c1 + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) = + ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) + where c1' = o ^* 2 ^-^ control + c2' = toR c2 + e' = toR e + + go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) = + ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) + where c1' = o ^* 2 ^-^ control + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (o, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where e' = toR e + c1' = toR c1 + + go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where c1' = o ^+^ toR c1 + e' = o ^+^ toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where c1' = o ^* 2 ^-^ control + e' = toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where c1' = o ^* 2 ^-^ control + e' = o ^+^ toR e + + go _ (ElipticalArc _ _) = error "Unimplemented" + + +-- | Conversion function between svg path to the rasterific one. +svgPathToRasterificPath :: Bool -> [PathCommand] -> R.Path +svgPathToRasterificPath shouldClose lst = + R.Path firstPoint shouldClose $ concat commands + where + lineTo p = [R.PathLineTo p] + cubicTo e1 e2 e3 = [R.PathCubicBezierCurveTo e1 e2 e3] + quadTo e1 e2 = [R.PathQuadraticBezierCurveTo e1 e2] + + ((_, _, firstPoint), commands) = + mapAccumL go (zero, zero, zero) $ singularize lst + + go (_, p, first) EndPath = + ((first, p, first), []) + + go o (HorizontalTo _ []) = (o, []) + go o (VerticalTo _ []) = (o, []) + go o (MoveTo _ []) = (o, []) + go o (LineTo _ []) = (o, []) + go o (CurveTo _ []) = (o, []) + go o (SmoothCurveTo _ []) = (o, []) + go o (QuadraticBezier _ []) = (o, []) + go o (SmoothQuadraticBezierCurveTo _ []) = (o, []) + + go (_, _, _) (MoveTo OriginAbsolute (p:_)) = + ((pp, pp, pp), []) where pp = toR p + go (o, _, _) (MoveTo OriginRelative (p:_)) = + ((pp, pp, pp), []) where pp = o ^+^ toR p + + go (R.V2 _ y, _, fp) (HorizontalTo OriginAbsolute (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 c y + go (R.V2 x y, _, fp) (HorizontalTo OriginRelative (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 (x + c) y + + go (R.V2 x _, _, fp) (VerticalTo OriginAbsolute (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 x c + go (R.V2 x y, _, fp) (VerticalTo OriginRelative (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 x (c + y) + + go (o, _, fp) (LineTo OriginRelative (c:_)) = + ((p, p, fp), lineTo p) where p = o ^+^ toR c + + go (_, _, fp) (LineTo OriginAbsolute (p:_)) = + ((p', p', fp), lineTo p') + where p' = toR p + + go (_, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where e' = toR e + c2' = toR c2 + c1' = toR c1 + + go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where c1' = o ^+^ toR c1 + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where c1' = o ^* 2 ^-^ control + c2' = toR c2 + e' = toR e + + go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where c1' = o ^* 2 ^-^ control + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (_, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) = + ((e', c1', fp), quadTo c1' e') + where e' = toR e + c1' = toR c1 + + go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) = + ((e', c1', fp), quadTo c1' e') + where c1' = o ^+^ toR c1 + e' = o ^+^ toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) = + ((e', c1', fp), quadTo c1' e') + where c1' = o ^* 2 ^-^ control + e' = toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) = + ((e', c1', fp), quadTo c1' e') + where c1' = o ^* 2 ^-^ control + e' = o ^+^ toR e + + go _ (ElipticalArc _ _) = error "Unimplemented" +
+ src/Graphics/Rasterific/Svg/RasterificRender.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Svg.RasterificRender + ( DrawResult( .. ) + , renderSvgDocument + , drawingOfSvgDocument + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty, mconcat ) +#endif + +import Data.Monoid( Last( .. ), (<>) ) +import Data.Maybe( fromMaybe ) +import Data.Word( Word8 ) +import Control.Monad( foldM ) +import Control.Monad.IO.Class( liftIO ) +import Control.Monad.Trans.State.Strict( modify, runStateT ) +import Control.Applicative( (<$>) ) +import Control.Lens( (&), (.~) ) +import qualified Codec.Picture as CP +import Codec.Picture( PixelRGBA8( .. ) + , PixelRGB16( .. ) + , PixelRGBA16( .. ) + , PixelRGBF( .. ) + , PixelYA16( .. ) + , PixelCMYK8 + , PixelYCbCr8 + , PixelRGB8 + , DynamicImage( .. ) + , pixelMap + , readImage + ) +import Codec.Picture.Types( promoteImage + , promotePixel + , convertPixel + ) + +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Graphics.Rasterific as R +import System.FilePath( (</>), dropFileName ) +import Graphics.Rasterific.Linear( V2( V2 ), (^+^), (^-^), (^*), zero ) +import Graphics.Rasterific.Outline +import qualified Graphics.Rasterific.Transformations as RT +import Graphics.Text.TrueType +import Graphics.Svg.Types hiding ( Dpi ) +import Graphics.Rasterific.Svg.PathConverter +import Graphics.Rasterific.Svg.RenderContext +import Graphics.Rasterific.Svg.RasterificTextRendering + +{-import Debug.Trace-} +{-import Text.Groom-} +{-import Text.Printf-} + +-- | Represent a Rasterific drawing with the associated +-- image size. +data DrawResult = DrawResult + { -- | Rasterific drawing, can be reused and composed + -- with other elements for scene drawing. + _drawAction :: R.Drawing PixelRGBA8 () + -- | Supposed drawing width of the drawing, ideally + -- represent the final image width. + , _drawWidth :: {-# UNPACK #-}!Int + -- | Supposed drawing height of the drawing, ideally + -- represent the final image height. + , _drawHeight :: {-# UNPACK #-}!Int + } + +renderSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document + -> IO (CP.Image PixelRGBA8, LoadedElements) +renderSvgDocument cache sizes dpi doc = do + (drawing, loaded) <- drawingOfSvgDocument cache sizes dpi doc + let color = PixelRGBA8 0 0 0 0 + img = R.renderDrawing (_drawWidth drawing) (_drawHeight drawing) color + $ _drawAction drawing + return (img, loaded) + +drawingOfSvgDocument :: FontCache -> Maybe (Int, Int) -> Dpi -> Document + -> IO (DrawResult, LoadedElements) +drawingOfSvgDocument cache sizes dpi doc = case sizes of + Just s -> renderAtSize s + Nothing -> renderAtSize $ documentSize dpi doc + where + uuWidth = toUserUnit dpi <$> _width doc + uuHeight = toUserUnit dpi <$> _height doc + (x1, y1, x2, y2) = case (_viewBox doc, uuWidth, uuHeight) of + (Just v, _, _) -> v + ( _, Just (Num w), Just (Num h)) -> (0, 0, floor w, floor h) + _ -> (0, 0, 1, 1) + + box = (V2 (fromIntegral x1) (fromIntegral y1), + V2 (fromIntegral x2) (fromIntegral y2)) + emptyContext = RenderContext + { _renderViewBox = box + , _initialViewBox = box + , _contextDefinitions = _definitions doc + , _fontCache = cache + , _renderDpi = dpi + , _subRender = subRenderer + , _basePath = _documentLocation doc + } + + subRenderer subDoc = do + (drawing, loaded) <- + liftIO $ renderSvgDocument cache Nothing dpi subDoc + modify (<> loaded) + return drawing + + sizeFitter (V2 0 0, V2 vw vh) (actualWidth, actualHeight) + | aw /= vw || vh /= ah = + R.withTransformation (RT.scale (aw / vw) (ah / vh)) + where + aw = fromIntegral actualWidth + ah = fromIntegral actualHeight + sizeFitter (V2 0 0, _) _ = id + sizeFitter (p@(V2 xs ys), V2 xEnd yEnd) actualSize = + R.withTransformation (RT.translate (negate p)) . + sizeFitter (zero, V2 (xEnd - xs) (yEnd - ys)) actualSize + + renderAtSize (w, h) = do + let stateDraw = mapM (renderSvg emptyContext) $ _elements doc + (elems, s) <- runStateT stateDraw mempty + let drawing = sizeFitter box (w, h) $ sequence_ elems + return (DrawResult drawing w h, s) + +withInfo :: (Monad m, Monad m2) + => (a -> Maybe b) -> a -> (b -> m (m2 ())) -> m (m2 ()) +withInfo accessor val action = + case accessor val of + Nothing -> return $ return () + Just v -> action v + +toTransformationMatrix :: Transformation -> RT.Transformation +toTransformationMatrix = go where + go (TransformMatrix a b c d e f) = + RT.Transformation a b c d e f + go (Translate x y) = RT.translate $ V2 x y + go (Scale xs Nothing) = RT.scale xs xs + go (Scale xs (Just ys)) = RT.scale xs ys + go (Rotate angle Nothing) = + RT.rotate $ toRadian angle + go (Rotate angle (Just (cx, cy))) = + RT.rotateCenter (toRadian angle) $ V2 cx cy + go (SkewX v) = RT.skewX $ toRadian v + go (SkewY v) = RT.skewY $ toRadian v + go TransformUnknown = mempty + +withTransform :: DrawAttributes -> R.Drawing a () + -> R.Drawing a () +withTransform trans draw = + case _transform trans of + Nothing -> draw + Just t -> R.withTransformation fullTrans draw + where fullTrans = F.foldMap toTransformationMatrix t + +withSvgTexture :: RenderContext -> DrawAttributes + -> Texture -> Float + -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +withSvgTexture ctxt attr texture opacity prims = do + mayTexture <- prepareTexture ctxt attr texture opacity prims + case mayTexture of + Nothing -> return $ return () + Just tex -> + let method = fillMethodOfSvg attr in + return . R.withTexture tex $ R.fillWithMethod method prims + +filler :: RenderContext + -> DrawAttributes + -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +filler ctxt info primitives = + withInfo (getLast . _fillColor) info $ \svgTexture -> + let opacity = fromMaybe 1.0 $ _fillOpacity info in + withSvgTexture ctxt info svgTexture opacity primitives + + +drawMarker :: (DrawAttributes -> Last ElementRef) + -> (R.Drawing PixelRGBA8 () -> Bool -> [R.Primitive] -> R.Drawing PixelRGBA8 ()) + -> RenderContext -> DrawAttributes -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +drawMarker accessor placer ctxt info prims = + withInfo (getLast . accessor) info $ \markerName -> + case markerElem markerName of + Nothing -> return mempty + Just (ElementMarker mark) -> do + let subInfo = initialDrawAttributes <> _markerDrawAttributes mark + markerGeometry <- mapM (renderTree ctxt subInfo) + $ _markerElements mark + let fittedGeometry = baseOrientation mark . fit mark $ mconcat markerGeometry + return $ placer fittedGeometry (shouldOrient mark) prims + Just _ -> return mempty + where + markerElem RefNone = Nothing + markerElem (Ref markerName) = + M.lookup markerName $ _contextDefinitions ctxt + + shouldOrient m = case _markerOrient m of + Just OrientationAuto -> True + Nothing -> False + Just (OrientationAngle _) -> False + + baseOrientation m = case _markerOrient m of + Nothing -> id + Just OrientationAuto -> id + Just (OrientationAngle a) -> + R.withTransformation (RT.rotate $ toRadian a) + + units = + fromMaybe MarkerUnitStrokeWidth . _markerUnits + + toNumber n = case toUserUnit (_renderDpi ctxt) n of + Num a -> a + _ -> 1.0 + + toStrokeSize n = do + sw <- toNumber <$> getLast (_strokeWidth info) + v <- toNumber <$> n + return . Num $ sw * v + + negatePoint (a, b) = + (mapNumber negate a, mapNumber negate b) + + fit markerInfo = case units markerInfo of + MarkerUnitUserSpaceOnUse -> + fitBox ctxt info + (Num 0, Num 0) + (_markerWidth markerInfo) + (_markerHeight markerInfo) + (negatePoint $ _markerRefPoint markerInfo) + (_markerViewBox markerInfo) + + MarkerUnitStrokeWidth -> + fitBox ctxt info + (Num 0, Num 0) + (toStrokeSize $ _markerWidth markerInfo) + (toStrokeSize $ _markerHeight markerInfo) + (negatePoint $ _markerRefPoint markerInfo) + (_markerViewBox markerInfo) + +drawEndMarker :: RenderContext -> DrawAttributes -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +drawEndMarker = drawMarker _markerEnd transformLast where + transformLast _ _ [] = return () + transformLast geom shouldOrient lst = R.withTransformation trans geom + where + prim = last lst + pp = R.lastPointOf prim + orient = R.lastTangeantOf prim + trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient + | otherwise = RT.translate pp + +drawMidMarker :: RenderContext -> DrawAttributes -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +drawMidMarker = drawMarker _markerMid transformStart where + transformStart geom shouldOrient = go where + go [] = return () + go [_] = return () + go (prim:rest@(p2:_)) = R.withTransformation trans geom >> go rest + where + pp = R.lastPointOf prim + prevOrient = R.lastTangeantOf prim + nextOrient = R.firstTangeantOf p2 + orient = (prevOrient ^+^ nextOrient) ^* 0.5 + trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient + | otherwise = RT.translate pp + +drawStartMarker :: RenderContext -> DrawAttributes -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +drawStartMarker = drawMarker _markerStart transformStart where + transformStart _ _ [] = return () + transformStart geom shouldOrient (prim:_) = R.withTransformation trans geom + where + pp = R.firstPointOf prim + orient = R.firstTangeantOf prim + trans | shouldOrient = RT.translate pp <> RT.toNewXBase orient + | otherwise = RT.translate pp + + +stroker :: Bool -> RenderContext -> DrawAttributes -> [R.Primitive] + -> IODraw (R.Drawing PixelRGBA8 ()) +stroker withMarker ctxt info primitives = + withInfo (getLast . _strokeWidth) info $ \swidth -> + withInfo (getLast . _strokeColor) info $ \svgTexture -> + let toFloat = lineariseLength ctxt info + realWidth = toFloat swidth + dashOffsetStart = + maybe 0 toFloat . getLast $ _strokeOffset info + primsList = case getLast $ _strokeDashArray info of + Just pat -> + dashedStrokize dashOffsetStart (toFloat <$> pat) + realWidth (joinOfSvg info) (capOfSvg info) primitives + Nothing -> + [strokize realWidth (joinOfSvg info) (capOfSvg info) primitives] + opacity = fromMaybe 1.0 $ _strokeOpacity info + strokerAction acc prims = + (acc <>) <$> + withSvgTexture ctxt info svgTexture opacity prims + + in do + geom <- + if withMarker then do + start <- drawStartMarker ctxt info primitives + mid <- drawMidMarker ctxt info primitives + end <- drawEndMarker ctxt info primitives + return $ start <> mid <> end + else return mempty + final <- foldM strokerAction mempty primsList + return (final <> geom) + +mergeContext :: RenderContext -> DrawAttributes -> RenderContext +mergeContext ctxt _attr = ctxt + +viewBoxOfTree :: Tree -> Maybe (Int, Int, Int, Int) +viewBoxOfTree (SymbolTree (Symbol g)) = _groupViewBox g +viewBoxOfTree _ = Nothing + +geometryOfNamedElement :: RenderContext -> String -> Tree +geometryOfNamedElement ctxt str = + maybe None extractGeometry . M.lookup str $ _contextDefinitions ctxt + where + extractGeometry e = case e of + ElementLinearGradient _ -> None + ElementRadialGradient _ -> None + ElementPattern _ -> None + ElementMarker _ -> None + ElementMask _ -> None + ElementClipPath _ -> None + ElementGeometry g -> g + +imgToPixelRGBA8 :: DynamicImage -> CP.Image PixelRGBA8 +imgToPixelRGBA8 img = case img of + ImageY8 i -> promoteImage i + ImageY16 i -> + pixelMap (\y -> let v = w2b y in PixelRGBA8 v v v 255) i + ImageYF i -> + pixelMap (\f -> let v = f2b f in PixelRGBA8 v v v 255) i + ImageYA8 i -> promoteImage i + ImageYA16 i -> + pixelMap (\(PixelYA16 y a) -> let v = w2b y in PixelRGBA8 v v v (w2b a)) i + ImageRGB8 i -> promoteImage i + ImageRGB16 i -> pixelMap rgb162Rgba8 i + ImageRGBF i -> pixelMap rgbf2rgba8 i + ImageRGBA8 i -> i + ImageRGBA16 i -> pixelMap rgba162Rgba8 i + ImageYCbCr8 i -> pixelMap (promotePixel . yCbCr2Rgb) i + ImageCMYK8 i -> pixelMap (promotePixel . cmyk2Rgb) i + ImageCMYK16 i -> pixelMap (rgb162Rgba8 . convertPixel) i + where + yCbCr2Rgb :: PixelYCbCr8 -> PixelRGB8 + yCbCr2Rgb = convertPixel + + cmyk2Rgb :: PixelCMYK8 -> PixelRGB8 + cmyk2Rgb = convertPixel + + w2b v = fromIntegral $ v `div` 257 + f2b :: Float -> Word8 + f2b v = floor . max 0 . min 255 $ v * 255 + + rgbf2rgba8 (PixelRGBF r g b) = + PixelRGBA8 (f2b r) (f2b g) (f2b b) 255 + rgba162Rgba8 (PixelRGBA16 r g b a) = + PixelRGBA8 (w2b r) (w2b g) (w2b b) (w2b a) + rgb162Rgba8 (PixelRGB16 r g b)= + PixelRGBA8 (w2b r) (w2b g) (w2b b) 255 + + +renderImage :: RenderContext -> DrawAttributes -> Image + -> IODraw (R.Drawing PixelRGBA8 ()) +renderImage ctxt attr imgInfo = do + let rootFolder = dropFileName $ _basePath ctxt + realPath = rootFolder </> _imageHref imgInfo + eimg <- liftIO $ readImage realPath + let srect = RectangleTree $ defaultSvg + { _rectUpperLeftCorner = _imageCornerUpperLeft imgInfo + , _rectDrawAttributes = + _imageDrawAttributes imgInfo & fillColor .~ Last (Just FillNone) + , _rectWidth = _imageWidth imgInfo + , _rectHeight = _imageHeight imgInfo + } + + case eimg of + Left _ -> renderTree ctxt attr srect + Right img -> do + let pAttr = _imageDrawAttributes imgInfo + info = attr <> pAttr + context' = mergeContext ctxt pAttr + p' = linearisePoint context' info $ _imageCornerUpperLeft imgInfo + w' = lineariseXLength context' info $ _imageWidth imgInfo + h' = lineariseYLength context' info $ _imageHeight imgInfo + filling = R.drawImageAtSize (imgToPixelRGBA8 img) 0 p' w' h' + stroking <- stroker False context' info $ R.rectangle p' w' h' + return . withTransform pAttr $ filling <> stroking + +initialDrawAttributes :: DrawAttributes +initialDrawAttributes = mempty + { _strokeWidth = Last . Just $ Num 1.0 + , _strokeLineCap = Last $ Just CapButt + , _strokeLineJoin = Last $ Just JoinMiter + , _strokeMiterLimit = Last $ Just 4.0 + , _strokeOpacity = Just 1.0 + , _fillColor = Last . Just . ColorRef $ PixelRGBA8 0 0 0 255 + , _fillOpacity = Just 1.0 + , _fillRule = Last $ Just FillNonZero + , _fontSize = Last . Just $ Num 16 + , _textAnchor = Last $ Just TextAnchorStart + } + + +renderSvg :: RenderContext -> Tree -> IODraw (R.Drawing PixelRGBA8 ()) +renderSvg initialContext = renderTree initialContext initialDrawAttributes + + +fitBox :: RenderContext -> DrawAttributes + -> Point -> Maybe Number -> Maybe Number -> Point + -> Maybe (Int, Int, Int, Int) + -> R.Drawing px () + -> R.Drawing px () +fitBox ctxt attr basePoint mwidth mheight preTranslate viewbox = + let origin = linearisePoint ctxt attr basePoint + preShift = linearisePoint ctxt attr preTranslate + w = lineariseXLength ctxt attr <$> mwidth + h = lineariseYLength ctxt attr <$> mheight + in + case viewbox of + Nothing -> R.withTransformation (RT.translate origin) + (Just (xs, ys, xe, ye)) -> + let boxOrigin = V2 (fromIntegral xs) (fromIntegral ys) + boxEnd = V2 (fromIntegral xe) (fromIntegral ye) + V2 bw bh = abs $ boxEnd ^-^ boxOrigin + xScaleFactor = case w of + Just wpx -> wpx / bw + Nothing -> 1.0 + yScaleFactor = case h of + Just hpx -> hpx / bh + Nothing -> 1.0 + in + R.withTransformation $ RT.translate origin + <> RT.scale xScaleFactor yScaleFactor + <> RT.translate (negate boxOrigin ^+^ preShift) + +fitUse :: RenderContext -> DrawAttributes -> Use -> Tree + -> R.Drawing px () + -> R.Drawing px () +fitUse ctxt attr useElement subTree = + fitBox ctxt attr + (_useBase useElement) + (_useWidth useElement) + (_useHeight useElement) + (Num 0, Num 0) + (viewBoxOfTree subTree) + +renderTree :: RenderContext -> DrawAttributes -> Tree -> IODraw (R.Drawing PixelRGBA8 ()) +renderTree = go where + go _ _ None = return mempty + go ctxt attr (TextTree tp stext) = renderText ctxt attr tp stext + go ctxt attr (ImageTree i) = renderImage ctxt attr i + go ctxt attr (UseTree useData (Just subTree)) = do + sub <- go ctxt attr' subTree + return . fitUse ctxt attr useData subTree + $ withTransform pAttr sub + where + pAttr = _useDrawAttributes useData + attr' = attr <> pAttr + + go ctxt attr (UseTree useData Nothing) = do + sub <- go ctxt attr' subTree + return . fitUse ctxt attr useData subTree + $ withTransform pAttr sub + where + pAttr = _useDrawAttributes useData + attr' = attr <> pAttr + subTree = geometryOfNamedElement ctxt $ _useName useData + + go ctxt attr (SymbolTree (Symbol g)) = go ctxt attr $ GroupTree g + go ctxt attr (GroupTree (Group groupAttr subTrees _)) = do + subTrees' <- mapM (go context' attr') subTrees + return . withTransform groupAttr $ sequence_ subTrees' + where attr' = attr <> groupAttr + context' = mergeContext ctxt groupAttr + + go ctxt attr (RectangleTree (Rectangle pAttr p w h (rx, ry))) = do + let info = attr <> pAttr + context' = mergeContext ctxt pAttr + p' = linearisePoint context' info p + w' = lineariseXLength context' info w + h' = lineariseYLength context' info h + + rx' = lineariseXLength context' info rx + ry' = lineariseXLength context' info ry + rect = case (rx', ry') of + (0, 0) -> R.rectangle p' w' h' + (v, 0) -> R.roundedRectangle p' w' h' v v + (0, v) -> R.roundedRectangle p' w' h' v v + (vx, vy) -> R.roundedRectangle p' w' h' vx vy + + filling <- filler context' info rect + stroking <- stroker False context' info rect + return . withTransform pAttr $ filling <> stroking + + go ctxt attr (CircleTree (Circle pAttr p r)) = do + let info = attr <> pAttr + context' = mergeContext ctxt pAttr + p' = linearisePoint context' info p + r' = lineariseLength context' info r + c = R.circle p' r' + filling <- filler context' info c + stroking <- stroker False context' info c + return . withTransform pAttr $ filling <> stroking + + go ctxt attr (EllipseTree (Ellipse pAttr p rx ry)) = do + let info = attr <> pAttr + context' = mergeContext ctxt pAttr + p' = linearisePoint context' info p + rx' = lineariseXLength context' info rx + ry' = lineariseYLength context' info ry + c = R.ellipse p' rx' ry' + filling <- filler context' info c + stroking <- stroker False context' info c + return . withTransform pAttr $ filling <> stroking + + go ctxt attr (PolyLineTree (PolyLine pAttr points)) = + go ctxt (dropFillColor attr) + . PathTree . Path (dropFillColor pAttr) + $ toPath points + where + dropFillColor v = v { _fillColor = Last Nothing } + toPath [] = [] + toPath (x:xs) = + [ MoveTo OriginAbsolute [x] + , LineTo OriginAbsolute xs + ] + + go ctxt attr (PolygonTree (Polygon pAttr points)) = + go ctxt attr . PathTree . Path pAttr $ toPath points + where + toPath [] = [] + toPath (x:xs) = + [ MoveTo OriginAbsolute [x] + , LineTo OriginAbsolute xs + , EndPath + ] + + go ctxt attr (LineTree (Line pAttr p1 p2)) = do + let info = attr <> pAttr + context' = mergeContext ctxt pAttr + p1' = linearisePoint context' info p1 + p2' = linearisePoint context' info p2 + stroking <- stroker True context' info $ R.line p1' p2' + return $ withTransform pAttr stroking + + go ctxt attr (PathTree (Path pAttr p)) = do + let info = attr <> pAttr + strokePrimitives = svgPathToPrimitives False p + fillPrimitives = svgPathToPrimitives True p + filling <- filler ctxt info fillPrimitives + stroking <- stroker True ctxt info strokePrimitives + return . withTransform pAttr $ filling <> stroking +
+ src/Graphics/Rasterific/Svg/RasterificTextRendering.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Svg.RasterificTextRendering + ( renderText ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>) ) +import Data.Monoid( mappend, mempty ) +#endif + +import Control.Monad( foldM ) +import Control.Monad.IO.Class( liftIO ) +import Control.Monad.Identity( Identity ) +import Control.Monad.Trans.State.Strict( execState + , StateT + , modify + , gets ) +import Control.Applicative( (<$>), (<|>) ) +import Control.Lens( at, (?=) ) +import qualified Control.Lens as L +import Codec.Picture( PixelRGBA8( .. ) ) +import qualified Data.Foldable as F +import Data.Monoid( (<>), Last( .. ), First( .. ) ) +import Data.Maybe( fromMaybe ) +import qualified Data.Text as T +import Graphics.Rasterific.Linear( (^+^), (^-^) ) +import Graphics.Rasterific hiding ( Path, Line, Texture, transform ) +import qualified Graphics.Rasterific as R +import qualified Graphics.Rasterific.Outline as RO +import Graphics.Rasterific.Immediate +import qualified Graphics.Rasterific.Transformations as RT +import Graphics.Rasterific.PathWalker +import Graphics.Text.TrueType +import Graphics.Svg.Types +import Graphics.Rasterific.Svg.RenderContext +import Graphics.Rasterific.Svg.PathConverter +{-import Graphics.Svg.XmlParser-} + +{-import Debug.Trace-} +{-import Text.Printf-} + +loadFont :: FilePath -> IODraw (Maybe Font) +loadFont fontPath = do + loaded <- L.use $ loadedFonts . at fontPath + case loaded of + Just v -> return $ Just v + Nothing -> do + file <- liftIO $ loadFontFile fontPath + case file of + Left _ -> return Nothing + Right f -> do + loadedFonts . at fontPath ?= f + return $ Just f + +data RenderableString px = RenderableString + { _renderableAttributes :: !DrawAttributes + , _renderableSize :: !Float + , _renderableFont :: !Font + , _renderableString :: ![(Char, CharInfo px)] + } + +data CharInfo px = CharInfo + { _charX :: Maybe Number + , _charY :: Maybe Number + , _charDx :: Maybe Number + , _charDy :: Maybe Number + , _charRotate :: Maybe Float + , _charStroke :: Maybe (Float, R.Texture px, R.Join, (R.Cap, R.Cap)) + } + +emptyCharInfo :: CharInfo px +emptyCharInfo = CharInfo + { _charX = Nothing + , _charY = Nothing + , _charDx = Nothing + , _charDy = Nothing + , _charRotate = Nothing + , _charStroke = Nothing + } + +propagateTextInfo :: TextInfo -> TextInfo -> TextInfo +propagateTextInfo parent current = TextInfo + { _textInfoX = combine _textInfoX + , _textInfoY = combine _textInfoY + , _textInfoDX = combine _textInfoDX + , _textInfoDY = combine _textInfoDY + , _textInfoRotate = combine _textInfoRotate + , _textInfoLength = _textInfoLength current + } + where + combine f = case f current of + [] -> f parent + lst -> lst + +textInfoRests :: TextInfo -> TextInfo -> TextInfo + -> TextInfo +textInfoRests this parent sub = TextInfo + { _textInfoX = decideWith _textInfoX + , _textInfoY = decideWith _textInfoY + , _textInfoDX = decideWith _textInfoDX + , _textInfoDY = decideWith _textInfoDY + , _textInfoRotate = decideWith _textInfoRotate + , _textInfoLength = _textInfoLength parent + } + where + decideWith f = decide (f this) (f parent) (f sub) + + decide [] _ ssub = ssub + decide _ top _ = top + +unconsTextInfo :: RenderContext -> DrawAttributes -> TextInfo + -> IODraw (CharInfo PixelRGBA8, TextInfo) +unconsTextInfo ctxt attr nfo = do + texture <- textureOf ctxt attr _strokeColor _strokeOpacity + return (charInfo texture, restText) + where + unconsInf lst = case lst of + [] -> (Nothing, []) + (x:xs) -> (Just x, xs) + + (xC, xRest) = unconsInf $ _textInfoX nfo + (yC, yRest) = unconsInf $ _textInfoY nfo + (dxC, dxRest) = unconsInf $ _textInfoDX nfo + (dyC, dyRest) = unconsInf $ _textInfoDY nfo + (rotateC, rotateRest) = unconsInf $ _textInfoRotate nfo + + restText = TextInfo + { _textInfoX = xRest + , _textInfoY = yRest + , _textInfoDX = dxRest + , _textInfoDY = dyRest + , _textInfoRotate = rotateRest + , _textInfoLength = _textInfoLength nfo + } + + sWidth = + lineariseLength ctxt attr <$> getLast (_strokeWidth attr) + + charInfo tex = CharInfo + { _charX = xC + , _charY = yC + , _charDx = dxC + , _charDy = dyC + , _charRotate = rotateC + , _charStroke = + (,, joinOfSvg attr, capOfSvg attr) <$> sWidth <*> tex + } + +repeatLast :: [a] -> [a] +repeatLast = go where + go lst = case lst of + [] -> [] + [x] -> repeat x + (x:xs) -> x : go xs + +infinitizeTextInfo :: TextInfo -> TextInfo +infinitizeTextInfo nfo = + nfo { _textInfoRotate = repeatLast $ _textInfoRotate nfo } + + +-- | Monadic version of mapAccumL +mapAccumLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining funcction + -> acc -- ^ initial state + -> [x] -- ^ inputs + -> m (acc, [y]) -- ^ final state, outputs +mapAccumLM _ s [] = return (s, []) +mapAccumLM f s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- mapAccumLM f s1 xs + return (s2, x' : xs') + +mixWithRenderInfo :: RenderContext -> DrawAttributes + -> TextInfo -> String + -> IODraw (TextInfo, [(Char, CharInfo PixelRGBA8)]) +mixWithRenderInfo ctxt attr = mapAccumLM go where + go info c = do + (thisInfo, rest) <- unconsTextInfo ctxt attr info + return (rest, (c, thisInfo)) + + +data LetterTransformerState = LetterTransformerState + { _charactersInfos :: ![CharInfo PixelRGBA8] + , _characterCurrent :: !(CharInfo PixelRGBA8) + , _currentCharDelta :: !R.Point + , _currentAbsoluteDelta :: !R.Point + , _currentDrawing :: Drawing PixelRGBA8 () + , _stringBounds :: !PlaneBound + } + +type GlyphPlacer = StateT LetterTransformerState Identity + +unconsCurrentLetter :: GlyphPlacer () +unconsCurrentLetter = modify $ \s -> + case _charactersInfos s of + [] -> s + (x:xs) -> s { _charactersInfos = xs + , _characterCurrent = x + } + +prepareCharRotation :: CharInfo px -> R.PlaneBound -> RT.Transformation +prepareCharRotation info bounds = case _charRotate info of + Nothing -> mempty + Just angle -> RT.rotateCenter (toRadian angle) lowerLeftCorner + where + lowerLeftCorner = boundLowerLeftCorner bounds + +prepareCharTranslation :: RenderContext -> CharInfo px -> R.PlaneBound + -> R.Point -> R.Point + -> (R.Point, R.Point, RT.Transformation) +prepareCharTranslation ctxt info bounds prevDelta prevAbsolute = go where + lowerLeftCorner = boundLowerLeftCorner bounds + toRPoint a b = linearisePoint ctxt mempty (a, b) + mzero = Just $ Num 0 + V2 pmx pmy = Just . Num <$> prevAbsolute + + mayForcedPoint = case (_charX info, _charY info) of + (Nothing, Nothing) -> Nothing + (mx, my) -> toRPoint <$> (mx <|> pmx) <*> (my <|> pmy) + + delta = fromMaybe 0 $ + toRPoint <$> (_charDx info <|> mzero) + <*> (_charDy info <|> mzero) + + go = case mayForcedPoint of + Nothing -> + let newDelta = prevDelta ^+^ delta + trans = RT.translate $ newDelta ^+^ prevAbsolute in + (newDelta, prevAbsolute, trans) + + Just p -> + let newDelta = prevDelta ^+^ delta + positionDelta = p ^-^ lowerLeftCorner + trans = RT.translate $ positionDelta ^+^ newDelta in + (newDelta, positionDelta, trans) + +transformPlaceGlyph :: RenderContext + -> RT.Transformation + -> R.PlaneBound + -> DrawOrder PixelRGBA8 + -> GlyphPlacer () +transformPlaceGlyph ctxt pathTransformation bounds order = do + unconsCurrentLetter + info <- gets _characterCurrent + delta <- gets _currentCharDelta + absoluteDelta <- gets _currentAbsoluteDelta + let rotateTrans = prepareCharRotation info bounds + (newDelta, newAbsolute, placement) = + prepareCharTranslation ctxt info bounds delta absoluteDelta + finalTrans = pathTransformation <> placement <> rotateTrans + newGeometry = + R.transform (RT.applyTransformation finalTrans) $ _orderPrimitives order + newOrder = order { _orderPrimitives = newGeometry } + + + stroking Nothing = return () + stroking (Just (w, texture, rjoin, cap)) = + orderToDrawing $ newOrder { + _orderPrimitives = stroker <$> _orderPrimitives newOrder, + _orderTexture = texture + } + where + stroker = RO.strokize w rjoin cap + + modify $ \s -> s + { _currentCharDelta = newDelta + , _currentAbsoluteDelta = newAbsolute + , _stringBounds = _stringBounds s <> bounds + , _currentDrawing = do + _currentDrawing s + orderToDrawing newOrder + stroking $ _charStroke info + } + +prepareFontFamilies :: DrawAttributes -> [String] +prepareFontFamilies = (++ defaultFont) + . fmap replaceDefault + . fromMaybe [] + . getLast + . _fontFamily + where + defaultFont = ["Arial"] + -- using "safe" web font, hoping they are present on + -- the system. + replaceDefault s = case s of + "monospace" -> "Courier New" + "sans-serif" -> "Arial" + "serif" -> "Times New Roman" + _ -> s + +fontOfAttributes :: FontCache -> DrawAttributes -> IODraw (Maybe Font) +fontOfAttributes fontCache attr = case fontFilename of + Nothing -> return Nothing + Just fn -> loadFont fn + where + fontFilename = + getFirst . F.foldMap fontFinder $ prepareFontFamilies attr + noStyle = FontStyle + { _fontStyleBold = False + , _fontStyleItalic = False } + + italic = noStyle { _fontStyleItalic = True } + + style = case getLast $ _fontStyle attr of + Nothing -> noStyle + Just FontStyleNormal -> noStyle + Just FontStyleItalic -> italic + Just FontStyleOblique -> italic + + fontFinder ff = + First $ findFontInCache fontCache descriptor + where descriptor = FontDescriptor + { _descriptorFamilyName = T.pack ff + , _descriptorStyle = style } + + +prepareRenderableString :: RenderContext -> DrawAttributes -> Text + -> IODraw [RenderableString PixelRGBA8] +prepareRenderableString ctxt ini_attr root = + fst <$> everySpan ini_attr mempty (_textRoot root) where + + everySpan attr originalInfo tspan = + foldM (everyContent subAttr) (mempty, nfo) $ _spanContent tspan + where + subAttr = attr <> _spanDrawAttributes tspan + nfo = propagateTextInfo originalInfo + . infinitizeTextInfo + $ _spanInfo tspan + + everyContent _attr (acc, info) (SpanTextRef _) = return (acc, info) + everyContent attr (acc, info) (SpanSub thisSpan) = do + let thisTextInfo = _spanInfo thisSpan + (drawn, newInfo) <- everySpan attr info thisSpan + return (acc <> drawn, textInfoRests thisTextInfo info newInfo) + everyContent attr (acc, info) (SpanText txt) = do + font <- fontOfAttributes (_fontCache ctxt) attr + case font of + Nothing -> return (acc, info) + Just f -> do + (info', str) <- mixWithRenderInfo ctxt attr info $ T.unpack txt + let finalStr = RenderableString attr size f str + return (acc <> [finalStr], info') + + where + size = case getLast $ _fontSize attr of + Just v -> lineariseLength ctxt attr v + Nothing -> 16 + + +anchorStringRendering :: TextAnchor -> LetterTransformerState + -> Drawing PixelRGBA8 () +anchorStringRendering anchor st = case anchor of + TextAnchorStart -> _currentDrawing st + TextAnchorMiddle -> + withTransformation (RT.translate (V2 (negate $ stringWidth / 2) 0)) $ + _currentDrawing st + TextAnchorEnd -> + withTransformation (RT.translate (V2 (- stringWidth) 0)) $ _currentDrawing st + where + stringWidth = boundWidth $ _stringBounds st + +notWhiteSpace :: (Char, a) -> Bool +notWhiteSpace (c, _) = c /= ' ' && c /= '\t' + +initialLetterTransformerState :: [RenderableString PixelRGBA8] -> LetterTransformerState +initialLetterTransformerState str = LetterTransformerState + { _charactersInfos = + fmap snd . filter notWhiteSpace . concat $ _renderableString <$> str + , _characterCurrent = emptyCharInfo + , _currentCharDelta = V2 0 0 + , _currentAbsoluteDelta = V2 0 0 + , _currentDrawing = mempty + , _stringBounds = mempty + } + +executePlacer :: Monad m => PathDrawer m px -> [DrawOrder px] -> m () +executePlacer placer = F.mapM_ exec where + exec order | bounds == mempty = return () + | otherwise = placer mempty bounds order + where + bounds = F.foldMap (F.foldMap planeBounds) + $ _orderPrimitives order + +textureOf :: RenderContext + -> DrawAttributes + -> (DrawAttributes -> Last Texture) + -> (DrawAttributes -> Maybe Float) + -> IODraw (Maybe (R.Texture PixelRGBA8)) +textureOf ctxt attr colorAccessor opacityAccessor = + case getLast $ colorAccessor attr of + Nothing -> return Nothing + Just svgTexture -> + prepareTexture ctxt attr svgTexture opacity [] + where opacity = fromMaybe 1.0 $ opacityAccessor attr + +renderString :: RenderContext -> Maybe (Float, R.Path) -> TextAnchor + -> [RenderableString PixelRGBA8] + -> IODraw (Drawing PixelRGBA8 ()) +renderString ctxt mayPath anchor str = do + textRanges <- mapM toFillTextRange str + + case mayPath of + Just (offset, tPath) -> + return . pathPlacer offset tPath $ fillOrders textRanges + Nothing -> return . linePlacer $ fillOrders textRanges + where + fillOrders = + drawOrdersOfDrawing swidth sheight (_renderDpi ctxt) background + . printTextRanges 0 + + pixelToPt s = pixelSizeInPointAtDpi s $ _renderDpi ctxt + (mini, maxi) = _renderViewBox ctxt + V2 swidth sheight = floor <$> (maxi ^-^ mini) + background = PixelRGBA8 0 0 0 0 + + pathPlacer offset tPath = + anchorStringRendering anchor + . flip execState (initialLetterTransformerState str) + . drawOrdersOnPath (transformPlaceGlyph ctxt) offset 0 tPath + + linePlacer = + anchorStringRendering anchor + . flip execState (initialLetterTransformerState str) + . executePlacer (transformPlaceGlyph ctxt) + + toFillTextRange renderable = do + mayTexture <- textureOf ctxt (_renderableAttributes renderable) + _fillColor _fillOpacity + return TextRange + { _textFont = _renderableFont renderable + , _textSize = pixelToPt $ _renderableSize renderable + , _text = fst <$> _renderableString renderable + , _textTexture = mayTexture + } + +startOffsetOfPath :: RenderContext -> DrawAttributes -> R.Path -> Number + -> Float +startOffsetOfPath _ _ _ (Num i) = i +startOffsetOfPath _ attr _ (Em i) = emTransform attr i +startOffsetOfPath _ _ tPath (Percent p) = + p * RO.approximatePathLength tPath +startOffsetOfPath ctxt attr tPath num = + startOffsetOfPath ctxt attr tPath $ stripUnits ctxt num + +renderText :: RenderContext + -> DrawAttributes + -> Maybe TextPath + -> Text + -> IODraw (Drawing PixelRGBA8 ()) +renderText ctxt attr ppath stext = + prepareRenderableString ctxt attr stext >>= renderString ctxt pathInfo anchor + where + renderPath = + svgPathToRasterificPath False . _textPathData <$> ppath + + offset = do + rpath <- renderPath + mayOffset <- _textPathStartOffset <$> ppath + return $ startOffsetOfPath ctxt attr rpath mayOffset + + pathInfo = (,) <$> (offset <|> return 0) <*> renderPath + + anchor = fromMaybe TextAnchorStart + . getLast + . _textAnchor + . mappend attr + . _spanDrawAttributes $ _textRoot stext +
+ src/Graphics/Rasterific/Svg/RenderContext.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Svg.RenderContext + ( RenderContext( .. ) + , LoadedElements( .. ) + , loadedFonts + , loadedImages + , IODraw + , ViewBox + , toRadian + , capOfSvg + , joinOfSvg + , stripUnits + , boundingBoxLength + , lineariseXLength + , lineariseYLength + , linearisePoint + , lineariseLength + , prepareTexture + , documentOfPattern + , fillAlphaCombine + , fillMethodOfSvg + , emTransform + ) + where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( .. ) ) +#endif + +import Control.Monad.Trans.State.Strict( StateT ) +import Control.Applicative( (<$>) ) +import Codec.Picture( PixelRGBA8( .. ) ) +import qualified Codec.Picture as CP +import qualified Data.Foldable as F +import qualified Data.Map as M +import Data.Monoid( Last( .. ) ) +import Control.Lens( Lens', lens ) + +import Graphics.Rasterific.Linear( (^-^) ) +import qualified Graphics.Rasterific as R +import qualified Graphics.Rasterific.Texture as RT +import Graphics.Text.TrueType +import Graphics.Svg.Types + +toRadian :: Float -> Float +toRadian v = v / 180 * pi + +data RenderContext = RenderContext + { _initialViewBox :: (R.Point, R.Point) + , _renderViewBox :: (R.Point, R.Point) + , _renderDpi :: Int + , _contextDefinitions :: M.Map String Element + , _fontCache :: FontCache + , _subRender :: Document -> IODraw (CP.Image PixelRGBA8) + , _basePath :: FilePath + } + +data LoadedElements = LoadedElements + { _loadedFonts :: M.Map FilePath Font + , _loadedImages :: M.Map FilePath (CP.Image PixelRGBA8) + } + +instance Monoid LoadedElements where + mempty = LoadedElements mempty mempty + mappend (LoadedElements a b) (LoadedElements a' b') = + LoadedElements (a `mappend` a') (b `mappend` b') + +loadedFonts :: Lens' LoadedElements (M.Map FilePath Font) +loadedFonts = lens _loadedFonts (\a b -> a { _loadedFonts = b }) + +loadedImages :: Lens' LoadedElements (M.Map FilePath (CP.Image PixelRGBA8)) +loadedImages = lens _loadedImages (\a b -> a { _loadedImages = b }) + +type IODraw = StateT LoadedElements IO + +type ViewBox = (R.Point, R.Point) + +capOfSvg :: DrawAttributes -> (R.Cap, R.Cap) +capOfSvg attrs = + case getLast $ _strokeLineCap attrs of + Nothing -> (R.CapStraight 1, R.CapStraight 1) + Just CapSquare -> (R.CapStraight 1, R.CapStraight 1) + Just CapButt -> (R.CapStraight 0, R.CapStraight 0) + Just CapRound -> (R.CapRound, R.CapRound) + + +joinOfSvg :: DrawAttributes -> R.Join +joinOfSvg attrs = + case (getLast $ _strokeLineJoin attrs, getLast $ _strokeMiterLimit attrs) of + (Nothing, _) -> R.JoinRound + (Just JoinMiter, Just _) -> R.JoinMiter 0 + (Just JoinMiter, Nothing) -> R.JoinMiter 0 + (Just JoinBevel, _) -> R.JoinMiter 5 + (Just JoinRound, _) -> R.JoinRound + +stripUnits :: RenderContext -> Number -> Number +stripUnits ctxt = toUserUnit (_renderDpi ctxt) + +boundingBoxLength :: RenderContext -> DrawAttributes -> R.PlaneBound -> Number + -> Float +boundingBoxLength ctxt attr (R.PlaneBound mini maxi) = go where + R.V2 actualWidth actualHeight = + abs <$> (maxi ^-^ mini) + two = 2 :: Int + coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two) + / sqrt 2 + go num = case num of + Num n -> n + Em n -> emTransform attr n + Percent p -> p * coeff + _ -> go $ stripUnits ctxt num + +boundbingBoxLinearise :: RenderContext -> DrawAttributes -> R.PlaneBound -> Point + -> R.Point +boundbingBoxLinearise + ctxt attr (R.PlaneBound mini@(R.V2 xi yi) maxi) (xp, yp) = R.V2 (finalX xp) (finalY yp) + where + R.V2 w h = abs <$> (maxi ^-^ mini) + finalX nu = case nu of + Num n -> n + Em n -> emTransform attr n + Percent p -> p * w + xi + _ -> finalX $ stripUnits ctxt nu + + finalY nu = case nu of + Num n -> n + Em n -> emTransform attr n + Percent p -> p * h + yi + _ -> finalY $ stripUnits ctxt nu + +lineariseXLength :: RenderContext -> DrawAttributes -> Number + -> Coord +lineariseXLength _ _ (Num i) = i +lineariseXLength _ attr (Em i) = emTransform attr i +lineariseXLength ctxt _ (Percent p) = abs (xe - xs) * p + where + (R.V2 xs _, R.V2 xe _) = _renderViewBox ctxt +lineariseXLength ctxt attr num = + lineariseXLength ctxt attr $ stripUnits ctxt num + +lineariseYLength :: RenderContext -> DrawAttributes -> Number + -> Coord +lineariseYLength _ _ (Num i) = i +lineariseYLength _ attr (Em n) = emTransform attr n +lineariseYLength ctxt _ (Percent p) = abs (ye - ys) * p + where + (R.V2 _ ys, R.V2 _ ye) = _renderViewBox ctxt +lineariseYLength ctxt attr num = + lineariseYLength ctxt attr $ stripUnits ctxt num + + +linearisePoint :: RenderContext -> DrawAttributes -> Point + -> R.Point +linearisePoint ctxt attr (p1, p2) = + R.V2 (xs + lineariseXLength ctxt attr p1) + (ys + lineariseYLength ctxt attr p2) + where (R.V2 xs ys, _) = _renderViewBox ctxt + +emTransform :: DrawAttributes -> Float -> Float +emTransform attr n = case getLast $ _fontSize attr of + Nothing -> 16 * n + Just (Num v) -> v * n + Just _ -> 16 * n + +lineariseLength :: RenderContext -> DrawAttributes -> Number + -> Coord +lineariseLength _ _ (Num i) = i +lineariseLength _ attr (Em i) = + emTransform attr i +lineariseLength ctxt _ (Percent v) = v * coeff + where + (R.V2 x1 y1, R.V2 x2 y2) = _renderViewBox ctxt + actualWidth = abs $ x2 - x1 + actualHeight = abs $ y2 - y1 + two = 2 :: Int + coeff = sqrt (actualWidth ^^ two + actualHeight ^^ two) + / sqrt 2 +lineariseLength ctxt attr num = + lineariseLength ctxt attr $ stripUnits ctxt num + +prepareLinearGradientTexture + :: RenderContext -> DrawAttributes + -> LinearGradient -> Float -> [R.Primitive] + -> R.Texture PixelRGBA8 +prepareLinearGradientTexture ctxt attr grad opa prims = + let bounds = F.foldMap R.planeBounds prims + lineariser = case _linearGradientUnits grad of + CoordUserSpace -> linearisePoint ctxt attr + CoordBoundingBox -> boundbingBoxLinearise ctxt attr bounds + gradient = + [(offset, fillAlphaCombine opa color) + | GradientStop offset color <- _linearGradientStops grad] + startPoint = lineariser $ _linearGradientStart grad + stopPoint = lineariser $ _linearGradientStop grad + in + RT.linearGradientTexture gradient startPoint stopPoint + +prepareRadialGradientTexture + :: RenderContext -> DrawAttributes + -> RadialGradient -> Float -> [R.Primitive] + -> R.Texture PixelRGBA8 +prepareRadialGradientTexture ctxt attr grad opa prims = + let bounds = F.foldMap R.planeBounds prims + (lineariser, lengthLinearise) = case _radialGradientUnits grad of + CoordUserSpace -> + (linearisePoint ctxt attr, lineariseLength ctxt attr) + CoordBoundingBox -> + (boundbingBoxLinearise ctxt attr bounds, + boundingBoxLength ctxt attr bounds) + gradient = + [(offset, fillAlphaCombine opa color) + | GradientStop offset color <- _radialGradientStops grad] + center = lineariser $ _radialGradientCenter grad + radius = lengthLinearise $ _radialGradientRadius grad + in + case (_radialGradientFocusX grad, + _radialGradientFocusY grad) of + (Nothing, Nothing) -> + RT.radialGradientTexture gradient center radius + (Just fx, Nothing) -> + RT.radialGradientWithFocusTexture gradient center radius + $ lineariser (fx, snd $ _radialGradientCenter grad) + (Nothing, Just fy) -> + RT.radialGradientWithFocusTexture gradient center radius + $ lineariser (fst $ _radialGradientCenter grad, fy) + (Just fx, Just fy) -> + RT.radialGradientWithFocusTexture gradient center radius + $ lineariser (fx, fy) + +fillMethodOfSvg :: DrawAttributes -> R.FillMethod +fillMethodOfSvg attr = case getLast $ _fillRule attr of + Nothing -> R.FillWinding + Just FillNonZero -> R.FillWinding + Just FillEvenOdd -> R.FillEvenOdd + +fillAlphaCombine :: Float -> PixelRGBA8 -> PixelRGBA8 +fillAlphaCombine opacity (PixelRGBA8 r g b a) = + PixelRGBA8 r g b alpha + where + a' = fromIntegral a / 255.0 + alpha = floor . max 0 . min 255 $ opacity * a' * 255 + +documentOfPattern :: Pattern -> String -> Document +documentOfPattern pat loc = Document + { _viewBox = _patternViewBox pat + , _width = return $ _patternWidth pat + , _height = return $ _patternHeight pat + , _elements = _patternElements pat + , _definitions = M.empty + , _styleRules = [] + , _description = "" + , _documentLocation = loc + } + +prepareTexture :: RenderContext -> DrawAttributes + -> Texture -> Float + -> [R.Primitive] + -> IODraw (Maybe (R.Texture PixelRGBA8)) +prepareTexture _ _ FillNone _opacity _ = return Nothing +prepareTexture _ _ (ColorRef color) opacity _ = + return . Just . RT.uniformTexture $ fillAlphaCombine opacity color +prepareTexture ctxt attr (TextureRef ref) opacity prims = + maybe (return Nothing) prepare $ + M.lookup ref (_contextDefinitions ctxt) + where + prepare (ElementGeometry _) = return Nothing + prepare (ElementMarker _) = return Nothing + prepare (ElementMask _) = return Nothing + prepare (ElementClipPath _) = return Nothing + prepare (ElementLinearGradient grad) = + return . Just $ prepareLinearGradientTexture ctxt + attr grad opacity prims + prepare (ElementRadialGradient grad) = + return . Just $ prepareRadialGradientTexture ctxt + attr grad opacity prims + prepare (ElementPattern pat) = do + patternPicture <- _subRender ctxt $ documentOfPattern pat (_basePath ctxt) + return . Just . RT.withSampler R.SamplerRepeat + $ RT.sampledImageTexture patternPicture +