module Graphics.SVG.ReadPath
( pathFromString,
PathCommand(..),
commandsToPoints,
ctp,
bSubCurve
)
where
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Prim
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(emptyDef)
import System.IO.Unsafe (unsafePerformIO)
import Debug.Trace
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 |
Z |
L_abs Tup |
L_rel Tup |
H_abs X |
H_rel X |
V_abs Y |
V_rel Y |
C_abs (X1,Y1,X2,Y2,X,Y) |
C_rel (X1,Y1,X2,Y2,X,Y) |
S_abs (X2,Y2,X,Y) |
S_rel (X2,Y2,X,Y) |
Q_abs (X1,Y1,X,Y) |
Q_rel (X1,Y1,X,Y) |
T_abs Tup |
T_rel Tup |
A_abs |
A_rel
deriving Show
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{ l <- many 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 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) } <|>
do{ symbol "a"; l <- many1 tupel2; return (map (\x-> A_rel) l) }
}
comma = do{ spaces; try (do { (char ','); return () }) <|> spaces }
tupel2 :: Parser (X,Y)
tupel2 = 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;
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;
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)
}
myfloat = try (do{ symbol "-"; n <- float; return (negate n) }) <|>
try float <|>
do { i<-integer; return(fromIntegral i) }
lexer = P.makeTokenParser emptyDef
whiteSpace = P.whiteSpace lexer
symbol = P.symbol lexer
integer = P.integer lexer
float = P.float lexer
commandsToPoints :: [PathCommand] -> F2 -> F2 -> [[F2]]
commandsToPoints commands (dx, dy) (offsetX, offsetY) | null result = []
| otherwise = result
where result = ctp commands [(0,0)] (0,0) False (dx,dy) (offsetX, offsetY)
ctp :: [PathCommand] -> [F2] -> F2 -> Bool -> F2 -> F2 -> [[F2]]
ctp [] _ _ _ _ _ = []
ctp (c:commands) points lastContr useTex (dx, dy) (ox,oy)
| null nextPoints = [tail points] ++ (if useTex && unequal dx dy (last points) (head points)
then [( go (L_abs (head (tail points))) )]
else []) ++
( ctp commands [(0,0)] (contr c) useTex (dx,dy) (ox,oy))
| otherwise = ctp commands (points ++ (tail nextPoints)) (contr c) useTex (dx,dy) (ox,oy)
where nextPoints = (go c)
contr ( C_abs (x1,y1,x2,y2,x,y) ) = ( x+xx2, y+yy2 )
contr ( C_rel (x1,y1,x2,y2,x,y) ) = (x0+x+xx2, y0+y+yy2 )
contr ( S_abs (x2,y2,x,y) ) = ( x+xx2, y+yy2 )
contr ( S_rel (x2,y2,x,y) ) = (x0+x+xx2, y0+y+yy2 )
contr ( Q_abs (x1,y1,x,y) ) = ( x+xx1, y+yy1 )
contr ( Q_rel (x1,y1,x,y) ) = (x0+x+xx1, y0+y+yy1 )
contr ( T_abs (x,y) ) = ( x+xcx, y+ycy )
contr ( T_rel (x,y) ) = ( 2*(x0+x)cx, 2*(y0+y)cy )
contr ( L_abs (x,y) ) = ( x, y)
contr ( L_rel (x,y) ) = (x0 + x, y0 + y)
contr ( M_abs (x,y) ) = ( x, y)
contr ( M_rel (x,y) ) = (x0 + x, y0 + y)
contr ( H_abs x ) = ( x, y0 )
contr ( H_rel x ) = (x0 + x, y0 )
contr ( V_abs y ) = (x0, y )
contr ( V_rel y ) = (x0, y0 + y )
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)]
| otherwise = [(x0,y0), (x, y)]
go ( L_rel (x,y) ) | useTex = bsub [(x0,y0), (x0 + x, y0 + y)]
| otherwise = [(x0,y0), (x0 + x, y0 + y)]
go ( H_abs x) | useTex = bsub [(x0,y0), (x, y0)]
| otherwise = [(x0,y0), (x, y0)]
go ( H_rel x) | useTex = bsub [(x0,y0), (x0 + x, y0)]
| otherwise = [(x0,y0), (x0 + x, y0)]
go ( V_abs y) | useTex = bsub [(x0,y0), (x0, y)]
| otherwise = [(x0,y0), (x0, y)]
go ( V_rel y) | useTex = bsub [(x0,y0), (x0, y0 + y)]
| otherwise = [(x0,y0), (x0, y0 + y)]
go ( C_abs (x1,y1,x2,y2,x,y) ) = bsub [(x0, y0), (x1, y1), (x2, y2), (x, y)]
go ( C_rel (x1,y1,x2,y2,x,y) ) = bsub [(x0, y0), (x0+x1, y0+y1), (x0+x2,y0+y2), (x0+x,y0+y)]
go ( S_abs ( x2,y2,x,y) ) = bsub [(x0, y0), (cx, cy), (x2, y2), (x, y) ]
go ( S_rel ( x2,y2,x,y) ) = bsub [(x0, y0), (cx, cy), (x0 + x2, y0 + y2), (x0 + x, y0 + y)]
go ( Q_abs (x1,y1,x,y) ) = bsub [(x0, y0), (x1, y1), (x, y)]
go ( Q_rel (x1,y1,x,y) ) = bsub [(x0, y0), (x0 + x1, y0 + y1), (x0 + x, y0 + y)]
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 ) = []
x0 = fst (last points)
y0 = snd (last points)
cx = (fst lastContr)
cy = (snd lastContr)
bsub xs = bSubCurve useTex (dx,dy) xs
unequal dx dy (x0,y0) (x1,y1) | (abs (x0x1) < dx/4) && (abs (y0y1) < dy/4) = False
| otherwise = True
linearInterp t ((x0,y0), (x1,y1)) = ( (1t)*x0 + t*x1, (1t)*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 :: Bool -> (X,Y) -> [F2] -> [F2]
bSubCurve useTex (dx,dy) bs | ( (abs (p1x_intp0x_int)) == 1 && (abs (p1y_intp0y_int)) == 1 ) ||
( (abs (p1xp0x)) < dx && (abs (p1yp0y)) < dy ) ||
( (abs (p1xp0x)) < dx && p0x_int == p1x_int && useTex ) ||
( (abs (p1yp0y)) < dy && p0y_int == p1y_int && useTex )
= [ (p0x, p0y), (p1x, p1y) ]
| otherwise = firstArc ++ (tail secondArc)
where firstArc = bSubCurve useTex (dx,dy) (take l twoArcs)
secondArc = bSubCurve useTex (dx,dy) (drop (l1) 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/dx), truncate (p0y/dy))
| otherwise = (truncate (p1x/dx), truncate (p1y/dy))
(p1x_int, p1y_int) | p0y < p1y = (truncate (p1x/dx), truncate (p1y/dy))
| otherwise = (truncate (p0x/dx), truncate (p0y/dy))