module Graphics.SVGFonts.ReadPath
( pathFromString,
PathCommand(..),
)
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 = Double
type Y = Double
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