-------------------------------------------------------------------- -- | -- Module : Graphics.SVG.ReadPath -- Copyright : (c) 2010 Tillmann Vogt -- License : BSD3 -- -- Maintainer: Tillmann Vogt -- Stability : stable -- Portability: portable -- -- parsing the SVG path command, see : module Graphics.SVG.ReadPath ( pathFromString, PathCommand(..), commandsToPoints, bSubCurve ) where import Text.ParserCombinators.Parsec hiding (spaces) import Text.ParserCombinators.Parsec.Expr import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language( javaStyle ) type X = Float type Y = Float type F2 = (X,Y) type Tup = (X,Y) type X1 = X type Y1 = Y type X2 = X type Y2 = Y data PathCommand = M_abs Tup | M_rel Tup | -- ^establish a new current point (with absolute coords or rel. to the current point) Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point L_abs Tup | L_rel Tup | -- ^a line from the current point to Tup which becomes the new current point H_abs X | H_rel X | -- ^a horizontal line from the current point (cpx, cpy) to (x, cpy) V_abs Y | V_rel Y | -- ^a vertical line from the current point (cpx, cpy) to (cpx, y) C_abs (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. C_rel (X1,Y1,X2,Y2,X,Y) | S_abs (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). S_rel (X2,Y2,X,Y) | Q_abs (X1,Y1,X,Y) | -- ^a quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point Q_rel (X1,Y1,X,Y) | -- ^nearly the same as cubic, but with one point less T_abs Tup | T_rel Tup | -- ^T_Abs = Shorthand/smooth quadratic Bezier curveto A_abs | -- ^A = elliptic arc A_rel -- ^A = elliptic arc (not used) deriving Show -- | convert a SVG path string into alist of commands pathFromString :: String -> IO [PathCommand] pathFromString str = do{ case (parse path "" str) of Left err -> do{ putStr "parse error at " ; print err ; return [] } Right x -> return x } spaces = skipMany space path :: Parser [PathCommand] path = do{ whiteSpace ; l <- many1 pathElement ; eof ; return (concat l) } pathElement :: Parser [PathCommand] pathElement = do{ whiteSpace; do{ symbol "M"; l <- many1 tupel2; return (map (\x-> M_abs x) l) } <|> do{ symbol "m"; l <- many1 tupel2; return (map (\x-> M_rel x) l) } <|> do{ symbol "z"; return [Z]; } <|> do{ symbol "Z"; return [Z]; } <|> do{ symbol "L"; l <- many1 tupel2; return (map (\x-> L_abs x) l) } <|> do{ symbol "l"; l <- many1 tupel2; return (map (\x-> L_rel x) l) } <|> do{ symbol "H"; l <- many1 integer; return (map (\x-> H_abs (fromIntegral x)) l) } <|> do{ symbol "h"; l <- many1 integer; return (map (\x-> H_rel (fromIntegral x)) l) } <|> do{ symbol "V"; l <- many1 integer; return (map (\x-> V_abs (fromIntegral x)) l) } <|> do{ symbol "v"; l <- many1 integer; return (map (\x-> V_rel (fromIntegral x)) l) } <|> do{ symbol "C"; l <- many1 tupel6; return (map (\x-> C_abs x) l) } <|> do{ symbol "c"; l <- many1 tupel6; return (map (\x-> C_rel x) l) } <|> do{ symbol "S"; l <- many1 tupel4; return (map (\x-> S_abs x) l) } <|> do{ symbol "s"; l <- many1 tupel4; return (map (\x-> S_rel x) l) } <|> do{ symbol "Q"; l <- many1 tupel4; return (map (\x-> Q_abs x) l) } <|> do{ symbol "q"; l <- many1 tupel4; return (map (\x-> Q_rel x) l) } <|> do{ symbol "T"; l <- many1 tupel2; return (map (\x-> T_abs x) l) } <|> do{ symbol "t"; l <- many1 tupel2; return (map (\x-> T_rel x) l) } <|> do{ symbol "A"; l <- many1 tupel2; return (map (\x-> A_abs) l) } <|> -- not used do{ symbol "a"; l <- many1 tupel2; return (map (\x-> A_rel) l) } -- not used } tupel2 :: Parser (X,Y) tupel2 = do{ x <- myfloat; spaces; y <- myfloat; spaces; ; return (realToFrac x, realToFrac y) } tupel4 :: Parser (X,Y,X,Y) tupel4 = do{ x1 <- myfloat; spaces; y1 <- myfloat; spaces; x <- myfloat; spaces; y <- myfloat; spaces; ; return (realToFrac x1, realToFrac y1, realToFrac x, realToFrac y) } tupel6 :: Parser (X,Y,X,Y,X,Y) tupel6 = do{ x1 <- myfloat; spaces; y1 <- myfloat; spaces; x2 <- myfloat; spaces; y2 <- myfloat; spaces; x <- myfloat; spaces; y <- myfloat; spaces; ; return (realToFrac x1, realToFrac y1, realToFrac x2, realToFrac y2, realToFrac x, realToFrac y) } myfloat = try (do{ symbol "-"; n <- float; return (negate n) }) <|> try float <|> -- 0 is not recognized as a float, so recognize it as an integer and then convert it to float do { i<-integer; return(fromIntegral i) } lexer = P.makeTokenParser oDef oDef = javaStyle whiteSpace = P.whiteSpace lexer symbol = P.symbol lexer integer = P.integer lexer float = P.float lexer ------------------------------------------- -- | convert path-commands to outline points commandsToPoints :: [PathCommand] -> F2 -> [[F2]] commandsToPoints commands (dx, dy) | length result == 0 = [] | otherwise = result where result = ctp commands [(0,0)] (0,0) False 255 (dx,dy) ctp :: [PathCommand] -> [F2] -> F2 -> Bool -> Int -> F2 -> [[F2]] ctp [] _ _ _ _ _ = [] ctp (c:commands) points lastContr useTex n (dx, dy) -- dx, dy is the size of a pixel, used for rasterisation | (length nextPoints) == 0 = [tail points] ++ ( ctp commands nextPoints (contr c) useTex (if n>0 then n-1 else 0) (dx,dy) ) | otherwise = ctp commands (points ++ nextPoints) (contr c) useTex (if n>0 then n-1 else 0) (dx,dy) where nextPoints = (go c) contr ( C_abs (x1,y1,x2,y2,x,y) ) = ( (x+x-x2)/dx, (y+y-y2)/dy ) -- control point of bezier curve contr ( C_rel (x1,y1,x2,y2,x,y) ) = (x0+(x+x-x2)/dx, y0+(y+y-y2)/dy ) contr ( S_abs (x2,y2,x,y) ) = ( (x+x-x2)/dx, (y+y-y2)/dy ) contr ( S_rel (x2,y2,x,y) ) = (x0+(x+x-x2)/dx, y0+(y+y-y2)/dy ) contr ( Q_abs (x1,y1,x,y) ) = ( (x+x-x1)/dx, (y+y-y1)/dy ) contr ( Q_rel (x1,y1,x,y) ) = (x0+(x+x-x1)/dx, y0+(y+y-y1)/dy ) contr ( T_abs (x,y) ) = ( (x+x)/dx-cx, (y+y)/dy - cy ) contr ( T_rel (x,y) ) = ( 2*(x0+x/dx)-cx, 2*(y0+y/dy)-cy ) -- absolute coordinates contr ( L_abs (x,y) ) = ( x/dx, y/dy) contr ( L_rel (x,y) ) = (x0 + x/dx, y0 + y/dy) contr ( M_abs (x,y) ) = ( x/dx, y/dy) contr ( M_rel (x,y) ) = (x0 + x/dx, y0 + y/dy) contr ( H_abs x ) = ( x/dx, y0 ) contr ( H_rel x ) = (x0 + x/dx, y0 ) contr ( V_abs y ) = (x0, y/dy ) contr ( V_rel y ) = (x0, y0 + y/dy ) go ( L_abs (x,y) ) = bsub [(x0,y0), (x/dx, y/dy)] go ( L_rel (x,y) ) = bsub [(x0,y0), (x0 + x/dx, y0 + y/dy)] go ( M_abs (x,y) ) = [(x/dx, y/dy)] go ( M_rel (x,y) ) = [(x0 + x/dx, y0 + y/dy)] go ( H_abs x) = bsub [(x0,y0), (x/dx, y0)] go ( H_rel x) = bsub [(x0,y0), (x0 + x/dx, y0)] go ( V_abs y) = bsub [(x0,y0), (x0, y/dy)] go ( V_rel y) = bsub [(x0,y0), (x0, y0 + y/dy)] go ( C_abs (x1,y1,x2,y2,x,y) ) = bsub [(x0, y0), (x1/dx, y1/dy), (x2/dx, y2/dy), (x/dx, y/dy)] go ( C_rel (x1,y1,x2,y2,x,y) ) = bsub [(x0, y0), (x0+x1/dx, y0+y1/dy), (x0+x2/dx,y0+y2/dy), (x0+x/dx,y0+y/dy)] go ( S_abs ( x2,y2,x,y) ) = bsub [(x0, y0), (cx, cy), (x2/dx, y2/dy), (x/dx, y/dy) ] go ( S_rel ( x2,y2,x,y) ) = bsub [(x0, y0), (cx, cy), (x0 + x2/dx, y0 + y2/dy), (x0 + x/dx, y0 + y/dy)] go ( Q_abs (x1,y1,x,y) ) = bsub [(x0, y0), (x1/dx, y1/dy), (x/dx, y/dy)] go ( Q_rel (x1,y1,x,y) ) = bsub [(x0, y0), (x0 + x1/dx, y0 + y1/dy), (x0 + x/dx, y0 + y/dy)] go ( T_abs (x,y) ) = bsub [(x0,y0), (cx, cy), (x/dx, y/dy) ] go ( T_rel (x,y) ) = bsub [(x0,y0), (cx, cy), (x0 + x/dx, y0 + y/dy)] go ( Z ) = [] x0 = fst (last points) y0 = snd (last points) cx = (fst lastContr) -- last control point is always in absolute coordinates cy = (snd lastContr) bsub xs = bSubCurve useTex (dx,dy) xs ----------------- -- bezier-curves ----------------- linearInterp t ((x0,y0), (x1,y1)) = ( (1-t)*x0 + t*x1, (1-t)*y0 + t*y1) tuplesOfTwo (bi:bj:[]) = [(bi,bj)] tuplesOfTwo (bi:bj:bs) = (bi,bj) : tuplesOfTwo (bj:bs) eval t bs = map (linearInterp t) (tuplesOfTwo bs) deCas2 t (bi:[]) = [bi] deCas2 t bs = [head bs] ++ (deCas2 t e) ++ [last bs] where e = eval t bs -- | bSubcurve uses bezier subdivision. (inspired by Hersch, Font Rasterization: the State of the Art (freely available)) -- It divides an arc into two arcs recursively until the arc is either completely -- between two vertical raster lines or completely between two horizontal raster lines or the line is at most 1 pixel long. -- This function computes outline points (tex==False) as well as border points for rasterisation (tex==True) by using -- an x-, y-resoultion raster. dx, dy is the width and height of a pixel of this raster. bSubCurve :: Bool -> (X,Y) -> [F2] -> [F2] bSubCurve useTex (dx,dy) bs | ((abs (p1x-p0x)) < dx && (abs (p1y-p0y)) < dy && (not useTex)) || -- line that is at most one pixel long ((abs (p1x-p0x)) < 1 && (abs (p1y-p0y)) < 1 && useTex) || ((abs (p1x-p0x)) < 1 && p0x_int == p1x_int && useTex) || -- vertical line ((abs (p1y-p0y)) < 1 && p0y_int == p1y_int && useTex) || -- horizontal line (useTex == False && (dx == 0 || dy == 0)) = [ (p0x, p0y), (p1x, p1y) ] | otherwise = firstArc ++ secondArc -- tail secondArc -- subdivide where firstArc = bSubCurve useTex (dx,dy) (take l twoArcs) secondArc = bSubCurve useTex (dx,dy) (drop (l-1) twoArcs) twoArcs = deCas2 0.5 bs l = (length twoArcs) `div` 2 + 1 (p0x, p0y) = head bs (p1x, p1y) = last bs (p0x_int, p0y_int) | p0y < p1y = (truncate p0x, truncate p0y) | otherwise = (truncate p1x, truncate p1y) (p1x_int, p1y_int) | p0y < p1y = (truncate p1x, truncate p1y) | otherwise = (truncate p0x, truncate p0y)