rasterific-svg 0.3.2 → 0.3.2.1
raw patch · 6 files changed
+1661/−1656 lines, 6 filesdep ~basedep ~optparse-applicativePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, optparse-applicative
API changes (from Hackage documentation)
Files
- changelog.md +90/−84
- exec-src/svgrender.hs +128/−128
- rasterific-svg.cabal +73/−73
- src/Graphics/Rasterific/Svg/RasterificRender.hs +596/−597
- src/Graphics/Rasterific/Svg/RasterificTextRendering.hs +468/−468
- src/Graphics/Rasterific/Svg/RenderContext.hs +306/−306
changelog.md view
@@ -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 +
exec-src/svgrender.hs view
@@ -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 +
rasterific-svg.cabal view
@@ -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 +
src/Graphics/Rasterific/Svg/RasterificRender.hs view
@@ -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 +
src/Graphics/Rasterific/Svg/RasterificTextRendering.hs view
@@ -1,468 +1,468 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Svg.RasterificTextRendering- ( renderText ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-import Data.Monoid( mappend, mempty )-#endif--import Control.Monad( foldM )-import Control.Monad.IO.Class( liftIO )-import Control.Monad.Identity( Identity )-import Control.Monad.Trans.State.Strict( execState- , StateT- , modify- , gets )-import Control.Applicative( (<|>) )-import Control.Lens( at, (?=) )-import qualified Control.Lens as L-import Codec.Picture( PixelRGBA8( .. ) )-import qualified Data.Foldable as F-import Data.Monoid( (<>), Last( .. ), First( .. ) )-import Data.Maybe( fromMaybe )-import qualified Data.Text as T-import Graphics.Rasterific.Linear( (^+^), (^-^) )-import Graphics.Rasterific hiding ( Path, Line, Texture, transform )-import qualified Graphics.Rasterific as R-import qualified Graphics.Rasterific.Outline as RO-import Graphics.Rasterific.Immediate-import qualified Graphics.Rasterific.Transformations as RT-import Graphics.Rasterific.PathWalker-import Graphics.Text.TrueType-import Graphics.Svg.Types-import Graphics.Rasterific.Svg.RenderContext-import Graphics.Rasterific.Svg.PathConverter-{-import Graphics.Svg.XmlParser-}--{-import Debug.Trace-}-{-import Text.Printf-}--loadFont :: FilePath -> IODraw (Maybe Font)-loadFont fontPath = do- loaded <- L.use $ loadedFonts . at fontPath- case loaded of- Just v -> return $ Just v- Nothing -> do- file <- liftIO $ loadFontFile fontPath- case file of- Left _ -> return Nothing- Right f -> do- loadedFonts . at fontPath ?= f- return $ Just f--data RenderableString px = RenderableString- { _renderableAttributes :: !DrawAttributes- , _renderableSize :: !Float- , _renderableFont :: !Font- , _renderableString :: ![(Char, CharInfo px)]- }--data CharInfo px = CharInfo- { _charX :: Maybe Number- , _charY :: Maybe Number- , _charDx :: Maybe Number- , _charDy :: Maybe Number- , _charRotate :: Maybe Float- , _charStroke :: Maybe (Float, R.Texture px, R.Join, (R.Cap, R.Cap))- }--emptyCharInfo :: CharInfo px-emptyCharInfo = CharInfo- { _charX = Nothing- , _charY = Nothing- , _charDx = Nothing- , _charDy = Nothing- , _charRotate = Nothing- , _charStroke = Nothing- }--propagateTextInfo :: TextInfo -> TextInfo -> TextInfo-propagateTextInfo parent current = TextInfo- { _textInfoX = combine _textInfoX- , _textInfoY = combine _textInfoY- , _textInfoDX = combine _textInfoDX- , _textInfoDY = combine _textInfoDY- , _textInfoRotate = combine _textInfoRotate- , _textInfoLength = _textInfoLength current- }- where- combine f = case f current of- [] -> f parent- lst -> lst--textInfoRests :: TextInfo -> TextInfo -> TextInfo- -> TextInfo-textInfoRests this parent sub = TextInfo- { _textInfoX = decideWith _textInfoX- , _textInfoY = decideWith _textInfoY- , _textInfoDX = decideWith _textInfoDX- , _textInfoDY = decideWith _textInfoDY- , _textInfoRotate = decideWith _textInfoRotate- , _textInfoLength = _textInfoLength parent- }- where- decideWith f = decide (f this) (f parent) (f sub)-- decide [] _ ssub = ssub - decide _ top _ = top--unconsTextInfo :: RenderContext -> DrawAttributes -> TextInfo- -> IODraw (CharInfo PixelRGBA8, TextInfo)-unconsTextInfo ctxt attr nfo = do- texture <- textureOf ctxt attr _strokeColor _strokeOpacity- return (charInfo texture, restText)- where- unconsInf lst = case lst of- [] -> (Nothing, [])- (x:xs) -> (Just x, xs)-- (xC, xRest) = unconsInf $ _textInfoX nfo- (yC, yRest) = unconsInf $ _textInfoY nfo- (dxC, dxRest) = unconsInf $ _textInfoDX nfo- (dyC, dyRest) = unconsInf $ _textInfoDY nfo- (rotateC, rotateRest) = unconsInf $ _textInfoRotate nfo-- restText = TextInfo- { _textInfoX = xRest- , _textInfoY = yRest- , _textInfoDX = dxRest- , _textInfoDY = dyRest- , _textInfoRotate = rotateRest- , _textInfoLength = _textInfoLength nfo- }-- sWidth =- lineariseLength ctxt attr <$> getLast (_strokeWidth attr)-- charInfo tex = CharInfo- { _charX = xC- , _charY = yC- , _charDx = dxC- , _charDy = dyC- , _charRotate = 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 +
src/Graphics/Rasterific/Svg/RenderContext.hs view
@@ -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 +