{-# LANGUAGE OverloadedStrings #-} module Graphics.SvgTree.PathParser ( transformParser , command , pathParser , viewBoxParser , pointData , gradientCommand , serializePoints , serializeCommand , serializeGradientCommand , serializeCommands , serializeViewBox ) where import Control.Applicative ((<|>)) import Data.Attoparsec.Combinator (option, sepBy, sepBy1) import Data.Attoparsec.Text (Parser, char, digit, many1, parseOnly, scientific, skipSpace, string) import Data.Functor import Data.List import Data.Scientific (toRealFloat) import qualified Data.Text as T import Graphics.SvgTree.Misc import Graphics.SvgTree.Types import Linear hiding (angle, point) import Text.Printf (printf) num :: Parser Double num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) where doubleNumber :: Parser Double doubleNumber = toRealFloat <$> scientific <|> shorthand plusMinus = negate <$ string "-" <*> doubleNumber <|> string "+" *> doubleNumber <|> doubleNumber shorthand = process' <$> (string "." *> many1 digit) process' = either (const 0) id . parseOnly doubleNumber . T.pack . (++) "0." viewBoxParser :: Parser (Double, Double, Double, Double) viewBoxParser = (,,,) <$> iParse <*> iParse <*> iParse <*> iParse where iParse = num <* skipSpace serializeViewBox :: (Double, Double, Double, Double) -> String serializeViewBox (a, b, c, d) = printf "%s %s %s %s" (ppD a) (ppD b) (ppD c) (ppD d) commaWsp :: Parser () commaWsp = skipSpace *> option () (string "," $> ()) <* skipSpace point :: Parser RPoint point = V2 <$> num <* commaWsp <*> num pointData :: Parser [RPoint] pointData = point `sepBy` commaWsp pathParser :: Parser [PathCommand] pathParser = skipSpace *> many1 command command :: Parser PathCommand command = (MoveTo OriginAbsolute <$ string "M" <*> pointList) <|> (MoveTo OriginRelative <$ string "m" <*> pointList) <|> (LineTo OriginAbsolute <$ string "L" <*> pointList) <|> (LineTo OriginRelative <$ string "l" <*> pointList) <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList) <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList) <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList) <|> (VerticalTo OriginRelative <$ string "v" <*> coordList) <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs) <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs) <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList) <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList) <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList) <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList) <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs) <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs) <|> (EndPath <$ string "Z" <* commaWsp) <|> (EndPath <$ string "z" <* commaWsp) where pointList = point `sepBy1` commaWsp pointPair = (,) <$> point <* commaWsp <*> point pointPairList = pointPair `sepBy1` commaWsp coordList = num `sepBy1` commaWsp curveToArgs = (,,) <$> (point <* commaWsp) <*> (point <* commaWsp) <*> point manyComma a = a `sepBy1` commaWsp numComma = num <* commaWsp ellipticalArgs = (,,,,,) <$> numComma <*> numComma <*> numComma <*> fmap (/= 0) numComma <*> fmap (/= 0) numComma <*> point unwordsS :: [ShowS] -> ShowS unwordsS = foldr (.) id . intersperse (showChar ' ') serializePoint :: RPoint -> ShowS serializePoint (V2 x y) = showString (ppD x) . showChar ',' . showString (ppD y) serializePoints :: [RPoint] -> ShowS serializePoints = unwordsS . map serializePoint serializeCoords :: [Coord] -> ShowS serializeCoords = unwordsS . fmap (showString . ppD) serializePointPair :: (RPoint, RPoint) -> ShowS serializePointPair (a, b) = serializePoint a . showChar ' ' . serializePoint b serializePointPairs :: [(RPoint, RPoint)] -> ShowS serializePointPairs = unwordsS . fmap serializePointPair serializePointTriplet :: (RPoint, RPoint, RPoint) -> ShowS serializePointTriplet (a, b, c) = serializePoint a . showChar ' ' . serializePoint b . showChar ' ' . serializePoint c serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> ShowS serializePointTriplets = unwordsS . fmap serializePointTriplet serializeCommands :: [PathCommand] -> ShowS serializeCommands = unwordsS . fmap serializeCommand serializeCommand :: PathCommand -> ShowS serializeCommand p = case p of MoveTo OriginAbsolute points -> showChar 'M' . serializePoints points MoveTo OriginRelative points -> showChar 'm' . serializePoints points LineTo OriginAbsolute points -> showChar 'L' . serializePoints points LineTo OriginRelative points -> showChar 'l' . serializePoints points HorizontalTo OriginRelative coords -> showChar 'h' . serializeCoords coords HorizontalTo OriginAbsolute coords -> showChar 'H' . serializeCoords coords VerticalTo OriginAbsolute coords -> showChar 'V' . serializeCoords coords VerticalTo OriginRelative coords -> showChar 'v' . serializeCoords coords CurveTo OriginAbsolute triplets -> showChar 'C' . serializePointTriplets triplets CurveTo OriginRelative triplets -> showChar 'c' . serializePointTriplets triplets SmoothCurveTo OriginAbsolute pointPairs -> showChar 'S' . serializePointPairs pointPairs SmoothCurveTo OriginRelative pointPairs -> showChar 's' . serializePointPairs pointPairs QuadraticBezier OriginAbsolute pointPairs -> showChar 'Q' . serializePointPairs pointPairs QuadraticBezier OriginRelative pointPairs -> showChar 'q' . serializePointPairs pointPairs SmoothQuadraticBezierCurveTo OriginAbsolute points -> showChar 'T' . serializePoints points SmoothQuadraticBezierCurveTo OriginRelative points -> showChar 't' . serializePoints points EllipticalArc OriginAbsolute args -> showChar 'A' . serializeArgs args EllipticalArc OriginRelative args -> showChar 'a' . serializeArgs args EndPath -> showChar 'Z' where serializeArg (a, b, c, d, e, V2 x y) = showString $ printf "%s %s %s %d %d %s,%s" (ppD a) (ppD b) (ppD c) (fromEnum d) (fromEnum e) (ppD x) (ppD y) serializeArgs = unwordsS . fmap serializeArg transformParser :: Parser Transformation transformParser = matrixParser <|> translationParser <|> scaleParser <|> rotateParser <|> skewYParser <|> skewXParser functionParser :: T.Text -> Parser [Double] functionParser funcName = string funcName *> skipSpace *> char '(' *> skipSpace *> num `sepBy1` commaWsp <* skipSpace <* char ')' <* skipSpace translationParser :: Parser Transformation translationParser = do args <- functionParser "translate" return $ case args of [x] -> Translate x 0 [x, y] -> Translate x y _ -> TransformUnknown skewXParser :: Parser Transformation skewXParser = do args <- functionParser "skewX" return $ case args of [x] -> SkewX x _ -> TransformUnknown skewYParser :: Parser Transformation skewYParser = do args <- functionParser "skewY" return $ case args of [x] -> SkewY x _ -> TransformUnknown scaleParser :: Parser Transformation scaleParser = do args <- functionParser "scale" return $ case args of [x] -> Scale x Nothing [x, y] -> Scale x (Just y) _ -> TransformUnknown matrixParser :: Parser Transformation matrixParser = do args <- functionParser "matrix" return $ case args of [a, b, c, d, e, f] -> TransformMatrix a b c d e f _ -> TransformUnknown rotateParser :: Parser Transformation rotateParser = do args <- functionParser "rotate" return $ case args of [angle] -> Rotate angle Nothing [angle, x, y] -> Rotate angle $ Just (x, y) _ -> TransformUnknown {- rotate( [ ]), which specifies a rotation by degrees about a given point. If optional parameters and are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0]. If optional parameters and are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(, ) rotate() translate(-, -). skewX(), which specifies a skew transformation along the x-axis. skewY(), which specifies a skew transformation along the y-axis. -} gradientCommand :: Parser GradientPathCommand gradientCommand = (GLine OriginAbsolute <$> (string "L" *> mayPoint)) <|> (GLine OriginRelative <$> (string "l" *> mayPoint)) <|> (string "C" *> curveToArgs OriginAbsolute) <|> (string "c" *> curveToArgs OriginRelative) <|> (GClose <$ string "Z") where mayPoint = option Nothing $ Just <$> point curveToArgs o = GCurve o <$> (point <* commaWsp) <*> (point <* commaWsp) <*> mayPoint serializeGradientCommand :: GradientPathCommand -> ShowS serializeGradientCommand p = case p of GLine OriginAbsolute points -> showChar 'L' . smp points GLine OriginRelative points -> showChar 'l' . smp points GClose -> showChar 'Z' GCurve OriginAbsolute a b c -> showChar 'C' . sp a . sp b . smp c GCurve OriginRelative a b c -> showChar 'c' . sp a . sp b . smp c where sp = serializePoint smp Nothing = id smp (Just pp) = serializePoint pp