{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} ------------------------------------------------------------------------------------- -- Parsing the SVG path command, see ------------------------------------------------------------------------------------- module Diagrams.SVG.Path ( -- * Converting Path Commands commandsToPaths , splittedCommands , outline , nextSegment , svgArc -- * Parsing (Generating Path Commands) , PathCommand(..) , parsePathCommand , commands ) where import Data.Attoparsec.Combinator import Data.Attoparsec.Text import qualified Data.Attoparsec.Text as AT import Data.Char (isAlpha, isHexDigit, digitToInt) import Data.Colour.Names (readColourName) import Data.Colour.SRGB import qualified Data.List.Split as S import Data.List (foldl') import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes) import qualified Data.Text as T import Data.Text(Text(..), pack, unpack, empty) import Diagrams.Attributes import Diagrams.Path import Diagrams.Segment import Diagrams.TwoD.Types import Diagrams.Prelude data AbsRel = Abs | Rel deriving Show data PathCommand n = M AbsRel !(n,n) | -- ^AbsRel (x,y): Establish a new current point (with absolute coords) Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point L AbsRel !(n,n) | -- ^AbsRel (X,Y): A line from the current point to Tup which becomes the new current point H AbsRel !n | -- ^AbsRel x: A horizontal line from the current point (cpx, cpy) to (x, cpy) V AbsRel !n | -- ^AbsRel y: A vertical line from the current point (cpx, cpy) to (cpx, y) C AbsRel !(n,n,n,n,n,n) | -- ^AbsRel (X1,Y1,X2,Y2,X,Y): Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the -- ^control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve. S AbsRel !(n,n,n,n) | -- ^AbsRel (X2,Y2,X,Y): Draws a cubic Bézier curve from the current point to (x,y). The first control point is -- assumed to be the reflection of the second control point on the previous command relative to the current point. -- (If there is no previous command or if the previous command was not an C, c, S or s, assume the first control -- point is coincident with the current point.) (x2,y2) is the second control point (i.e., the control point at -- the end of the curve). Q AbsRel !(n,n,n,n) | -- ^AbsRel (X1,Y1,X,Y): A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point. -- Nearly the same as cubic, but with one point less T AbsRel !(n,n) | -- ^AbsRel (X,Y): T_Abs = Shorthand/smooth quadratic Bezier curveto A AbsRel !(n,n,n,n,n,n,n) -- ^AbsRel (rx,ry,xAxisRot,fl0,fl1,x,y): Elliptic arc deriving Show -- | The parser to parse the lines and curves that make an outline parsePathCommand = do { AT.skipSpace; AT.choice [parse_m, parse_M, parse_l, parse_L, parse_h, parse_H, parse_v, parse_V, parse_c, parse_C, parse_S, parse_s, parse_q, parse_Q, parse_t, parse_T, parse_a, parse_A, parse_z] } -- Although it makes no sense, some programs produce several M in sucession parse_m = do { AT.string "m"; t <- many' tuple2; return (Just $ (M Rel $ head t): (map (L Rel) (tail t)) ) } -- that's why we need many' parse_M = do { AT.string "M"; t <- many' tuple2; return (Just $ map (M Abs) t) } parse_z = do { AT.choice [AT.string "z", AT.string "Z"]; return (Just [Z]) } parse_l = do { AT.string "l"; t <- many' tuple2; return (Just $ map (L Rel) t) } parse_L = do { AT.string "L"; t <- many' tuple2; return (Just $ map (L Abs) t) } parse_h = do { AT.string "h"; t <- many' spaceDouble; return (Just $ map (H Rel) t) } parse_H = do { AT.string "H"; t <- many' spaceDouble; return (Just $ map (H Abs) t) } parse_v = do { AT.string "v"; t <- many' spaceDouble; return (Just $ map (V Rel) t) } parse_V = do { AT.string "V"; t <- many' spaceDouble; return (Just $ map (V Abs) t) } parse_c = do { AT.string "c"; t <- many' tuple6; return (Just $ map (C Rel) t) } parse_C = do { AT.string "C"; t <- many' tuple6; return (Just $ map (C Abs) t) } parse_s = do { AT.string "s"; t <- many' tuple4; return (Just $ map (S Rel) t) } parse_S = do { AT.string "S"; t <- many' tuple4; return (Just $ map (S Abs) t) } parse_q = do { AT.string "q"; t <- many' tuple4; return (Just $ map (Q Rel) t) } parse_Q = do { AT.string "Q"; t <- many' tuple4; return (Just $ map (Q Abs) t) } parse_t = do { AT.string "t"; t <- many' tuple2; return (Just $ map (T Rel) t) } parse_T = do { AT.string "T"; t <- many' tuple2; return (Just $ map (T Abs) t) } parse_a = do { AT.string "a"; t <- many' tuple7; return (Just $ map (A Rel) t) } parse_A = do { AT.string "A"; t <- many' tuple7; return (Just $ map (A Abs) t) } -- | In SVG values can be separated with a "," but don't have to be withOptional parser a = do { AT.skipSpace; AT.choice [ do { AT.char a; b <- parser; return b}, do { b <- parser; return b} ] } doubleWithOptional a = do { d <- double `withOptional` a ; return (fromRational $ toRational d) } spaceDouble = do { AT.skipSpace; d <- double; return (fromRational $ toRational d) } tuple2 = do { a <- spaceDouble; b <- doubleWithOptional ','; return (a, b) } tuple4 = do { a <- spaceDouble; b <- doubleWithOptional ','; c <- doubleWithOptional ','; d <- doubleWithOptional ','; return (a, b, c, d) } tuple6 = do { a <- spaceDouble; b <- doubleWithOptional ','; c <- doubleWithOptional ','; d <- doubleWithOptional ','; e <- doubleWithOptional ','; f <- doubleWithOptional ','; return (a, b, c, d, e, f) } tuple7 = do { a <- spaceDouble; b <- doubleWithOptional ','; c <- doubleWithOptional ','; d <- decimal `withOptional` ','; e <- decimal `withOptional` ','; f <- doubleWithOptional ','; g <- doubleWithOptional ','; return $ -- Debug.Trace.trace (show (a, b, c, fromIntegral d, fromIntegral e, f, g)) (a, b, c, fromIntegral d, fromIntegral e, f, g) } -- | Convert a path string into path commands commands :: (RealFloat n, Show n) => Maybe Text -> [PathCommand n] commands = concat . catMaybes . (either (const []) id) . (AT.parseOnly (many' parsePathCommand)) . (fromMaybe T.empty) -- | Convert path commands into trails commandsToPaths :: (RealFloat n, Show n) => [PathCommand n] -> [Path V2 n] commandsToPaths pathCommands = map fst $ foldl' outline [] (splittedCommands pathCommands) -- | split list when there is a Z(closePath) and also when there is a (M)oveto command (keep the M) -- and merge repeated lists of single Ms into one M command splittedCommands pathCommands = concat $ map (S.split (S.keepDelimsR (S.whenElt isZ))) $ -- a path ends with a Z mergeMs $ -- now it is one M S.split (S.keepDelimsL (S.whenElt isM)) -- a path starts with Ms pathCommands where isM (M ar p) = True isM _ = False isZ Z = True isZ _ = False -- single Ms are a problem, because we would move something empty that we don't remember. mergeMs :: RealFloat n => [[PathCommand n]] -> [[PathCommand n]] mergeMs ( [M Rel (x,y)] : ( ((M Rel (x0,y0)):cs):ds ) ) = mergeMs (((M Rel (x+x0,y+y0)):cs):ds) mergeMs ( [M Rel (x,y)] : ( ((M Abs (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x0, y0)):cs):ds) mergeMs ( [M Abs (x,y)] : ( ((M Rel (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x+x0,y+y0)):cs):ds) mergeMs ( [M Abs (x,y)] : ( ((M Abs (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x0, y0)):cs):ds) mergeMs (c:cs) = c : (mergeMs cs) mergeMs [] = [] data ClosedTrail a = O a | Closed a isClosed (Closed _) = True isClosed _ = False getTrail (Closed a) = a getTrail (O a) = a -- | Take the endpoint of the latest path, append another path that has been generated from the path commands -- and return this whole path outline :: (RealFloat n, Show n) => [(Path V2 n, (n, n))] -> [PathCommand n] -> [(Path V2 n, (n, n))] outline paths cs = paths ++ [(newPath,newPoint)] where newPath = translate (r2 (trx,try)) $ pathFromTrail $ if isClosed trail then wrapLoop $ closeLine (mconcat (getTrail trail)) else wrapLoop $ closeLine (mconcat (getTrail trail)) -- unfortunately this has to be closed also, -- because some svgs fill paths that are open newPoint | isClosed trail = (trx, try) -- the endpoint is the old startpoint | otherwise = startPoint (ctrlPoint, startPoint, trail) = foldl' nextSegment ((x,y), (x,y), O []) cs (trx,try) | null cs = (0,0) | otherwise = sel2 $ nextSegment ((x,y), (x,y), O []) (head cs) -- cs usually always starts with a M-command, -- because we splitted the commands like that (x,y) | null paths = (0,0) | otherwise = snd (last paths) sel2 (a,b,c) = a -- | The last control point and end point of the last path are needed to calculate the next line to append -- endpoint -> (controlPoint, startPoint, line) -> nextSegment :: (RealFloat n, Show n) => ((n,n), (n,n), ClosedTrail [Trail' Line V2 n]) -> PathCommand n -> ( (n,n), (n,n), ClosedTrail [Trail' Line V2 n]) nextSegment (ctrlPoint, startPoint, O trail) Z = (ctrlPoint, startPoint, Closed trail) nextSegment (_, _, _ ) (M Abs point) = (point, point, O []) nextSegment (_, (x0,y0), _ ) (M Rel (x,y)) = ((x+x0, y+y0), (x+x0, y+y0), O []) nextSegment (_, (x0,y0), O trail) (L Abs (x,y)) = ((x, y ), (x, y ), O $ trail ++ [straight' (x-x0, y-y0)]) nextSegment (_, (x0,y0), O trail) (L Rel (x,y)) = ((x+x0, y+y0), (x+x0, y+y0), O $ trail ++ [straight' (x, y )]) nextSegment (_, (x0,y0), O trail) (H Abs x) = ((x, y0), (x, y0), O $ trail ++ [straight' (x-x0, 0)]) nextSegment (_, (x0,y0), O trail) (H Rel x) = ((x+x0, y0), (x+x0, y0), O $ trail ++ [straight' (x, 0)]) nextSegment (_, (x0,y0), O trail) (V Abs y) = (( x0, y ), ( x0, y ), O $ trail ++ [straight' (0 , y-y0)]) nextSegment (_, (x0,y0), O trail) (V Rel y) = (( x0, y+y0), ( x0, y+y0), O $ trail ++ [straight' (0, y )]) nextSegment (_, (x0,y0), O trail) (C Abs (x1,y1,x2,y2,x,y)) = ((x2,y2), (x,y), O $ trail ++ [bez3 (x1-x0, y1-y0) (x2-x0, y2-y0) (x-x0,y-y0)]) nextSegment (_, (x0,y0), O trail) (C Rel (x1,y1,x2,y2,x,y)) = ((x2+x0, y2+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x1, y1) (x2, y2) (x,y)]) nextSegment ((cx,cy),(x0,y0), O trail) (S Abs (x2,y2,x,y)) = ((x2, y2), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x2-x0, y2-y0) (x-x0, y-y0)]) nextSegment ((cx,cy),(x0,y0), O trail) (S Rel (x2,y2,x,y)) = ((x2+x0, y2+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x0-cx, y0-cy) (x2, y2) (x, y)]) nextSegment (_, (x0,y0), O trail) (Q Abs (x1,y1,x,y)) = ((x1, y1), (x, y), O $ trail ++ [bez3 (x1-x0, y1-y0) (x-x0, y-y0) (x-x0, y-y0)]) nextSegment (_, (x0,y0), O trail) (Q Rel (x1,y1,x,y)) = ((x1+x0, y1+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x1, y1) (x, y) (x, y)]) nextSegment ((cx,cy), (x0,y0), O trail) (T Abs (x,y)) = ((2*x0-cx, 2*y0-cy ), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x-x0, y-y0) (x-x0, y-y0)]) nextSegment ((cx,cy), (x0,y0), O trail) (T Rel (x,y)) = ((2*x0-cx, 2*y0-cy), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x, y) (x, y)]) nextSegment (_, (x0,y0), O trail) (A Abs (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)]) nextSegment (_, (x0,y0), O trail) (A Rel (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)]) nul = (0,0) straight' = lineFromSegments . (:[]) . straight . r2 bez3 point1 point2 point3 = lineFromSegments [bezier3 (r2 point1) (r2 point2) (r2 point3)] -- | The arc command: see -- To Do: scale if rx,ry,xAxisRot are such that there is no solution svgArc :: (RealFloat n, Show n) => (n, n) -> n -> n -> n -> (n,n) -> Trail' Line V2 n svgArc (rxx, ryy) xAxisRot largeArcFlag sweepFlag (x2, y2) | x2 == 0 && y2 == 0 = emptyLine -- spec F6.2 | rx == 0 || ry == 0 = straight' (x2,y2) -- spec F6.2 | otherwise = -- Debug.Trace.trace (show (dtheta) ++ show dir1) $ unLoc (arc' 1 dir1 (dtheta @@ rad) # scaleY ry # scaleX rx # rotate (phi @@ rad)) where rx | rxx < 0 = -rxx -- spec F6.2 | otherwise = rxx ry | ryy < 0 = -ryy -- spec F6.2 | otherwise = ryy fa | largeArcFlag == 0 = 0 | otherwise = 1 -- spec F6.2 fs | sweepFlag == 0 = 0 | otherwise = 1 -- spec F6.2 phi = xAxisRot * pi / 180 (x1,y1) = (0,0) x1x2 = (x1 - x2)/2 y1y2 = (y1 - y2)/2 x1' = (cos phi) * x1x2 + (sin phi) * y1y2 y1' = -(sin phi) * x1x2 + (cos phi) * y1y2 s = (rx*rx*ry*ry - rx*rx*y1'*y1' - ry*ry*x1'*x1') / (rx*rx*y1'*y1' + ry*ry*x1'*x1' ) root | s <= 0 = 0 -- Should only happen because of rounding errors, s usually being very close to 0 | otherwise = sqrt s -- This bug happened: cx' | fa /= fs = root * rx * y1' / ry | otherwise = - root * rx * y1' / ry cy' | fa /= fs = - root * ry * x1' / rx | otherwise = root * ry * x1' / rx cx = (cos phi) * cx' - (sin phi) * cy' + ((x1+x2)/2) cy = (sin phi) * cx' + (cos phi) * cy' + ((y1+y2)/2) dir1 = dirBetween (p2 ((x1'-cx')/rx, (y1'-cy')/ry)) origin v1 = r2 (( x1'-cx')/rx, (y1'-cy')/ry) v2 = r2 ((-x1'-cx')/rx, (-y1'-cy')/ry) -- angleV1V2 is unfortunately necessary probably because of something like angleV1V2 | (signorm v1 `dot` signorm v2) >= 1 = (acosA 1 ) ^. rad | (signorm v1 `dot` signorm v2) <= -1 = (acosA (-1)) ^. rad | otherwise = (signedAngleBetween v2 v1) ^. rad dtheta | fs == 0 = if angleV1V2 > 0 then angleV1V2 - (2*pi) else angleV1V2 | otherwise = if angleV1V2 < 0 then angleV1V2 + (2*pi) else angleV1V2