module Graphics.Curves.SVG.Path
( Path, CoordType(..), PathCmd(..)
, parsePath, drawPath
) where
import Data.Char
import Data.Monoid
import Graphics.Curves
type Path = [PathCmd]
data CoordType = Absolute | Relative
deriving Show
data PathCmd = MoveTo CoordType Point
| LineTo CoordType Point
| HorLineTo CoordType Scalar
| VerLineTo CoordType Scalar
| BezierTo CoordType [Point]
| SmoothBezierTo CoordType [Point]
| ArcTo CoordType Vec Scalar Bool Bool Point
| ClosePath
deriving Show
data PathToken = TokNum Scalar
| TokCmd Char
instance Show PathToken where
show (TokCmd c) = [c]
show (TokNum x) = show x
lexNum :: String -> Maybe (String, String)
lexNum s = start s
where
eat c = fmap (\(a, b) -> (c:a, b))
ret s = Just ("", s)
bad = Nothing
start ('-':s) = eat '-' $ num s
start s = num s
num (c:s) | isDigit c = eat c $ num1 s
num _ = bad
num1 (c:s) | isDigit c = eat c $ num1 s
num1 ('.':s) = eat '.' $ frac s
num1 ('e':s) = eat 'e' $ expn s
num1 s = ret s
frac (c:s) | isDigit c = eat c $ frac1 s
frac1 (c:s) | isDigit c = eat c $ frac1 s
frac1 ('e':s) = eat 'e' $ expn s
frac1 s = ret s
expn ('-':s) = eat '-' $ expn1 s
expn s = expn1 s
expn1 (c:s) | isDigit c = eat c $ expn2 s
expn1 _ = bad
expn2 (c:s) | isDigit c = eat c $ expn2 s
expn2 s = ret s
lexPath :: String -> [PathToken]
lexPath [] = []
lexPath (c:s)
| isAlpha c = TokCmd c : lexPath s
| isNumChar c =
case lexNum (c:s) of
Just (d, s') -> TokNum (read d) : lexPath s'
Nothing -> error $ "lex error on " ++ show (take 25 (c:s)) ++ "..."
| otherwise = lexPath s
where
isNumChar c = isDigit c || c == '-'
parsePath :: String -> Path
parsePath s = parse (lexPath s)
where
parse ts = case ts of
[] -> []
TokCmd 'M' : ts -> args1p 'M' (MoveTo Absolute) ts
TokCmd 'm' : ts -> args1p 'm' (MoveTo Relative) ts
TokCmd 'Z' : ts -> ClosePath : parse ts
TokCmd 'z' : ts -> ClosePath : parse ts
TokCmd 'L' : ts -> args1p 'L' (LineTo Absolute) ts
TokCmd 'l' : ts -> args1p 'l' (LineTo Relative) ts
TokCmd 'H' : ts -> args1 'H' (HorLineTo Absolute) ts
TokCmd 'h' : ts -> args1 'h' (HorLineTo Relative) ts
TokCmd 'V' : ts -> args1 'V' (VerLineTo Absolute) ts
TokCmd 'v' : ts -> args1 'v' (VerLineTo Relative) ts
TokCmd 'C' : ts -> argsNp 3 'C' (BezierTo Absolute) ts
TokCmd 'c' : ts -> argsNp 3 'c' (BezierTo Relative) ts
TokCmd 'S' : ts -> argsNp 2 'S' (SmoothBezierTo Absolute) ts
TokCmd 's' : ts -> argsNp 2 's' (SmoothBezierTo Relative) ts
TokCmd 'Q' : ts -> argsNp 2 'Q' (BezierTo Absolute) ts
TokCmd 'q' : ts -> argsNp 2 'q' (BezierTo Relative) ts
TokCmd 'T' : ts -> argsNp 1 'T' (SmoothBezierTo Absolute) ts
TokCmd 't' : ts -> argsNp 1 't' (SmoothBezierTo Relative) ts
TokCmd 'A' : ts -> argsN 7 'A' (arcTo Absolute) ts
TokCmd 'a' : ts -> argsN 7 'a' (arcTo Relative) ts
TokCmd c : _ -> error $ "parsePath: unknown command: " ++ [c]
TokNum _ : _ -> error $ "parsePath: not a command " ++ show (take 3 ts)
where
next c ts = parse (prevCmd c ts)
prevCmd c ts@(TokNum _ : _) = TokCmd c : ts
prevCmd c ts = ts
arcTo rel [rx, ry, angle, largeArc, sweep, x, y] =
ArcTo rel (Vec rx ry) angle (largeArc /= 0) (sweep /= 0) (Vec x y)
args1 :: Char -> (Scalar -> PathCmd) -> [PathToken] -> Path
args1 c f (TokNum x : ts) = f x : next c ts
args1p :: Char -> (Vec -> PathCmd) -> [PathToken] -> Path
args1p c f (TokNum x : TokNum y : ts) = f (Vec x y) : next c ts
args2p :: Char -> (Vec -> Vec -> PathCmd) -> [PathToken] -> Path
args2p c f (TokNum x : TokNum y : TokNum x' : TokNum y' : ts) = f (Vec x y) (Vec x' y') : next c ts
argsN :: Int -> Char -> ([Scalar] -> PathCmd) -> [PathToken] -> Path
argsN n c f ts
| all isNum xs = f (map getNum xs) : next c ts'
| otherwise = error $ "Expected " ++ show n ++ " numerical arguments to " ++ show c ++ ". Got: " ++ show xs
where
(xs, ts') = splitAt n ts
isNum TokNum{} = True
isNum _ = False
getNum (TokNum x) = x
argsNp :: Int -> Char -> ([Vec] -> PathCmd) -> [PathToken] -> Path
argsNp n c f = argsN (2 * n) c (f . points)
where
points (x:y:xs) = Vec x y : points xs
points [] = []
data DrawState =
DrawState { dsCurrentPoint :: Point
, dsLastControlPoint :: Point
, dsStartOfSubCurve :: Point }
drawPath :: Path -> Image
drawPath p = snd $ foldl draw (DrawState 0 0 0, mempty) p
where
draw (ds, i) cmd = case cmd of
MoveTo ct p -> (newSubCurve p', i +.+ point p')
where p' = pt ds ct p
LineTo ct p -> (newPt ds p', i ++> p')
where p' = pt ds ct p
HorLineTo ct x -> (newPt ds p', i ++> p')
where Vec _ y = dsCurrentPoint ds
Vec x' _ = pt ds ct (Vec x 0)
p' = Vec x' y
VerLineTo ct y -> (newPt ds p', i ++> p')
where Vec x _ = dsCurrentPoint ds
Vec _ y' = pt ds ct (Vec 0 y)
p' = Vec x y'
BezierTo ct ps -> (newPt ds (last ps'), i +++ bezierSegment (dsCurrentPoint ds : ps'))
where ps' = map (pt ds ct) ps
SmoothBezierTo ct ps -> (newPt ds (last ps'), i +++ bezierSegment (p0 : cp : ps'))
where ps' = map (pt ds ct) ps
p0 = dsCurrentPoint ds
cp = 2 * p0 dsLastControlPoint ds
ArcTo{} -> error "TODO: elliptical arcs"
ClosePath -> (newPt ds p, i ++> p)
where p = dsStartOfSubCurve ds
pt ds Absolute p = p
pt ds Relative p = p + dsCurrentPoint ds
newPt ds p = ds { dsCurrentPoint = p, dsLastControlPoint = p }
newSubCurve p = DrawState p p p