diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010, Tillmann Vogt +Copyright (c) 2010-2013, 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: diff --git a/SVGPath.cabal b/SVGPath.cabal --- a/SVGPath.cabal +++ b/SVGPath.cabal @@ -1,5 +1,5 @@ Name: SVGPath -Version: 1.1 +Version: 1.1.1 Synopsis: Parsing the path command of SVG Description: Parsing the path command of SVG category: Graphics diff --git a/src/Graphics/SVG/ReadPath.hs b/src/Graphics/SVG/ReadPath.hs --- a/src/Graphics/SVG/ReadPath.hs +++ b/src/Graphics/SVG/ReadPath.hs @@ -1,14 +1,14 @@ -------------------------------------------------------------------- -- | -- Module : Graphics.SVG.ReadPath --- Copyright : (c) 2011 Tillmann Vogt +-- Copyright : (c) 2013 Tillmann Vogt -- License : BSD3 -- -- Maintainer: Tillmann Vogt -- Stability : stable -- Portability: portable -- --- parsing the SVG path command, see : +-- Parsing the SVG path command, see : module Graphics.SVG.ReadPath ( pathFromString, @@ -27,8 +27,8 @@ import System.IO.Unsafe (unsafePerformIO) import Debug.Trace -type X = Float -type Y = Float +type X = Double +type Y = Double type F2 = (X,Y) type Tup = (X,Y) type X1 = X @@ -83,43 +83,43 @@ 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 "M"; l <- many1 tuple2; return (map (\x-> M_abs x) l) } <|> + do{ symbol "m"; l <- many1 tuple2; 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 "L"; l <- many1 tuple2; return (map (\x-> L_abs x) l) } <|> + do{ symbol "l"; l <- many1 tuple2; return (map (\x-> L_rel x) l) } <|> do{ symbol "H"; l <- many1 myfloat; return (map (\x-> H_abs (realToFrac x)) l) } <|> do{ symbol "h"; l <- many1 myfloat; return (map (\x-> H_rel (realToFrac x)) l) } <|> do{ symbol "V"; l <- many1 myfloat; return (map (\x-> V_abs (realToFrac x)) l) } <|> do{ symbol "v"; l <- many1 myfloat; return (map (\x-> V_rel (realToFrac 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 + do{ symbol "C"; l <- many1 tuple6; return (map (\x-> C_abs x) l) } <|> + do{ symbol "c"; l <- many1 tuple6; return (map (\x-> C_rel x) l) } <|> + do{ symbol "S"; l <- many1 tuple4; return (map (\x-> S_abs x) l) } <|> + do{ symbol "s"; l <- many1 tuple4; return (map (\x-> S_rel x) l) } <|> + do{ symbol "Q"; l <- many1 tuple4; return (map (\x-> Q_abs x) l) } <|> + do{ symbol "q"; l <- many1 tuple4; return (map (\x-> Q_rel x) l) } <|> + do{ symbol "T"; l <- many1 tuple2; return (map (\x-> T_abs x) l) } <|> + do{ symbol "t"; l <- many1 tuple2; return (map (\x-> T_rel x) l) } <|> + do{ symbol "A"; l <- many1 tuple2; return (map (\x-> A_abs) l) } <|> -- not used + do{ symbol "a"; l <- many1 tuple2; return (map (\x-> A_rel) l) } -- not used } comma = do{ spaces; try (do { (char ','); return () }) <|> spaces } -tupel2 :: Parser (X,Y) -tupel2 = do{ x <- myfloat; comma; y <- myfloat; spaces; +tuple2 :: Parser (X,Y) +tuple2 = do{ x <- myfloat; comma; y <- myfloat; spaces; return (realToFrac x, realToFrac y) } -tupel4 :: Parser (X,Y,X,Y) -tupel4 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces; +tuple4 :: Parser (X,Y,X,Y) +tuple4 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces; x <- myfloat; comma; y <- myfloat; spaces; return (realToFrac x1, realToFrac y1, realToFrac x, realToFrac y) } -tupel6 :: Parser (X,Y,X,Y,X,Y) -tupel6 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces; +tuple6 :: Parser (X,Y,X,Y,X,Y) +tuple6 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces; x2 <- myfloat; comma; y2 <- myfloat; spaces; x <- myfloat; comma; y <- myfloat; spaces; return (realToFrac x1, realToFrac y1, realToFrac x2, realToFrac y2, realToFrac x, realToFrac y) @@ -143,8 +143,12 @@ | otherwise = result where result = ctp commands [(0,0)] (0,0) False (dx,dy) (offsetX, offsetY) +unequal :: (Fractional a, Fractional a1, Ord a, Ord a1) => a -> a1 -> (a, a1) -> (a, a1) -> Bool +unequal dx dy (x0,y0) (x1,y1) | (abs (x0-x1) < dx/4) && (abs (y0-y1) < dy/4) = False + | otherwise = True + ctp :: [PathCommand] -> [F2] -> F2 -> Bool -> F2 -> F2 -> [[F2]] -ctp [] _ _ _ _ _ = [] +ctp [] p _ _ _ _ = [tail p] ctp (c:commands) points lastContr useTex (dx, dy) (ox,oy) -- dx, dy is the size of a pixel, used for rasterisation -- one outline completed | null nextPoints = [tail points] ++ (if useTex && unequal dx dy (last points) (head points) @@ -154,10 +158,10 @@ ( ctp commands [(0,0)] (contr c) useTex (dx,dy) (ox,oy)) | otherwise = ctp commands (points ++ (tail nextPoints)) (contr c) useTex (dx,dy) (ox,oy) -- work on outline where nextPoints = (go c) - contr ( C_abs (x1,y1,x2,y2,x,y) ) = ( x+x-x2, y+y-y2 ) -- control point of bezier curve - contr ( C_rel (x1,y1,x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 ) - contr ( S_abs (x2,y2,x,y) ) = ( x+x-x2, y+y-y2 ) - contr ( S_rel (x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 ) + contr ( C_abs (_,_,x2,y2,x,y) ) = ( x+x-x2, y+y-y2 ) -- control point of bezier curve + contr ( C_rel (_,_,x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 ) + contr ( S_abs (x2,y2,x,y) ) = ( x+x-x2, y+y-y2 ) + contr ( S_rel (x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 ) contr ( Q_abs (x1,y1,x,y) ) = ( x+x-x1, y+y-y1 ) contr ( Q_rel (x1,y1,x,y) ) = (x0+x+x-x1, y0+y+y-y1 ) contr ( T_abs (x,y) ) = ( x+x-cx, y+y-cy ) @@ -170,6 +174,8 @@ contr ( H_rel x ) = (x0 + x, y0 ) contr ( V_abs y ) = (x0, y ) contr ( V_rel y ) = (x0, y0 + y ) + contr _ = error "error at parsing SVG path command, arcs not implemented yet" + go ( M_abs (x,y) ) = [(0, 0), (x + ox, y + oy)] go ( M_rel (x,y) ) = [(0, 0), (x0 + x + ox, y0 + y + oy)] go ( L_abs (x,y) ) | useTex = bsub [(x0,y0), (x, y)] @@ -193,25 +199,29 @@ go ( T_abs (x,y) ) = bsub [(x0,y0), (cx, cy), (x, y) ] go ( T_rel (x,y) ) = bsub [(x0,y0), (cx, cy), (x0 + x, y0 + y)] go ( Z ) = [] + go _ = error "error at parsing SVG path command, arcs not implemented yet" + 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 - unequal dx dy (x0,y0) (x1,y1) | (abs (x0-x1) < dx/4) && (abs (y0-y1) < dy/4) = False - | otherwise = True ----------------- -- bezier-curves ----------------- +linearInterp :: Num t => t -> ((t, t), (t, t)) -> (t, t) linearInterp t ((x0,y0), (x1,y1)) = ( (1-t)*x0 + t*x1, (1-t)*y0 + t*y1) +tuplesOfTwo :: [t] -> [(t, t)] tuplesOfTwo (bi:bj:[]) = [(bi,bj)] tuplesOfTwo (bi:bj:bs) = (bi,bj) : tuplesOfTwo (bj:bs) +tuplesOfTwo _ = error "tuplesOfTwo" eval t bs = map (linearInterp t) (tuplesOfTwo bs) +deCas2 :: Num t => t -> [(t, t)] -> [(t, t)] deCas2 t (bi:[]) = [bi] deCas2 t bs = [head bs] ++ (deCas2 t e) ++ [last bs] where e = eval t bs