SVGPath (empty) → 1.0
raw patch · 4 files changed
+252/−0 lines, 4 filesdep +basedep +parsecsetup-changed
Dependencies added: base, parsec
Files
- LICENSE +11/−0
- SVGPath.cabal +19/−0
- Setup.hs +3/−0
- src/Graphics/SVG/ReadPath.hs +219/−0
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright (c) 2010, Tillmann Vogt +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. +Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. +The names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +
+ SVGPath.cabal view
@@ -0,0 +1,19 @@+Name: SVGPath +Version: 1.0 +Synopsis: Parsing the path command from SVG +Description: Parsing the path command from SVG+category: Graphics +License: BSD3 +License-file: LICENSE +Author: Tillmann Vogt +Maintainer: Tillmann.Vogt@rwth-aachen.de +Build-Type: Simple +Cabal-Version: >=1.6 ++Library+ hs-source-dirs: src + build-depends: + base == 4.*, + parsec == 2.1.* + exposed-modules: + Graphics.SVG.ReadPath
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain
+ src/Graphics/SVG/ReadPath.hs view
@@ -0,0 +1,219 @@+-------------------------------------------------------------------- +-- | +-- Module : Graphics.SVG.ReadPath +-- Copyright : (c) 2010 Tillmann Vogt +-- License : BSD3 +-- +-- Maintainer: Tillmann Vogt <Tillmann.Vogt@rwth-aachen.de> +-- Stability : stable +-- Portability: portable +-- +-- parsing the SVG path command, see <http://www.w3.org/TR/SVG/paths.html#PathData> : + +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)