rasterific-svg 0.3.2.1 → 0.3.3
raw patch · 7 files changed
+480/−391 lines, 7 filesdep ~svg-treePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: svg-tree
API changes (from Hackage documentation)
Files
- changelog.md +8/−0
- exec-src/svgrender.hs +1/−0
- rasterific-svg.cabal +5/−4
- src/Graphics/Rasterific/Svg/ArcConversion.hs +121/−0
- src/Graphics/Rasterific/Svg/PathConverter.hs +250/−332
- src/Graphics/Rasterific/Svg/RasterificRender.hs +5/−21
- src/Graphics/Rasterific/Svg/RenderContext.hs +90/−34
changelog.md view
@@ -1,6 +1,14 @@ Change log ========== +v0.3.3 2017 +----------- + + * Fix: Arc rendering, some cases where mishandled + * Addition: linked patterns handling + * Fix: gradient transformation handling + * Fix: better handling of viewbox attribute. + v0.3.2.1 November 2016 ---------------------- * Fix: handling of "matrix()" transform
exec-src/svgrender.hs view
@@ -49,6 +49,7 @@ , _dpi :: !Int } + argParser :: Parser Options argParser = Options <$> ( argument str
rasterific-svg.cabal view
@@ -1,7 +1,7 @@ -- Initial svg.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: rasterific-svg -version: 0.3.2.1 +version: 0.3.3 synopsis: SVG renderer based on Rasterific. description: SVG renderer that will let you render svg-tree parsed SVG file to a JuicyPixel image or Rasterific Drawing. @@ -22,7 +22,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/rasterific-svg.git - Tag: v0.3.2.1 + Tag: v0.3.3 library hs-source-dirs: src @@ -35,6 +35,7 @@ , Graphics.Rasterific.Svg.MeshConverter , Graphics.Rasterific.Svg.RasterificRender , Graphics.Rasterific.Svg.RasterificTextRendering + , Graphics.Rasterific.Svg.ArcConversion build-depends: base >= 4.5 && < 5 , directory @@ -46,7 +47,7 @@ , containers >= 0.5 , Rasterific >= 0.7 && < 0.8 , FontyFruity >= 0.5.2.1 && < 0.6 - , svg-tree >= 0.6 && < 0.7 + , svg-tree >= 0.6.2 && < 0.7 , lens >= 4.5 && < 5 , linear >= 1.20 , vector >= 0.10 @@ -61,7 +62,7 @@ Main-Is: svgrender.hs Ghc-options: -O3 -Wall Build-Depends: base >= 4.6 - , optparse-applicative >= 0.11 && < 0.14 + , optparse-applicative >= 0.11 && < 0.15 , directory >= 1.0 , bytestring , rasterific-svg
+ src/Graphics/Rasterific/Svg/ArcConversion.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE BangPatterns #-} +-- | Conversion from SVG arcs to bezier curves +-- see https://github.com/GNOME/librsvg/blob/ebcbfae24321f22cd8c04a4951bbaf70b60d7f29/rust/src/path_builder.rs +module Graphics.Rasterific.Svg.ArcConversion( arcToSegments ) where + +import Graphics.Svg.Types +import Linear( M22, nearZero, (!*), V2( V2 ), norm, quadrance ) + +toRadian :: Floating a => a -> a +toRadian v = v / 180 * pi + +-- | Create a 2 dimensional rotation matrix given an angle +-- expressed in radians. +mkRotation :: Floating a => a -> M22 a +mkRotation angle = + V2 (V2 ca (-sa)) + (V2 sa ca) + where + ca = cos angle + sa = sin angle + +mkRota' :: Floating a => a -> M22 a +mkRota' angle = + V2 (V2 ca sa) + (V2 (-sa) ca) + where + ca = cos angle + sa = sin angle + +arcSegment :: V2 Double -> Double -> Double -> V2 Double -> Double + -> PathCommand +arcSegment c th0 th1 r angle = comm where + !comm = CurveTo OriginAbsolute + [( c + (finalRotation !* p1) + , c + (finalRotation !* p2) + , c + (finalRotation !* p3) + )] + + !finalRotation = mkRotation $ toRadian angle + + !th_half = 0.5 * (th1 - th0) + !t = (8.0 / 3.0) * + sin (th_half * 0.5) * + sin (th_half * 0.5) / + sin th_half + + !cosTh0 = cos th0 + !sinTh0 = sin th0 + !cosTh1 = cos th1 + !sinTh1 = sin th1 + + !p1 = r * V2 (cosTh0 - t * sinTh0) (sinTh0 + t * cosTh0) + !p3 = r * V2 cosTh1 sinTh1 + !p2 = p3 + r * V2 (t * sinTh1) (-t * cosTh1) + +-- See Appendix F.6 Elliptical arc implementation notes +-- http://www.w3.org/TR/SVG/implnote.html#ArcImplementationNotes */ +arc :: V2 Double -> Double -> Double -> Double -> Bool -> Bool -> V2 Double + -> [PathCommand] +arc p1 rxOrig ryOrig x_axis_rotation is_large_arc is_sweep p2 + | p1 == p2 = mempty + | nearZero (abs rxOrig) || nearZero (abs ryOrig) = [LineTo OriginAbsolute [p2]] + | kCheck == 0 = mempty + | norm kk == 0 = mempty + | k5Norm == 0 = mempty + | otherwise = segs + where + f = toRadian x_axis_rotation + + k = (p1 - p2) * 0.5 + p1_@(V2 x1_ y1_) = mkRota' f !* k + + radius@(V2 rx ry) + | gamma > 1 = V2 (abs rxOrig * sqrt gamma) (abs ryOrig * sqrt gamma) + | otherwise = V2 (abs rxOrig) (abs ryOrig) + where gamma = (x1_ * x1_) / (rxOrig * rxOrig) + (y1_ * y1_) / (ryOrig * ryOrig) + + sweepCoeff | is_sweep == is_large_arc = -1 + | otherwise = 1 + + -- Compute the center + kCheck = rx * rx * y1_ * y1_ + ry * ry * x1_ * x1_ + + kc = (sweepCoeff *) . sqrt . abs $ (rx * rx * ry * ry) / kCheck - 1.0 + + c_ = V2 (kc * rx * y1_ / ry) (-kc * ry * x1_ / rx) + c = (mkRotation f !* c_) + (p1 + p2) * 0.5 + + -- Compute start angle + kk@(V2 k1 k2) = (p1_ - c_) / radius + kkk@(V2 k3 k4) = ((-p1_) - c_) / radius + + theta1 = (if k2 < 0 then negate else id) . acos . min 1 . max (-1) $ k1 / norm kk + + -- Compute delta_theta + k5Norm = sqrt $ quadrance kk * quadrance kkk + + delta_theta + | is_sweep && v < 0.0 = v + 2 * pi + | not is_sweep && v > 0.0 = v - 2 * pi + | otherwise = v + where + vBase = acos . min 1 . max (-1) $ (k1 * k3 + k2 * k4) / k5Norm; + v | k1 * k4 - k3 * k2 < 0.0 = - vBase + | otherwise = vBase + + -- Now draw the arc + n_segs :: Int + n_segs = ceiling . abs $ delta_theta / (pi * 0.5 + 0.001) + + angleAt v = theta1 + fromIntegral v * delta_theta / fromIntegral n_segs + + segs = + [arcSegment c (angleAt i) (angleAt $ i + 1) (V2 rx ry) x_axis_rotation + | i <- [0 .. n_segs - 1]] + +arcToSegments :: RPoint -> (Coord, Coord, Coord, Bool, Bool, RPoint) + -> [PathCommand] +arcToSegments orig (radX, radY, rotateX, large, sweep, pos) = + arc orig radX radY rotateX large sweep pos +
src/Graphics/Rasterific/Svg/PathConverter.hs view
@@ -1,332 +1,250 @@-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Svg.PathConverter- ( svgPathToPrimitives- , svgPathToRasterificPath- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mconcat )-import Control.Applicative( pure, (<$>) )-#endif--import Data.List( mapAccumL )-import Graphics.Rasterific.Linear( (^+^)- , (^-^)- , (^*)- , norm- , nearZero- , zero )-import qualified Graphics.Rasterific as R-import Linear( dot, (!*!), (!*), V2( V2 ), scaled )-import qualified Linear as L-import Graphics.Svg.Types-import Graphics.Rasterific.Svg.RenderContext--singularize :: [PathCommand] -> [PathCommand]-singularize = concatMap go- where- go (MoveTo _ []) = []- go (MoveTo o (x: xs)) = MoveTo o [x] : go (LineTo o xs)- go (LineTo o lst) = LineTo o . pure <$> lst- go (HorizontalTo o lst) = HorizontalTo o . pure <$> lst- go (VerticalTo o lst) = VerticalTo o . pure <$> lst- go (CurveTo o lst) = CurveTo o . pure <$> lst- go (SmoothCurveTo o lst) = SmoothCurveTo o . pure <$> lst- go (QuadraticBezier o lst) = QuadraticBezier o . pure <$> lst- go (SmoothQuadraticBezierCurveTo o lst) =- SmoothQuadraticBezierCurveTo o . pure <$> lst- go (EllipticalArc o lst) = EllipticalArc o . pure <$> lst- go EndPath = [EndPath]--toR :: RPoint -> R.Point-{-# INLINE toR #-}-toR (L.V2 x y) = realToFrac <$> R.V2 x y--fromR :: R.Point -> RPoint-{-# INLINE fromR #-}-fromR (R.V2 x y) = realToFrac <$> L.V2 x y--svgPathToPrimitives :: Bool -> [PathCommand] -> [R.Primitive]-svgPathToPrimitives shouldClose lst- | shouldClose && not (nearZero $ norm (lastPoint ^-^ firstPoint)) =- concat $ prims ++ [R.line lastPoint firstPoint]- | otherwise = concat prims- where- ((lastPoint, _, firstPoint), prims) =- mapAccumL go (zero, zero, zero) $ singularize lst-- go (latest, p, first) EndPath =- ((first, p, first), R.line latest first)-- go o (HorizontalTo _ []) = (o, [])- go o (VerticalTo _ []) = (o, [])- go o (MoveTo _ []) = (o, [])- go o (LineTo _ []) = (o, [])- go o (CurveTo _ []) = (o, [])- go o (SmoothCurveTo _ []) = (o, [])- go o (QuadraticBezier _ []) = (o, [])- go o (SmoothQuadraticBezierCurveTo _ []) = (o, [])- go o (EllipticalArc _ []) = (o, [])-- go (_, _, _) (MoveTo OriginAbsolute (p:_)) = ((p', p', p'), [])- where p' = toR p- go (o, _, _) (MoveTo OriginRelative (p:_)) =- ((pp, pp, pp), []) where pp = o ^+^ toR p-- go (o@(R.V2 _ y), _, fp) (HorizontalTo OriginAbsolute (c:_)) =- ((p, p, fp), R.line o p) where p = R.V2 (realToFrac c) y- go (o@(R.V2 x y), _, fp) (HorizontalTo OriginRelative (c:_)) =- ((p, p, fp), R.line o p) where p = R.V2 (x + realToFrac c) y-- go (o@(R.V2 x _), _, fp) (VerticalTo OriginAbsolute (c:_)) =- ((p, p, fp), R.line o p) where p = R.V2 x (realToFrac c)- go (o@(R.V2 x y), _, fp) (VerticalTo OriginRelative (c:_)) =- ((p, p, fp), R.line o p) where p = R.V2 x (realToFrac c + y)-- go (o, _, fp) (LineTo OriginRelative (c:_)) =- ((p, p, fp), R.line o p) where p = o ^+^ toR c-- go (o, _, fp) (LineTo OriginAbsolute (p:_)) =- ((p', p', fp), R.line o $ toR p)- where p' = toR p-- go (o, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) =- ((e', c2', fp),- [R.CubicBezierPrim $ R.CubicBezier o (toR c1) c2' e'])- where e' = toR e- c2' = toR c2-- go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) =- ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e'])- where c1' = o ^+^ toR c1- c2' = o ^+^ toR c2- e' = o ^+^ toR e-- go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) =- ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e'])- where c1' = o ^* 2 ^-^ control- c2' = toR c2- e' = toR e-- go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) =- ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e'])- where c1' = o ^* 2 ^-^ control- c2' = o ^+^ toR c2- e' = o ^+^ toR e-- go (o, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) =- ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])- where e' = toR e- c1' = toR c1-- go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) =- ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])- where c1' = o ^+^ toR c1- e' = o ^+^ toR e-- go (o, control, fp)- (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) =- ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])- where c1' = o ^* 2 ^-^ control- e' = toR e-- go (o, control, fp)- (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) =- ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e'])- where c1' = o ^* 2 ^-^ control- e' = o ^+^ toR e-- go acc@(o, _, _) (EllipticalArc OriginAbsolute (e:_)) =- (accFinal, mconcat outList)- where- (accFinal, outList) = mapAccumL go acc $ arcToSegments (fromR o) e-- go back@(o,_,_) (EllipticalArc OriginRelative ((rx, ry, rot, f1, f2, p): _)) =- go back $ EllipticalArc OriginAbsolute [new]- where p' = p L.^+^ (fromR o)- new = (rx, ry, rot, f1, f2, p')----- | Conversion function between svg path to the rasterific one.-svgPathToRasterificPath :: Bool -> [PathCommand] -> R.Path-svgPathToRasterificPath shouldClose lst =- R.Path firstPoint shouldClose $ concat commands- where- lineTo p = [R.PathLineTo p]- cubicTo e1 e2 e3 = [R.PathCubicBezierCurveTo e1 e2 e3]- quadTo e1 e2 = [R.PathQuadraticBezierCurveTo e1 e2]-- ((_, _, firstPoint), commands) =- mapAccumL go (zero, zero, zero) $ singularize lst- - go (_, p, first) EndPath =- ((first, p, first), [])-- go o (HorizontalTo _ []) = (o, [])- go o (VerticalTo _ []) = (o, [])- go o (MoveTo _ []) = (o, [])- go o (LineTo _ []) = (o, [])- go o (CurveTo _ []) = (o, [])- go o (SmoothCurveTo _ []) = (o, [])- go o (QuadraticBezier _ []) = (o, [])- go o (SmoothQuadraticBezierCurveTo _ []) = (o, [])- go o (EllipticalArc _ []) = (o, [])-- go (_, _, _) (MoveTo OriginAbsolute (p:_)) =- ((pp, pp, pp), []) where pp = toR p- go (o, _, _) (MoveTo OriginRelative (p:_)) =- ((pp, pp, pp), []) where pp = o ^+^ toR p-- go (R.V2 _ y, _, fp) (HorizontalTo OriginAbsolute (c:_)) =- ((p, p, fp), lineTo p) where p = R.V2 (realToFrac c) y- go (R.V2 x y, _, fp) (HorizontalTo OriginRelative (c:_)) =- ((p, p, fp), lineTo p) where p = R.V2 (x + realToFrac c) y-- go (R.V2 x _, _, fp) (VerticalTo OriginAbsolute (c:_)) =- ((p, p, fp), lineTo p) where p = R.V2 x (realToFrac c)- go (R.V2 x y, _, fp) (VerticalTo OriginRelative (c:_)) =- ((p, p, fp), lineTo p) where p = R.V2 x (realToFrac c + y)-- go (o, _, fp) (LineTo OriginRelative (c:_)) =- ((p, p, fp), lineTo p) where p = o ^+^ toR c-- go (_, _, fp) (LineTo OriginAbsolute (p:_)) =- ((p', p', fp), lineTo p')- where p' = toR p-- go (_, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) =- ((e', c2', fp), cubicTo c1' c2' e')- where e' = toR e- c2' = toR c2- c1' = toR c1-- go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) =- ((e', c2', fp), cubicTo c1' c2' e')- where c1' = o ^+^ toR c1- c2' = o ^+^ toR c2- e' = o ^+^ toR e-- go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) =- ((e', c2', fp), cubicTo c1' c2' e')- where c1' = o ^* 2 ^-^ control- c2' = toR c2- e' = toR e-- go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) =- ((e', c2', fp), cubicTo c1' c2' e')- where c1' = o ^* 2 ^-^ control- c2' = o ^+^ toR c2- e' = o ^+^ toR e-- go (_, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) =- ((e', c1', fp), quadTo c1' e')- where e' = toR e- c1' = toR c1-- go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) =- ((e', c1', fp), quadTo c1' e')- where c1' = o ^+^ toR c1- e' = o ^+^ toR e-- go (o, control, fp)- (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) =- ((e', c1', fp), quadTo c1' e')- where c1' = o ^* 2 ^-^ control- e' = toR e-- go (o, control, fp)- (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) =- ((e', c1', fp), quadTo c1' e')- where c1' = o ^* 2 ^-^ control- e' = o ^+^ toR e-- go back@(o, _, _) (EllipticalArc OriginAbsolute (com:_)) = (nextState, mconcat pathCommands)- where- (nextState, pathCommands) =- mapAccumL go back $ arcToSegments (fromR o) com- go back@(o, _, _) (EllipticalArc OriginRelative ((rx, ry, rot, f1, f2, p):_)) =- go back $ EllipticalArc OriginAbsolute [new]- where p' = p L.^+^ (fromR o)- new = (rx, ry, rot, f1, f2, p')----- | Create a 2 dimensional rotation matrix given an angle--- expressed in radians.-mkRotation :: Floating a => a -> L.M22 a-mkRotation angle =- L.V2 (L.V2 ca (-sa))- (L.V2 sa ca)- where- ca = cos angle- sa = sin angle--mkRota' :: Floating a => a -> L.M22 a-mkRota' angle =- L.V2 (L.V2 ca sa)- (L.V2 (-sa) ca)- where- ca = cos angle- sa = sin angle--arcToSegments :: RPoint -> (Coord, Coord, Coord, Bool, Bool, RPoint)- -> [PathCommand]-arcToSegments orig (radX, radY, rotateX, large, sweep, pos) =- [segmentToBezier transBackward (V2 xc yc) th2 th3- | (th2, th3) <- zip angleSampling $ tail angleSampling]- where- angleSampling =- [th0 + i * th_arc / fromIntegral segmentCount | i <- fromIntegral <$> [0 .. segmentCount]]- theta = toRadian rotateX- rotation = mkRota' theta-- V2 px py =- (mkRota' theta !* (orig L.^-^ pos)) ^* 0.5-- (rx, ry)- | tmp > 1 = (rx' * sqtmp, ry' * sqtmp)- | otherwise = (rx', ry')- where- sqtmp = sqrt tmp- tmp = (px * px) / (rx' * rx') + (py * py) / (ry' * ry')- rx' = abs radX- ry' = abs radY-- transBackward = mkRotation theta !*! scaled (V2 rx ry)- trans = scaled (V2 (1 / rx) (1 / ry)) !*! rotation-- orig'@(V2 x0 y0) = trans !* orig- pos'@(V2 x1 y1) = trans !* pos- delta = pos' L.^-^ orig'- d = delta `dot` delta-- sfactor | sweep == large = - factor- | otherwise = factor- where- factor = sqrt . max 0 $ 1 / d - 0.25-- xc = 0.5 * (x0 + x1) - sfactor * (y1-y0)- yc = 0.5 * (y0 + y1) + sfactor * (x1-x0)-- th0 = atan2 (y0 - yc) (x0 - xc)- th1 = atan2 (y1 - yc) (x1 - xc)-- th_arc | tmp < 0 && sweep = tmp + 2 * pi- | tmp > 0 && not sweep = tmp - 2 * pi- | otherwise = tmp- where- tmp = th1 - th0-- segmentCount :: Int- segmentCount = ceiling . abs $ th_arc / (pi / 2 + 0.001)--segmentToBezier :: L.M22 Coord -> RPoint -> Coord -> Coord -> PathCommand-segmentToBezier trans (V2 cx cy) th0 th1 =- CurveTo OriginAbsolute [(trans !* p1, trans !* p2, trans !* p3)]- where- th_half = 0.5 * (th1 - th0)- t = (8 / 3) * sin (th_half * 0.5) * sin (th_half * 0.5) / sin th_half- - p1 = V2 (cx + cos th0 - t * sin th0) (cy + sin th0 + t * cos th0)- p3@(V2 x3 y3) = V2 (cx + cos th1) (cy + sin th1)- p2 = V2 (x3 + t * sin th1) (y3 - t * cos th1)-+{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Svg.PathConverter + ( svgPathToPrimitives + , svgPathToRasterificPath + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mconcat ) +import Control.Applicative( pure, (<$>) ) +#endif + +import Data.List( mapAccumL ) +import Graphics.Rasterific.Linear( (^+^) + , (^-^) + , (^*) + , norm + , nearZero + , zero ) +import qualified Graphics.Rasterific as R +import qualified Linear as L +import Graphics.Svg.Types +import Graphics.Rasterific.Svg.ArcConversion + +singularize :: [PathCommand] -> [PathCommand] +singularize = concatMap go + where + go (MoveTo _ []) = [] + go (MoveTo o (x: xs)) = MoveTo o [x] : go (LineTo o xs) + go (LineTo o lst) = LineTo o . pure <$> lst + go (HorizontalTo o lst) = HorizontalTo o . pure <$> lst + go (VerticalTo o lst) = VerticalTo o . pure <$> lst + go (CurveTo o lst) = CurveTo o . pure <$> lst + go (SmoothCurveTo o lst) = SmoothCurveTo o . pure <$> lst + go (QuadraticBezier o lst) = QuadraticBezier o . pure <$> lst + go (SmoothQuadraticBezierCurveTo o lst) = + SmoothQuadraticBezierCurveTo o . pure <$> lst + go (EllipticalArc o lst) = EllipticalArc o . pure <$> lst + go EndPath = [EndPath] + +toR :: RPoint -> R.Point +{-# INLINE toR #-} +toR (L.V2 x y) = realToFrac <$> R.V2 x y + +fromR :: R.Point -> RPoint +{-# INLINE fromR #-} +fromR (R.V2 x y) = realToFrac <$> L.V2 x y + +svgPathToPrimitives :: Bool -> [PathCommand] -> [R.Primitive] +svgPathToPrimitives shouldClose lst + | shouldClose && not (nearZero $ norm (lastPoint ^-^ firstPoint)) = + concat $ prims ++ [R.line lastPoint firstPoint] + | otherwise = concat prims + where + ((lastPoint, _, firstPoint), prims) = + mapAccumL go (zero, zero, zero) $ singularize lst + + go (latest, p, first) EndPath = + ((first, p, first), R.line latest first) + + go o (HorizontalTo _ []) = (o, []) + go o (VerticalTo _ []) = (o, []) + go o (MoveTo _ []) = (o, []) + go o (LineTo _ []) = (o, []) + go o (CurveTo _ []) = (o, []) + go o (SmoothCurveTo _ []) = (o, []) + go o (QuadraticBezier _ []) = (o, []) + go o (SmoothQuadraticBezierCurveTo _ []) = (o, []) + go o (EllipticalArc _ []) = (o, []) + + go (_, _, _) (MoveTo OriginAbsolute (p:_)) = ((p', p', p'), []) + where p' = toR p + go (o, _, _) (MoveTo OriginRelative (p:_)) = + ((pp, pp, pp), []) where pp = o ^+^ toR p + + go (o@(R.V2 _ y), _, fp) (HorizontalTo OriginAbsolute (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 (realToFrac c) y + go (o@(R.V2 x y), _, fp) (HorizontalTo OriginRelative (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 (x + realToFrac c) y + + go (o@(R.V2 x _), _, fp) (VerticalTo OriginAbsolute (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 x (realToFrac c) + go (o@(R.V2 x y), _, fp) (VerticalTo OriginRelative (c:_)) = + ((p, p, fp), R.line o p) where p = R.V2 x (realToFrac c + y) + + go (o, _, fp) (LineTo OriginRelative (c:_)) = + ((p, p, fp), R.line o p) where p = o ^+^ toR c + + go (o, _, fp) (LineTo OriginAbsolute (p:_)) = + ((p', p', fp), R.line o $ toR p) + where p' = toR p + + go (o, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) = + ((e', c2', fp), + [R.CubicBezierPrim $ R.CubicBezier o (toR c1) c2' e']) + where e' = toR e + c2' = toR c2 + + go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) = + ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) + where c1' = o ^+^ toR c1 + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) = + ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) + where c1' = o ^* 2 ^-^ control + c2' = toR c2 + e' = toR e + + go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) = + ((e', c2', fp), [R.CubicBezierPrim $ R.CubicBezier o c1' c2' e']) + where c1' = o ^* 2 ^-^ control + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (o, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where e' = toR e + c1' = toR c1 + + go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where c1' = o ^+^ toR c1 + e' = o ^+^ toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where c1' = o ^* 2 ^-^ control + e' = toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) = + ((e', c1', fp), [R.BezierPrim $ R.Bezier o c1' e']) + where c1' = o ^* 2 ^-^ control + e' = o ^+^ toR e + + go acc@(o, _, _) (EllipticalArc OriginAbsolute (e:_)) = + (accFinal, mconcat outList) + where + (accFinal, outList) = mapAccumL go acc $ arcToSegments (fromR o) e + + go back@(o,_,_) (EllipticalArc OriginRelative ((rx, ry, rot, f1, f2, p): _)) = + go back $ EllipticalArc OriginAbsolute [new] + where p' = p L.^+^ (fromR o) + new = (rx, ry, rot, f1, f2, p') + + +-- | Conversion function between svg path to the rasterific one. +svgPathToRasterificPath :: Bool -> [PathCommand] -> R.Path +svgPathToRasterificPath shouldClose lst = + R.Path firstPoint shouldClose $ concat commands + where + lineTo p = [R.PathLineTo p] + cubicTo e1 e2 e3 = [R.PathCubicBezierCurveTo e1 e2 e3] + quadTo e1 e2 = [R.PathQuadraticBezierCurveTo e1 e2] + + ((_, _, firstPoint), commands) = + mapAccumL go (zero, zero, zero) $ singularize lst + + go (_, p, first) EndPath = + ((first, p, first), []) + + go o (HorizontalTo _ []) = (o, []) + go o (VerticalTo _ []) = (o, []) + go o (MoveTo _ []) = (o, []) + go o (LineTo _ []) = (o, []) + go o (CurveTo _ []) = (o, []) + go o (SmoothCurveTo _ []) = (o, []) + go o (QuadraticBezier _ []) = (o, []) + go o (SmoothQuadraticBezierCurveTo _ []) = (o, []) + go o (EllipticalArc _ []) = (o, []) + + go (_, _, _) (MoveTo OriginAbsolute (p:_)) = + ((pp, pp, pp), []) where pp = toR p + go (o, _, _) (MoveTo OriginRelative (p:_)) = + ((pp, pp, pp), []) where pp = o ^+^ toR p + + go (R.V2 _ y, _, fp) (HorizontalTo OriginAbsolute (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 (realToFrac c) y + go (R.V2 x y, _, fp) (HorizontalTo OriginRelative (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 (x + realToFrac c) y + + go (R.V2 x _, _, fp) (VerticalTo OriginAbsolute (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 x (realToFrac c) + go (R.V2 x y, _, fp) (VerticalTo OriginRelative (c:_)) = + ((p, p, fp), lineTo p) where p = R.V2 x (realToFrac c + y) + + go (o, _, fp) (LineTo OriginRelative (c:_)) = + ((p, p, fp), lineTo p) where p = o ^+^ toR c + + go (_, _, fp) (LineTo OriginAbsolute (p:_)) = + ((p', p', fp), lineTo p') + where p' = toR p + + go (_, _, fp) (CurveTo OriginAbsolute ((c1, c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where e' = toR e + c2' = toR c2 + c1' = toR c1 + + go (o, _, fp) (CurveTo OriginRelative ((c1, c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where c1' = o ^+^ toR c1 + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (o, control, fp) (SmoothCurveTo OriginAbsolute ((c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where c1' = o ^* 2 ^-^ control + c2' = toR c2 + e' = toR e + + go (o, control, fp) (SmoothCurveTo OriginRelative ((c2, e):_)) = + ((e', c2', fp), cubicTo c1' c2' e') + where c1' = o ^* 2 ^-^ control + c2' = o ^+^ toR c2 + e' = o ^+^ toR e + + go (_, _, fp) (QuadraticBezier OriginAbsolute ((c1, e):_)) = + ((e', c1', fp), quadTo c1' e') + where e' = toR e + c1' = toR c1 + + go (o, _, fp) (QuadraticBezier OriginRelative ((c1, e):_)) = + ((e', c1', fp), quadTo c1' e') + where c1' = o ^+^ toR c1 + e' = o ^+^ toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginAbsolute (e:_)) = + ((e', c1', fp), quadTo c1' e') + where c1' = o ^* 2 ^-^ control + e' = toR e + + go (o, control, fp) + (SmoothQuadraticBezierCurveTo OriginRelative (e:_)) = + ((e', c1', fp), quadTo c1' e') + where c1' = o ^* 2 ^-^ control + e' = o ^+^ toR e + + go back@(o, _, _) (EllipticalArc OriginAbsolute (com:_)) = (nextState, mconcat pathCommands) + where + (nextState, pathCommands) = + mapAccumL go back $ arcToSegments (fromR o) com + go back@(o, _, _) (EllipticalArc OriginRelative ((rx, ry, rot, f1, f2, p):_)) = + go back $ EllipticalArc OriginAbsolute [new] + where p' = p L.^+^ (fromR o) + new = (rx, ry, rot, f1, f2, p') +
src/Graphics/Rasterific/Svg/RasterificRender.hs view
@@ -43,7 +43,7 @@ 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.Linear( V2( V2 ), (^+^), (^*), zero ) import Graphics.Rasterific.Outline import qualified Graphics.Rasterific.Transformations as RT import Graphics.Text.TrueType @@ -129,9 +129,9 @@ 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 + sizeFitter (p, V2 xEnd yEnd) actualSize = + sizeFitter (zero, V2 xEnd yEnd) actualSize . + R.withTransformation (RT.translate (negate p)) renderAtSize (w, h) = do let stateDraw = mapM (renderSvg emptyContext) $ _elements doc @@ -146,22 +146,6 @@ 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 = @@ -450,7 +434,7 @@ (Just (xs, ys, xe, ye)) -> let boxOrigin = V2 (realToFrac xs) (realToFrac ys) boxEnd = V2 (realToFrac xe) (realToFrac ye) - V2 bw bh = abs $ boxEnd ^-^ boxOrigin + V2 bw bh = abs boxEnd xScaleFactor = case w of Just wpx -> wpx / bw Nothing -> 1.0
src/Graphics/Rasterific/Svg/RenderContext.hs view
@@ -17,10 +17,10 @@ , linearisePoint , lineariseLength , prepareTexture - , documentOfPattern , fillAlphaCombine , fillMethodOfSvg , emTransform + , toTransformationMatrix ) where @@ -29,32 +29,39 @@ import Data.Monoid( Monoid( .. ) ) #endif +import Control.Lens( (&), (.~) ) 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 Data.Monoid( (<>), Last( .. ) ) import Control.Lens( Lens', lens ) import Graphics.Rasterific.Linear( (^-^) ) import qualified Graphics.Rasterific as R +import qualified Graphics.Rasterific.Transformations as RT import qualified Graphics.Rasterific.Texture as RT import Graphics.Text.TrueType import Graphics.Svg.Types import Graphics.Rasterific.Svg.MeshConverter +import Debug.Trace +import Text.Printf + toRadian :: Floating a => a -> a toRadian v = v / 180 * pi +type Definitions = M.Map String Element + 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 + { _initialViewBox :: !(R.Point, R.Point) + , _renderViewBox :: !(R.Point, R.Point) + , _renderDpi :: !Int + , _contextDefinitions :: !Definitions + , _fontCache :: !FontCache + , _subRender :: !(Document -> IODraw (R.Drawing PixelRGBA8 ())) + , _basePath :: !FilePath } data LoadedElements = LoadedElements @@ -191,12 +198,19 @@ let bounds = F.foldMap R.planeBounds prims strip (x, y) = (stripUnits ctxt x, stripUnits ctxt y) mesh' = mapMeshBaseCoordiantes strip mesh + gradTransform = toTransformer $ _meshGradientTransform mesh interp = case _meshGradientType mesh of GradientBilinear -> R.PatchBilinear GradientBicubic -> R.PatchBicubic in - RT.meshPatchTexture interp $ convertGradientMesh (globalBounds ctxt) bounds mesh' + RT.meshPatchTexture interp $ + R.transform gradTransform $ convertGradientMesh (globalBounds ctxt) bounds mesh' +toTransformer :: [Transformation] -> R.Point -> R.Point +toTransformer [] = id +toTransformer lst = RT.applyTransformation combined where + combined = F.foldMap toTransformationMatrix lst + prepareLinearGradientTexture :: RenderContext -> DrawAttributes -> LinearGradient -> Float -> [R.Primitive] @@ -207,13 +221,14 @@ CoordUserSpace -> linearisePoint ctxt attr CoordBoundingBox -> boundbingBoxLinearise ctxt attr bounds toA = maybe 1 id + gradTransform = toTransformer $ _linearGradientTransform grad 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 + RT.linearGradientTexture gradient (gradTransform startPoint) (gradTransform stopPoint) prepareRadialGradientTexture :: RenderContext -> DrawAttributes @@ -228,10 +243,11 @@ (boundbingBoxLinearise ctxt attr bounds, boundingBoxLength ctxt attr bounds) toA = maybe 1 id + gradTransform = toTransformer $ _radialGradientTransform grad gradient = [(offset, fillAlphaCombine (opa * toA opa2) color) | GradientStop offset color _ opa2 <- _radialGradientStops grad] - center = lineariser $ _radialGradientCenter grad + center = gradTransform . lineariser $ _radialGradientCenter grad radius = lengthLinearise $ _radialGradientRadius grad in case (_radialGradientFocusX grad, @@ -261,18 +277,55 @@ a' = fromIntegral a / 255.0 alpha = floor . max 0 . min 255 $ opacity * a' * 255 -documentOfPattern :: Pattern -> String -> Document -documentOfPattern pat loc = Document +scalesOfTransformation :: RT.Transformation -> (Float, Float) +scalesOfTransformation (RT.Transformation a c _e + b d _f) = (widthScale, heightScale) + where + widthScale = sqrt $ a * a + c * c + heightScale = sqrt $ b * b + d * d + + +documentOfPattern :: Definitions -> RT.Transformation -> Int -> Int -> Pattern -> String + -> Document +documentOfPattern defs trans w h pat loc = Document { _viewBox = _patternViewBox pat - , _width = return $ _patternWidth pat - , _height = return $ _patternHeight pat - , _elements = _patternElements pat - , _definitions = M.empty + , _width = return . Num $ fromIntegral tileWidth + , _height = return . Num $ fromIntegral tileHeight + , _elements = _patternElements pat -- [GroupTree asTransformedGroup] + , _definitions = defs , _styleRules = [] , _description = "" , _documentLocation = loc } + where + (widthScale, heightScale) = scalesOfTransformation trans + tileWidth, tileHeight :: Int + tileWidth = floor $ widthScale * fromIntegral w + tileHeight = floor $ heightScale * fromIntegral h + _asGroup = defaultSvg { _groupChildren = _patternElements pat } + _transfo = Scale + (realToFrac widthScale) + (Just . realToFrac $ heightScale) + _asTransformedGroup = _asGroup & drawAttr . transform .~ Just [_transfo] + +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 $ R.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) $ R.V2 (rf cx) (rf cy) + go (SkewX v) = RT.skewX . toRadian $ rf v + go (SkewY v) = RT.skewY . toRadian $ rf v + go TransformUnknown = mempty + + prepareTexture :: RenderContext -> DrawAttributes -> Texture -> Float -> [R.Primitive] @@ -281,26 +334,29 @@ 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) = + maybe (return Nothing) (prepare mempty) $ M.lookup ref (_contextDefinitions ctxt) where + prepare rootTrans e = case e of + ElementGeometry _ -> return Nothing + ElementMarker _ -> return Nothing + ElementMask _ -> return Nothing + ElementClipPath _ -> return Nothing + 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) + ElementLinearGradient grad -> + return . Just $ prepareLinearGradientTexture ctxt attr grad opacity prims + ElementRadialGradient grad -> + return . Just $ prepareRadialGradientTexture ctxt attr grad opacity prims + ElementPattern pat@Pattern { _patternHref = "" } -> do + let doc = documentOfPattern (_contextDefinitions ctxt) rootTrans w h 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 + ElementPattern pat -> do + let _inverser = maybe id RT.transformTexture . RT.inverseTransformation + _applyTransformation = RT.transformTexture + trans = maybe mempty (F.foldMap toTransformationMatrix) $ _patternTransform pat + nextRef = _patternHref pat + maybe (return Nothing) (prepare (rootTrans <> trans)) $ M.lookup nextRef (_contextDefinitions ctxt)