module Graphics.SVGFonts.ReadPath
( pathFromString,
PathCommand(..),
)
where
import Control.Applicative hiding (many, (<|>))
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.ParserCombinators.Parsec.Language (emptyDef)
import qualified Text.ParserCombinators.Parsec.Token as P
type X = Double
type Y = Double
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 -> Either String [PathCommand]
pathFromString str = case parse path "" str of
Left err -> Left (show err)
Right p -> Right p
spaces :: Parser ()
spaces = skipMany space
path :: Parser [PathCommand]
path = do{ l <- many pathElement
; eof
; return (concat l)
}
pathElement :: Parser [PathCommand]
pathElement =
whiteSpace *>
( symbol "M" *> many1 (M_abs <$> tupel2)
<|> symbol "m" *> many1 (M_rel <$> tupel2)
<|> symbol "z" *> pure [Z]
<|> symbol "Z" *> pure [Z]
<|> symbol "L" *> many1 (L_abs <$> tupel2)
<|> symbol "l" *> many1 (L_rel <$> tupel2)
<|> symbol "H" *> many1 (H_abs . realToFrac <$> myfloat)
<|> symbol "h" *> many1 (H_rel . realToFrac <$> myfloat)
<|> symbol "V" *> many1 (V_abs . realToFrac <$> myfloat)
<|> symbol "v" *> many1 (V_rel . realToFrac <$> myfloat)
<|> symbol "C" *> many1 (C_abs <$> tupel6)
<|> symbol "c" *> many1 (C_rel <$> tupel6)
<|> symbol "S" *> many1 (S_abs <$> tupel4)
<|> symbol "s" *> many1 (S_rel <$> tupel4)
<|> symbol "Q" *> many1 (Q_abs <$> tupel4)
<|> symbol "q" *> many1 (Q_rel <$> tupel4)
<|> symbol "T" *> many1 (T_abs <$> tupel2)
<|> symbol "t" *> many1 (T_rel <$> tupel2)
<|> symbol "A" *> many1 (A_abs <$ tupel2)
<|> symbol "a" *> many1 (A_rel <$ tupel2)
)
comma :: Parser ()
comma = spaces *> (try (() <$ char ',' ) <|> 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 :: Parser Double
myfloat = try (do{ _ <- symbol "-"; n <- float; return (negate n) }) <|>
try float <|>
do { i<-integer; return(fromIntegral i) }
lexer :: P.TokenParser a
lexer = P.makeTokenParser emptyDef
whiteSpace :: Parser ()
whiteSpace = P.whiteSpace lexer
symbol :: String -> Parser String
symbol = P.symbol lexer
integer :: Parser Integer
integer = P.integer lexer
float :: Parser Double
float = P.float lexer