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