juicy-gcode-0.2.1.0: src/Render.hs
module Render (
renderDoc
) where
import Data.Maybe ( fromMaybe )
import qualified Graphics.Svg as SVG
import qualified Graphics.Svg.CssTypes as CSS
import qualified Linear
import Graphics.Path
import Graphics.Point
import Graphics.Transformation
import Approx.BiArc
import SvgArcSegment
import SVGExt
import qualified Graphics.CubicBezier as B
mapTuple :: (a -> b) -> (a, a) -> (b, b)
mapTuple f (a1, a2) = (f a1, f a2)
fromSvgPoint :: Int -> SVG.Point -> Point
fromSvgPoint dpi (x,y) = (fromSvgNumber dpi x, fromSvgNumber dpi y)
fromRPoint :: SVG.RPoint -> Point
fromRPoint (Linear.V2 x y) = (x, y)
-- TODO: em, percentage
fromSvgNumber :: Int -> SVG.Number -> Double
fromSvgNumber dpi num = fromNumber' (CSS.toUserUnit dpi num)
where
fromNumber' (SVG.Num n) = n
fromNumber' _ = error "TODO: unhandled em or percentage"
-- current point + control point -> mirrored control point
mirrorControlPoint :: Point -> Point -> Point
mirrorControlPoint (cx, cy) (cpx, cpy) = (cx + cx - cpx, cy + cy - cpy)
-- convert a quadratic bezier to a cubic one
bezierQ2C :: Point -> Point -> Point -> PathCommand
bezierQ2C (qp0x, qp0y) (qp1x, qp1y) (qp2x, qp2y)
= BezierTo (qp0x + 2.0 / 3.0 * (qp1x - qp0x), qp0y + 2.0 / 3.0 * (qp1y - qp0y))
(qp2x + 2.0 / 3.0 * (qp1x - qp2x), qp2y + 2.0 / 3.0 * (qp1y - qp2y))
(qp2x, qp2y)
toAbsolute :: (Double, Double) -> SVG.Origin -> (Double, Double) -> (Double, Double)
toAbsolute _ SVG.OriginAbsolute p = p
toAbsolute (cx,cy) SVG.OriginRelative (dx,dy) = (cx+dx, cy+dy)
-- Apply SVG transformations to a TransformationMatrix
applyTransformations :: TransformationMatrix -> Maybe [SVG.Transformation] -> TransformationMatrix
applyTransformations m Nothing = m
applyTransformations m (Just ts) = foldl applyTransformation m ts
radiansPerDegree :: Double
radiansPerDegree = pi / 180.0
-- https://developer.mozilla.org/en/docs/Web/SVG/Attribute/transform
applyTransformation :: TransformationMatrix -> SVG.Transformation -> TransformationMatrix
applyTransformation m (SVG.TransformMatrix a b c d e f) = multiply m (fromElements [a,b,c,d,e,f])
applyTransformation m (SVG.Translate x y) = multiply m (fromElements [1,0,0,1,x,y])
applyTransformation m (SVG.Scale sx mbSy) = multiply m (fromElements [sx,0,0,Data.Maybe.fromMaybe sx mbSy,0,0])
applyTransformation m (SVG.Rotate a Nothing)
= multiply m (fromElements [cos r, sin r, -sin r, cos r , 0, 0])
where
r = a * radiansPerDegree
applyTransformation m (SVG.Rotate a (Just (x, y))) = applyTransformations m (Just [SVG.Translate x y , SVG.Rotate a Nothing , SVG.Translate (-x) (-y)])
applyTransformation m (SVG.SkewX a) = multiply m (fromElements [1,0,tan(a*radiansPerDegree),1,0,0])
applyTransformation m (SVG.SkewY a) = multiply m (fromElements [1,tan(a*radiansPerDegree),0,1,0,0])
applyTransformation m SVG.TransformUnknown = m
docTransform :: Int -> SVG.Document -> TransformationMatrix
docTransform dpi doc = multiply mirrorTransform (viewBoxTransform $ SVG._viewBox doc)
where
viewBoxTransform (Just (vbx,vby,vbw,vbh))
= multiply (scaleTransform (w/vbw) (h/vbh)) (translateTransform (-vbx) (-vby))
viewBoxTransform Nothing
= identityTransform
mirrorTransform = mirrorYTransform w h
(w, h) = documentSize dpi doc
renderDoc :: Bool -> Int -> Double -> SVG.Document -> [PathCommand]
renderDoc generateBezier dpi resolution doc
= stage2 $ renderTrees (docTransform dpi doc) (SVG._elements doc)
where
pxresolution = fromIntegral dpi / 2.45 / 10 * resolution
-- TODO: make it tail recursive
stage2 :: [PathCommand] -> [PathCommand]
stage2 dops = approximate dops (Linear.V2 0 0)
where
approximate [] _ = []
approximate (MoveTo p:ds) _ = MoveTo p : approximate ds (fromPoint p)
approximate (LineTo p:ds) _ = LineTo p : approximate ds (fromPoint p)
approximate (ArcTo p1 p2 d:ds) _ = ArcTo p1 p2 d : approximate ds (fromPoint p2)
approximate (BezierTo c1 c2 p2:ds) cp
| generateBezier
= BezierTo c1 c2 p2 : approximate ds (fromPoint p2)
| otherwise
= bezier2biarcs
(B.CubicBezier cp (fromPoint c1) (fromPoint c2) (fromPoint p2)) pxresolution
++ approximate ds (fromPoint p2)
renderPathCommands :: Point -> Point -> Maybe Point -> [SVG.PathCommand] -> [PathCommand]
renderPathCommands _ currentp _ (SVG.MoveTo origin (p:ps):ds)
= MoveTo ap : renderPathCommands ap ap Nothing (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
cont [] = ds
cont ps' = SVG.LineTo origin ps' : ds
renderPathCommands firstp currentp _ (SVG.LineTo origin (p:ps):ds)
= LineTo ap : renderPathCommands firstp ap Nothing (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
cont [] = ds
cont ps' = SVG.LineTo origin ps' : ds
renderPathCommands firstp (_, cy) _ (SVG.HorizontalTo SVG.OriginAbsolute (px:pxs):ds)
= LineTo ap : renderPathCommands firstp ap Nothing (cont pxs)
where
ap = (px,cy)
cont [] = ds
cont pxs' = SVG.HorizontalTo SVG.OriginAbsolute pxs' : ds
renderPathCommands firstp (cx, cy) _ (SVG.HorizontalTo SVG.OriginRelative (dx:dxs):ds)
= LineTo ap : renderPathCommands firstp ap Nothing (cont dxs)
where
ap = (cx+dx,cy)
cont [] = ds
cont dxs' = SVG.HorizontalTo SVG.OriginRelative dxs' : ds
renderPathCommands firstp (cx, _) _ (SVG.VerticalTo SVG.OriginAbsolute (py:pys):ds)
= LineTo ap : renderPathCommands firstp ap Nothing (cont pys)
where
ap = (cx,py)
cont [] = ds
cont pys' = SVG.VerticalTo SVG.OriginAbsolute pys' : ds
renderPathCommands firstp (cx, cy) _ (SVG.VerticalTo SVG.OriginRelative (dy:dys):ds)
= LineTo ap : renderPathCommands firstp ap Nothing (cont dys)
where
ap = (cx,cy+dy)
cont [] = ds
cont dys' = SVG.VerticalTo SVG.OriginRelative dys' : ds
renderPathCommands firstp currentp _ (SVG.CurveTo origin ((c1,c2,p):ps):ds)
= BezierTo ac1 ac2 ap : renderPathCommands firstp ap (Just ac2) (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
ac1 = toAbsolute currentp origin (fromRPoint c1)
ac2 = toAbsolute currentp origin (fromRPoint c2)
cont [] = ds
cont ps' = SVG.CurveTo origin ps' : ds
renderPathCommands firstp currentp mbControlp (SVG.SmoothCurveTo origin ((c2,p):ps):ds)
= BezierTo ac1 ac2 ap : renderPathCommands firstp ap (Just ac2) (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
ac1 = maybe ac2 (mirrorControlPoint currentp) mbControlp
ac2 = toAbsolute currentp origin (fromRPoint c2)
cont [] = ds
cont ps' = SVG.SmoothCurveTo origin ps' : ds
renderPathCommands firstp currentp _ (SVG.QuadraticBezier origin ((c1,p):ps):ds)
= cbezier : renderPathCommands firstp ap (Just ac1) (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
ac1 = toAbsolute currentp origin (fromRPoint c1)
cbezier = bezierQ2C currentp ac1 ap
cont [] = ds
cont ps' = SVG.QuadraticBezier origin ps' : ds
renderPathCommands firstp currentp mbControlp (SVG.SmoothQuadraticBezierCurveTo origin (p:ps):ds)
= cbezier : renderPathCommands firstp ap (Just ac1) (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
ac1 = maybe currentp (mirrorControlPoint currentp) mbControlp
cbezier = bezierQ2C currentp ac1 ap
cont [] = ds
cont ps' = SVG.SmoothQuadraticBezierCurveTo origin ps' : ds
renderPathCommands firstp currentp _ (SVG.EllipticalArc origin ((rx,ry,rot,largeArcFlag,sweepFlag,p):ps):ds)
= convertSvgArc currentp rx ry rot largeArcFlag sweepFlag ap ++ renderPathCommands firstp ap Nothing (cont ps)
where
ap = toAbsolute currentp origin (fromRPoint p)
cont [] = ds
cont ps' = SVG.EllipticalArc origin ps' : ds
renderPathCommands firstp@(fx,fy) (cx,cy) mbControlp (SVG.EndPath:ds)
| fx /= cx || fy /= cy
= LineTo firstp : renderPathCommands firstp firstp mbControlp ds
| otherwise
= renderPathCommands firstp firstp mbControlp ds
renderPathCommands _ _ _ _ = []
renderTree :: TransformationMatrix -> SVG.Tree -> [PathCommand]
renderTree m (SVG.GroupTree g) = renderTrees (applyTransformations m (SVG._transform (SVG._groupDrawAttributes g))) (SVG._groupChildren g)
renderTree m (SVG.PathTree p) = map (transform tr) $ renderPathCommands (0,0) (0,0) Nothing (SVG._pathDefinition p)
where
tr = applyTransformations m (SVG._transform (SVG._pathDrawAttributes p))
renderTree m (SVG.RectangleTree r)
| rx == 0.0 && ry == 0.0
= map (transform tr) [MoveTo (x,y), LineTo (x+w,y), LineTo (x+w,y+h), LineTo (x,y+h), LineTo (x,y)]
| otherwise
= map (transform tr)
([MoveTo (x,y+ry)] ++ convertSvgArc (x,y+ry) rx ry 0 False True (x+rx, y) ++
[LineTo (x+w-rx,y)] ++ convertSvgArc (x+w-rx,y) rx ry 0 False True (x+w, y+ry) ++
[LineTo (x+w,y+h-ry)] ++ convertSvgArc (x+w,y+h-ry) rx ry 0 False True (x+w-rx, y+h) ++
[LineTo (x+rx,y+h)] ++ convertSvgArc (x+rx, y+h) rx ry 0 False True (x, y+h-ry) ++
[LineTo (x,y+ry)])
where
(x,y) = fromSvgPoint dpi (SVG._rectUpperLeftCorner r)
w = fromSvgNumber dpi (SVG._rectWidth r)
h = fromSvgNumber dpi (SVG._rectHeight r)
(rx, ry) = mapTuple (fromSvgNumber dpi) (SVG._rectCornerRadius r)
tr = applyTransformations m (SVG._transform (SVG._rectDrawAttributes r))
renderTree m (SVG.LineTree l) = [MoveTo p1, LineTo p2]
where
p1 = transform tr (fromSvgPoint dpi (SVG._linePoint1 l))
p2 = transform tr (fromSvgPoint dpi (SVG._linePoint2 l))
tr = applyTransformations m (SVG._transform (SVG._lineDrawAttributes l))
renderTree m (SVG.PolyLineTree l) = map (transform tr) (MoveTo p0:map LineTo ps)
where
(p0:ps) = map (\(Linear.V2 x y) -> (x,y)) (SVG._polyLinePoints l)
tr = applyTransformations m (SVG._transform (SVG._polyLineDrawAttributes l))
renderTree m (SVG.PolygonTree l) = map (transform tr) (MoveTo p0:map LineTo (ps ++ [p0]))
where
(p0:ps) = map (\(Linear.V2 x y) -> (x,y)) (SVG._polygonPoints l)
tr = applyTransformations m (SVG._transform (SVG._polygonDrawAttributes l))
renderTree m (SVG.EllipseTree e) = map (transform tr) (MoveTo (cx-rx,cy) : bs1++bs2++bs3++bs4)
where
bs1 = convertSvgArc (cx-rx, cy) rx ry 0 False True (cx, cy-ry)
bs2 = convertSvgArc (cx, cy-ry) rx ry 0 False True (cx+rx, cy)
bs3 = convertSvgArc (cx+rx, cy) rx ry 0 False True (cx, cy+ry)
bs4 = convertSvgArc (cx, cy+ry) rx ry 0 False True (cx-rx, cy)
(cx,cy) = fromSvgPoint dpi (SVG._ellipseCenter e)
rx = fromSvgNumber dpi (SVG._ellipseXRadius e)
ry = fromSvgNumber dpi (SVG._ellipseYRadius e)
tr = applyTransformations m (SVG._transform (SVG._ellipseDrawAttributes e))
renderTree m (SVG.CircleTree c) = map (transform tr) (MoveTo (cx-r,cy) : bs1++bs2++bs3++bs4)
where
bs1 = convertSvgArc (cx-r, cy) r r 0 False True (cx, cy-r)
bs2 = convertSvgArc (cx, cy-r) r r 0 False True (cx+r, cy)
bs3 = convertSvgArc (cx+r, cy) r r 0 False True (cx, cy+r)
bs4 = convertSvgArc (cx, cy+r) r r 0 False True (cx-r, cy)
(cx,cy) = fromSvgPoint dpi (SVG._circleCenter c)
r = fromSvgNumber dpi (SVG._circleRadius c)
tr = applyTransformations m (SVG._transform (SVG._circleDrawAttributes c))
{- The rest: None, UseTree, SymbolTree, TextTree, ImageTree -}
renderTree _ _ = []
renderTrees :: TransformationMatrix -> [SVG.Tree] -> [PathCommand]
renderTrees m es = concatMap (renderTree m) es