Parser.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RebindableSyntax #-}
{-# OPTIONS_GHC -Wall #-}

-- | SVG path manipulation
module Data.Path.Parser
  ( -- * Parsing
    -- $parsing
    parsePath,
    svgToPathData,
    pathDataToSvg,
    PathCommand (..),
    Origin (..),
  )
where

import Chart.Data
import Control.Applicative
import Control.Monad.State.Lazy
import qualified Data.Attoparsec.Text as A
import Data.Either
import Data.FormatN
import Data.Functor
import Data.Path (ArcInfo (ArcInfo), PathData (..))
import Data.Scientific (toRealFloat)
import Data.Text (Text, pack)
import qualified Data.Text as Text
import GHC.Generics
import GHC.OverloadedLabels
import NumHask.Prelude
import Optics.Core hiding ((<|))

-- import qualified Data.List as List

-- $parsing
-- Every element of an svg path can be thought of as exactly two points in space, with instructions of how to draw a curve between them.  From this point of view, one which this library adopts, a path chart is thus very similar to a line chart.  There's just a lot more information about the style of this line to deal with.
--
-- References:
--
-- [SVG d attribute](https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d)
--
-- [SVG Paths](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths)

-- | Parse a raw path string.
--
-- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z"
-- >>> parsePath outerseg1
-- Right [MoveTo OriginAbsolute [Point -1.0 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 -1.2320508075688774),(1.0,1.0,0.0,False,False,Point -0.5 -0.3660254037844387),(1.0,1.0,0.0,False,False,Point -1.0 0.5)],EndPath]
parsePath :: Text -> Either String [PathCommand]
parsePath = A.parseOnly pathParser

commaWsp :: A.Parser ()
commaWsp = A.skipSpace *> A.option () (A.string "," $> ()) <* A.skipSpace

point :: A.Parser (Point Double)
point = Point <$> num <* commaWsp <*> num

points :: A.Parser [Point Double]
points = fromList <$> point `A.sepBy1` commaWsp

pointPair :: A.Parser (Point Double, Point Double)
pointPair = (,) <$> point <* commaWsp <*> point

pointPairs :: A.Parser [(Point Double, Point Double)]
pointPairs = fromList <$> pointPair `A.sepBy1` commaWsp

pathParser :: A.Parser [PathCommand]
pathParser = fromList <$> (A.skipSpace *> A.many1 command)

num :: A.Parser Double
num = realToFrac <$> (A.skipSpace *> plusMinus <* A.skipSpace)
  where
    doubleNumber :: A.Parser Double
    doubleNumber = toRealFloat <$> A.scientific <|> shorthand

    plusMinus =
      negate <$ A.string "-" <*> doubleNumber
        <|> A.string "+" *> doubleNumber
        <|> doubleNumber

    shorthand = process' <$> (A.string "." *> A.many1 A.digit)
    process' = fromRight 0 . A.parseOnly doubleNumber . pack . (++) "0."

nums :: A.Parser [Double]
nums = num `A.sepBy1` commaWsp

flag :: A.Parser Bool
flag = fmap (/= '0') A.digit

command :: A.Parser PathCommand
command =
  MoveTo OriginAbsolute <$ A.string "M" <*> points
    <|> MoveTo OriginRelative <$ A.string "m" <*> points
    <|> LineTo OriginAbsolute <$ A.string "L" <*> points
    <|> LineTo OriginRelative <$ A.string "l" <*> points
    <|> HorizontalTo OriginAbsolute <$ A.string "H" <*> nums
    <|> HorizontalTo OriginRelative <$ A.string "h" <*> nums
    <|> VerticalTo OriginAbsolute <$ A.string "V" <*> nums
    <|> VerticalTo OriginRelative <$ A.string "v" <*> nums
    <|> CurveTo OriginAbsolute <$ A.string "C" <*> fmap fromList (manyComma curveToArgs)
    <|> CurveTo OriginRelative <$ A.string "c" <*> fmap fromList (manyComma curveToArgs)
    <|> SmoothCurveTo OriginAbsolute <$ A.string "S" <*> pointPairs
    <|> SmoothCurveTo OriginRelative <$ A.string "s" <*> pointPairs
    <|> QuadraticBezier OriginAbsolute <$ A.string "Q" <*> pointPairs
    <|> QuadraticBezier OriginRelative <$ A.string "q" <*> pointPairs
    <|> SmoothQuadraticBezierCurveTo OriginAbsolute <$ A.string "T" <*> points
    <|> SmoothQuadraticBezierCurveTo OriginRelative <$ A.string "t" <*> points
    <|> EllipticalArc OriginAbsolute <$ A.string "A" <*> manyComma ellipticalArgs
    <|> EllipticalArc OriginRelative <$ A.string "a" <*> manyComma ellipticalArgs
    <|> EndPath <$ A.string "Z" <* commaWsp
    <|> EndPath <$ A.string "z" <* commaWsp
  where
    curveToArgs =
      (,,)
        <$> (point <* commaWsp)
        <*> (point <* commaWsp)
        <*> point
    manyComma a = fromList <$> a `A.sepBy1` commaWsp

    numComma = num <* commaWsp
    flagComma = flag <* commaWsp
    ellipticalArgs =
      (,,,,,)
        <$> numComma
        <*> numComma
        <*> numComma
        <*> flagComma
        <*> flagComma
        <*> point

-- | Path command definition (ripped from reanimate-svg).
data PathCommand
  = -- | M or m command
    MoveTo !Origin ![Point Double]
  | -- | Line to, L or l Svg path command.
    LineTo !Origin ![Point Double]
  | -- | Equivalent to the H or h svg path command.
    HorizontalTo !Origin ![Double]
  | -- | Equivalent to the V or v svg path command.
    VerticalTo !Origin ![Double]
  | -- | Cubic bezier, C or c command
    CurveTo !Origin ![(Point Double, Point Double, Point Double)]
  | -- | Smooth cubic bezier, equivalent to S or s command
    SmoothCurveTo !Origin ![(Point Double, Point Double)]
  | -- | Quadratic bezier, Q or q command
    QuadraticBezier !Origin ![(Point Double, Point Double)]
  | -- | Quadratic bezier, T or t command
    SmoothQuadraticBezierCurveTo !Origin ![Point Double]
  | -- | Elliptical arc, A or a command.
    EllipticalArc !Origin ![(Double, Double, Double, Bool, Bool, Point Double)]
  | -- | Close the path, Z or z svg path command.
    EndPath
  deriving (Eq, Show, Generic)

-- | Tell if a path command is absolute (in the current
-- user coordiante) or relative to the previous point.
data Origin
  = -- | Next point in absolute coordinate
    OriginAbsolute
  | -- | Next point relative to the previous
    OriginRelative
  deriving (Eq, Show, Generic)

pointToSvgCoords :: Point Double -> Point Double
pointToSvgCoords (Point x y) = Point x (-y)

svgCoords :: PathData Double -> PathData Double
svgCoords (CubicP a b p) = CubicP (pointToSvgCoords a) (pointToSvgCoords b) (pointToSvgCoords p)
svgCoords (QuadP a p) = QuadP (pointToSvgCoords a) (pointToSvgCoords p)
svgCoords (StartP p) = StartP (pointToSvgCoords p)
svgCoords (LineP p) = LineP (pointToSvgCoords p)
svgCoords (ArcP i p) = ArcP i (pointToSvgCoords p)

-- | Convert from a path info, start point, end point triple to a path text clause.
--
-- Note that morally,
--
-- > toPathsAbsolute . toPathDatas . parsePath == id
--
-- but the round trip destroys much information, including:
--
-- - path text spacing
--
-- - "Z", which is replaced by a LineI instruction from the end point back to the original start of the path.
--
-- - Sequences of the same instruction type are uncompressed
--
-- - As the name suggests, relative paths are translated to absolute ones.
--
-- - implicit L's in multiple M instructions are separated.
--
-- In converting between chart-svg and SVG there are two changes in reference:
--
-- - arc rotation is expressed as positive degrees for a clockwise rotation in SVG, and counter-clockwise in radians for chart-svg
--
-- - A positive y-direction is down for SVG and up for chart-svg
toPathAbsolute ::
  PathData Double ->
  -- | path text
  Text
toPathAbsolute (StartP p) = "M " <> pp p
toPathAbsolute (LineP p) = "L " <> pp p
toPathAbsolute (CubicP c1 c2 p) =
  "C "
    <> pp c1
    <> " "
    <> pp c2
    <> " "
    <> pp p
toPathAbsolute (QuadP control p) =
  "Q "
    <> pp control
    <> " "
    <> pp p
toPathAbsolute (ArcP (ArcInfo (Point x y) phi' l sw) x2) =
  "A "
    <> (pack . show) x
    <> " "
    <> (pack . show) y
    <> " "
    <> (pack . show) (-phi' * 180 / pi)
    <> " "
    <> bool "0" "1" l
    <> " "
    <> bool "0" "1" sw
    <> " "
    <> pp x2

-- | Render a point (including conversion to SVG Coordinates).
pp :: Point Double -> Text
pp (Point x y) =
  formatOrShow (FixedStyle 4) Nothing x
    <> ","
    <> formatOrShow (FixedStyle 4) Nothing (bool (-y) y (y == zero))

data PathCursor = PathCursor
  { -- | previous position
    curPrevious :: Point Double,
    -- | start point (to close out the path)
    curStart :: Point Double,
    -- | last control point
    curControl :: Maybe (Point Double)
  }
  deriving (Eq, Show, Generic)

stateCur0 :: PathCursor
stateCur0 = PathCursor zero zero Nothing

-- | Convert from an SVG d attribute text snippet to a [`PathData` `Double`]
svgToPathData :: Text -> [PathData Double]
svgToPathData = toPathDatas . either error id . parsePath

-- | Convert from [`PathData` `Double`] to an SVG d path text snippet.
pathDataToSvg :: [PathData Double] -> Text
pathDataToSvg xs = Text.intercalate " " $ fmap toPathAbsolute xs

-- | Convert from a path command list to a PathA specification
toPathDatas :: [PathCommand] -> [PathData Double]
toPathDatas xs = fmap svgCoords $ mconcat $ flip evalState stateCur0 $ mapM toPathData xs

-- | Convert relative points to absolute points
relToAbs :: (Additive a) => a -> [a] -> [a]
relToAbs p xs = accsum (p : xs)

moveTo :: [Point Double] -> State PathCursor [PathData Double]
moveTo xs = do
  put (PathCursor (last xs) (head xs) Nothing)
  pure (StartP (head xs) : (LineP <$> tail xs))

lineTo :: [Point Double] -> State PathCursor [PathData Double]
lineTo xs = do
  modify ((#curPrevious .~ last xs) . (#curControl .~ Nothing))
  pure $ LineP <$> xs

horTo :: [Double] -> State PathCursor [PathData Double]
horTo xs = do
  (PathCursor (Point _ y) _ _) <- get
  lineTo (fmap (`Point` y) xs)

verTo :: [Double] -> State PathCursor [PathData Double]
verTo ys = do
  (PathCursor (Point x _) _ _) <- get
  lineTo (fmap (Point x) ys)

curveTo :: [(Point Double, Point Double, Point Double)] -> State PathCursor [PathData Double]
curveTo xs = do
  modify
    ( (#curPrevious .~ (\(_, _, p) -> p) (last xs))
        . (#curControl ?~ (\(_, c2, _) -> c2) (last xs))
    )
  pure $ (\(c1, c2, x2) -> CubicP c1 c2 x2) <$> xs

-- | Convert relative points to absolute points
relToAbs3 :: (Additive a) => a -> [(a, a, a)] -> [(a, a, a)]
relToAbs3 p xs = xs'
  where
    x1 = (\(x, _, _) -> x) <$> xs
    x2 = (\(_, x, _) -> x) <$> xs
    x3 = (\(_, _, x) -> x) <$> xs
    x1' = fmap (p +) (accsum x1)
    x2' = fmap (p +) (accsum x2)
    x3' = fmap (p +) (accsum x3)
    xs' = zip3 x1' x2' x3'

reflControlPoint :: State PathCursor (Point Double)
reflControlPoint = do
  (PathCursor p _ c) <- get
  case c of
    Nothing -> pure p
    Just c' -> pure (p - (c' - p))

smoothCurveToStep :: (Point Double, Point Double) -> State PathCursor (PathData Double)
smoothCurveToStep (c2, x2) = do
  c1 <- reflControlPoint
  modify ((#curControl ?~ c2) . (#curPrevious .~ x2))
  pure (CubicP c1 c2 x2)

smoothCurveTo :: [(Point Double, Point Double)] -> State PathCursor [PathData Double]
smoothCurveTo xs =
  mapM smoothCurveToStep xs

-- | Convert relative points to absolute points
relToAbs2 :: (Additive a) => a -> [(a, a)] -> [(a, a)]
relToAbs2 p xs = xs'
  where
    x1 = fst <$> xs
    x2 = snd <$> xs
    x1' = fmap (p +) (accsum x1)
    x2' = fmap (p +) (accsum x2)
    xs' = zip x1' x2'

quad :: [(Point Double, Point Double)] -> State PathCursor [PathData Double]
quad xs = do
  modify
    ( (#curPrevious .~ snd (last xs))
        . (#curControl ?~ fst (last xs))
    )
  pure $ uncurry QuadP <$> xs

smoothQuadStep :: Point Double -> State PathCursor (PathData Double)
smoothQuadStep x2 = do
  c1 <- reflControlPoint
  modify ((#curControl ?~ c1) . (#curPrevious .~ x2))
  pure (QuadP c1 x2)

smoothQuad :: [Point Double] -> State PathCursor [PathData Double]
smoothQuad xs =
  mapM smoothQuadStep xs

arcTo :: [(Double, Double, Double, Bool, Bool, Point Double)] -> State PathCursor [PathData Double]
arcTo xs = do
  modify ((#curPrevious .~ (\(_, _, _, _, _, p) -> p) (last xs)) . (#curControl .~ Nothing))
  pure $ fromPathEllipticalArc <$> xs

fromPathEllipticalArc :: (a, a, a, Bool, Bool, Point a) -> PathData a
fromPathEllipticalArc (x, y, r, l, s, p) = ArcP (ArcInfo (Point x y) r l s) p

-- | Convert relative points to absolute points
relToAbsArc :: (Additive a) => Point a -> [(a, a, a, Bool, Bool, Point a)] -> [(a, a, a, Bool, Bool, Point a)]
relToAbsArc p xs = xs'
  where
    ps = (\(_, _, _, _, _, pt) -> pt) <$> xs
    ps' = fmap (p +) (accsum ps)
    xs' = zipWith (\(x0, x1, x2, x3, x4, _) pt -> (x0, x1, x2, x3, x4, pt)) xs ps'

-- | Convert a path command fragment to PathData
--
-- flips the y-dimension of points.
toPathData :: PathCommand -> State PathCursor [PathData Double]
toPathData (MoveTo OriginAbsolute xs) = moveTo xs
toPathData (MoveTo OriginRelative xs) = do
  (PathCursor p _ _) <- get
  moveTo (relToAbs p xs)
toPathData EndPath = do
  (PathCursor _ s _) <- get
  pure [LineP s]
toPathData (LineTo OriginAbsolute xs) = lineTo xs
toPathData (LineTo OriginRelative xs) = do
  (PathCursor p _ _) <- get
  lineTo (relToAbs p xs)
toPathData (HorizontalTo OriginAbsolute xs) = horTo xs
toPathData (HorizontalTo OriginRelative xs) = do
  (PathCursor (Point x _) _ _) <- get
  horTo (relToAbs x xs)
toPathData (VerticalTo OriginAbsolute xs) = verTo xs
toPathData (VerticalTo OriginRelative ys) = do
  (PathCursor (Point _ y) _ _) <- get
  verTo (relToAbs y ys)
toPathData (CurveTo OriginAbsolute xs) = curveTo xs
toPathData (CurveTo OriginRelative xs) = do
  (PathCursor p _ _) <- get
  curveTo (relToAbs3 p xs)
toPathData (SmoothCurveTo OriginAbsolute xs) = smoothCurveTo xs
toPathData (SmoothCurveTo OriginRelative xs) = do
  (PathCursor p _ _) <- get
  smoothCurveTo (relToAbs2 p xs)
toPathData (QuadraticBezier OriginAbsolute xs) = quad xs
toPathData (QuadraticBezier OriginRelative xs) = do
  (PathCursor p _ _) <- get
  quad (relToAbs2 p xs)
toPathData (SmoothQuadraticBezierCurveTo OriginAbsolute xs) = smoothQuad xs
toPathData (SmoothQuadraticBezierCurveTo OriginRelative xs) = do
  (PathCursor p _ _) <- get
  smoothQuad (relToAbs p xs)
toPathData (EllipticalArc OriginAbsolute xs) = arcTo xs
toPathData (EllipticalArc OriginRelative xs) = do
  (PathCursor p _ _) <- get
  arcTo (relToAbsArc p xs)