FromSVG.hs

{-# LANGUAGE TypeApplications #-}
{-|
Load [SVG Data](https://developer.mozilla.org/en-US/docs/Web/SVG) into `Waterfall.Path2D`
-}
module Waterfall.SVG.FromSVG
( SVGErrorKind (..)
, SVGError (..)
, convertPathCommands
, parsePath
, convertTransform
, convertTree
, convertDocument
, readSVG
) where

import qualified Waterfall
import qualified Data.Attoparsec.Text as Atto
import Graphics.Svg.PathParser (pathParser)
import qualified Graphics.Svg as Svg
import qualified Data.Text as T
import Linear (V3 (..), V2 (..), zero, Metric (norm), normalize, (^*), (*^), _x, _y, unit)
import Control.Lens ((^.), ala, each)
import Data.Monoid (Endo (..))
import Control.Arrow (second)
import Prelude hiding (Foldable(..))
import Data.Foldable (Foldable(..))
import Control.Exception (IOException, try)
import Control.Monad (join, (<=<))
import Data.Bifunctor (first)
import Data.Maybe (catMaybes)
import Data.Function ((&))

-- | Categories of error that may occur when processing an SVG
data SVGErrorKind
    = SVGIOError
    | SVGTreeError
    | SVGParseError
    | SVGPathError
    | SVGTransformError
    | SVGNumberError
    deriving (Eq, Ord, Show)

-- | Type representing an error that occured when processing an SVG
data SVGError = SVGError SVGErrorKind String
        deriving (Eq, Ord, Show)

uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
uncurry6 fn (a, b, c, d, e, f) = fn a b c d e f

pathFromToWithControlPoint :: [Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))] -> V2 Double -> Either SVGError (V2 Double, Waterfall.Path2D)
pathFromToWithControlPoint commands start = 
    let go (cp, (pos, paths)) cmd = second (second (:paths)) <$> cmd cp pos
        go' b a = join (go <$> b <*> pure a)
    in case foldl' go' (Right (Nothing, (start, []))) commands of
        Right (_cp, (end, allPaths)) -> Right (end, mconcat . reverse $ allPaths)
        Left err -> Left err

ellipseToRelative :: Double -> Double -> Double -> Bool -> Bool -> V2 Double -> V2 Double -> (V2 Double, Waterfall.Path2D)
ellipseToRelative rx ry angleDeg largeArcFlag sweepFlag relativeEnd =
    let angleRads = angleDeg * pi / 180
        scaleFac = ry / rx
        transformForward :: Waterfall.Transformable2D a => a -> a
        transformForward = Waterfall.rotate2D (angleRads) . Waterfall.scale2D (V2 (1/scaleFac) 1)
        transformBack :: Waterfall.Transformable2D a => a -> a
        transformBack = Waterfall.scale2D (V2 (scaleFac) 1) . Waterfall.rotate2D (-angleRads)
        relativeEndTransformed@(V2 retX retY) = transformBack relativeEnd
        transformedDistance = norm relativeEndTransformed
        halfTD = transformedDistance * 0.5
        perp = normalize (V2 (-retY) retX)
        p1 = if sweepFlag == largeArcFlag then negate perp else perp
        p2 = if largeArcFlag then p1 else negate p1
        radius = max ry halfTD 
        centerPerpDistance = sqrt (radius * radius - halfTD * halfTD)
        center = (relativeEndTransformed ^* 0.5) + (p1 ^* centerPerpDistance)
        midPoint = center + (p2 ^* radius)
        
        in Waterfall.splice . transformForward $ Waterfall.arcVia zero midPoint relativeEndTransformed 

quadraticBezierAbsolute :: V2 Double -> V2 Double -> V2 Double -> (V2 Double, Waterfall.Path2D)
quadraticBezierAbsolute p0 p1 p2 = (p2, Waterfall.bezier2D p0 (p0 + ((p1 - p0) ^* (2/3))) (p2 + ((p1 - p2) ^* (2/3))) p2)

curveToAbsolute :: (V2 Double, V2 Double, V2 Double) -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
curveToAbsolute (cp1, cp2, cp3) _ cp0 = Right (Just (cp3 + cp3 - cp2), Waterfall.bezierTo2D cp1 cp2 cp3 cp0)

curveToRelative :: (V2 Double, V2 Double, V2 Double) -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
curveToRelative (cp1, cp2, cp3) _ cp0 = curveToAbsolute (cp0 + cp1, cp0 + cp2, cp0 + cp3) Nothing cp0

quadraticBezierAbsolute' :: (V2 Double, V2 Double) -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
quadraticBezierAbsolute' (cp1, cp2) _ cp0 = Right (Just (cp2 + cp2 - cp1), quadraticBezierAbsolute cp0 cp1 cp2)

quadraticBezierRelative' :: (V2 Double, V2 Double) -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
quadraticBezierRelative' (cp1, cp2) _ cp0 = quadraticBezierAbsolute' (cp0 + cp1, cp0 + cp2) Nothing cp0

ellipseToAbsolute :: Double -> Double -> Double -> Bool -> Bool -> V2 Double -> V2 Double -> (V2 Double, Waterfall.Path2D)
ellipseToAbsolute rx ry angleDeg largeArcFlag sweepFlag absoluteEnd start =
    ellipseToRelative rx ry angleDeg largeArcFlag sweepFlag (absoluteEnd - start) start

smoothCurveToAbsolute :: (V2 Double, V2 Double) -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
smoothCurveToAbsolute _ Nothing _ = Left (SVGError SVGPathError "S command must follow either an S, s, C or c command")
smoothCurveToAbsolute (cp2, cp3) (Just cp1) cp0 = Right (Just (cp3 + cp3 - cp2), Waterfall.bezierTo2D cp1 cp2 cp3 cp0) 

smoothCurveToRelative ::  (V2 Double, V2 Double) -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
smoothCurveToRelative _ Nothing _ = Left (SVGError SVGPathError "s command must follow either an S, s, C or c command")
smoothCurveToRelative (cp2, cp3) cp1 cp0 = smoothCurveToAbsolute (cp0 + cp2, cp0 + cp3) cp1 cp0

smoothQuadraticBezierCurveToAbsolute :: V2 Double -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
smoothQuadraticBezierCurveToAbsolute _ Nothing _ = Left (SVGError SVGPathError "T command must follow either an T, t, Q or q command")
smoothQuadraticBezierCurveToAbsolute cp2 (Just cp1) cp0 = Right (Just (cp2 + cp2 - cp1), quadraticBezierAbsolute cp0 cp1 cp2)

smoothQuadraticBezierCurveToRelative :: V2 Double -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
smoothQuadraticBezierCurveToRelative _ Nothing _ = Left (SVGError SVGPathError "t command must follow either an T, t, Q or q command")
smoothQuadraticBezierCurveToRelative cp2 cp1 cp0 = smoothQuadraticBezierCurveToRelative (cp0 + cp2) cp1 cp0

-- | Generate `Waterfall.Path2D`s from a parsed list of `Svg.PathCommand`s.
-- 
-- Consective `Svg.PathCommands` will be merged into the same `Waterfall.Path2D` 
-- unless either a move command ('m', 'M') or a close path command ('z', 'Z') is encountered.
convertPathCommands :: [Svg.PathCommand] -> Either SVGError [Waterfall.Path2D]
convertPathCommands cs =
    let
        relativeLocation _ Svg.OriginAbsolute v = v
        relativeLocation curPos Svg.OriginRelative v = curPos + v
        buildPathInProgress (origin, segments) = 
            pathFromToWithControlPoint segments origin
        withoutControlPoint f _cp o = Right (Nothing, f o)
        go (cmd:rest) pathInProgress@(o, segments) paths = 
            let goSegment ss = go rest (o, segments <> ss) paths  
            in case cmd of
                (Svg.MoveTo origin (v:vs)) ->
                    let restPlusImplicitLineTo =
                            case vs of
                                [] -> rest
                                implicitLineTos -> Svg.LineTo origin implicitLineTos : rest
                    in if null segments
                        then go restPlusImplicitLineTo (relativeLocation o origin v, []) paths
                        else case buildPathInProgress pathInProgress of
                            Right (currentPosition, newPath) ->  go restPlusImplicitLineTo (relativeLocation currentPosition origin v, []) (newPath : paths)
                            Left err -> Left err
                (Svg.MoveTo _ []) -> Left (SVGError SVGPathError "Empty MoveTo command")
                (Svg.LineTo Svg.OriginAbsolute vs) -> goSegment (withoutControlPoint . Waterfall.lineTo2D <$> vs )
                (Svg.LineTo Svg.OriginRelative vs) -> goSegment (withoutControlPoint . Waterfall.lineRelative2D <$> vs)
                (Svg.HorizontalTo Svg.OriginAbsolute ds) -> 
                    let f d v@(V2 _x y) = let v' = V2 d y in (v', Waterfall.line2D v v')
                        in goSegment (withoutControlPoint . f <$> ds) 
                (Svg.HorizontalTo Svg.OriginRelative ds) -> 
                    let f d v = let v' = v + V2 d 0 in (v', Waterfall.line2D v v')
                    in goSegment (withoutControlPoint . f <$> ds)
                (Svg.VerticalTo Svg.OriginAbsolute ds) -> 
                    let f d v@(V2 x _y) = let v' = V2 x d in (v', Waterfall.line2D v v')
                     in goSegment (withoutControlPoint . f <$> ds) 
                (Svg.VerticalTo Svg.OriginRelative ds) -> 
                    let f d v = let v' = v + V2 0 d in (v', Waterfall.line2D v v')
                     in goSegment (withoutControlPoint . f <$> ds) 
                (Svg.CurveTo Svg.OriginAbsolute points) -> goSegment (curveToAbsolute <$> points)
                (Svg.CurveTo Svg.OriginRelative points) -> goSegment (curveToRelative <$> points)
                (Svg.EllipticalArc Svg.OriginAbsolute points) -> goSegment (withoutControlPoint . uncurry6 ellipseToAbsolute <$> points)
                (Svg.EllipticalArc Svg.OriginRelative points) -> goSegment (withoutControlPoint . uncurry6 ellipseToRelative <$> points)
                Svg.QuadraticBezier Svg.OriginAbsolute points -> goSegment (quadraticBezierAbsolute' <$> points)
                Svg.QuadraticBezier Svg.OriginRelative points -> goSegment (quadraticBezierRelative' <$> points)
                Svg.SmoothCurveTo Svg.OriginAbsolute points -> goSegment (smoothCurveToAbsolute <$> points)
                Svg.SmoothCurveTo Svg.OriginRelative points -> goSegment (smoothCurveToRelative <$> points)
                Svg.SmoothQuadraticBezierCurveTo Svg.OriginAbsolute points -> goSegment (smoothQuadraticBezierCurveToAbsolute <$> points)
                Svg.SmoothQuadraticBezierCurveTo Svg.OriginRelative points -> goSegment (smoothQuadraticBezierCurveToRelative <$> points)
                Svg.EndPath -> 
                    if null segments 
                        then go rest (o, []) paths
                        else case buildPathInProgress pathInProgress of
                                 Right (_, newPath) -> go rest (o, []) (Waterfall.closeLoop newPath : paths)
                                 Left err -> Left err
        go [] pathInProgress@(_o, segments) paths = 
            if null segments 
                then Right paths
                else (:paths) . snd <$> buildPathInProgress pathInProgress
    in reverse <$> go cs (zero, []) []

-- | Parse [SVG Path data](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths) 
-- and convert it into a `Path2D`
parsePath :: String -> Either SVGError [Waterfall.Path2D]
parsePath s =
    case Atto.parseOnly (pathParser <* Atto.endOfInput) (T.pack s) of 
        Right r -> convertPathCommands r
        Left msg -> Left (SVGError SVGParseError msg)

-- | Parse a `Svg.Transformation` into a function that can be applied to 
-- any Waterfall type with a `Waterfall.Transformable2D` instance
-- 
-- This should handle every case except for `TransformUnknown`
convertTransform :: Waterfall.Transformable2D a => Svg.Transformation -> Either SVGError (a -> a)
convertTransform (Svg.TransformMatrix a b c d e f) = Right $ Waterfall.matTransform2D (V2 (V3 a c e) (V3 b d f))
convertTransform (Svg.Translate x y) = Right $ Waterfall.translate2D (V2 x y)
convertTransform (Svg.Scale v Nothing) = Right $ Waterfall.uScale2D v
convertTransform (Svg.Scale x (Just y)) = Right $ Waterfall.scale2D (V2 x y)
convertTransform (Svg.Rotate angleDeg center) = 
    let center' = maybe zero (uncurry V2) center 
        fwd = Waterfall.translate2D (negate center')
        angleRad = angleDeg * pi / 180
        back = Waterfall.translate2D center'
     in Right (back . Waterfall.rotate2D angleRad . fwd)
convertTransform (Svg.SkewX x) = Right $ Waterfall.matTransform2D (V2 (V3 x 0 0) (V3 0 1 0))
convertTransform (Svg.SkewY y) = Right $ Waterfall.matTransform2D (V2 (V3 1 0 0) (V3 0 y 0))
convertTransform Svg.TransformUnknown = Left . (SVGError SVGTransformError) $ "Unknown Transform"

chain :: [a -> a] -> a -> a
chain = ala Endo foldMap

svgDPI :: Svg.Dpi
svgDPI = 300

convertNumber :: Svg.Number -> Either SVGError Double
convertNumber n = 
    -- toUserUnit should guarantee we either get a Num, Em, or Percent value here
    -- of which only Num is supported
    case Svg.toUserUnit svgDPI n of 
        Svg.Num v -> Right v
        Svg.Px _ -> Left (SVGError SVGNumberError "Unexpected Px value")
        Svg.Em _ -> Left (SVGError SVGNumberError "Unsupported Em value")
        Svg.Percent _ -> Left (SVGError SVGNumberError "Unsupported Percent value")
        Svg.Pc _ ->  Left (SVGError SVGNumberError "Unexpected Pc value")
        Svg.Inches _ -> Left (SVGError SVGNumberError "Unexpected Inches value")
        Svg.Mm _ -> Left (SVGError SVGNumberError "Unexpected Mm value")
        Svg.Cm _ -> Left (SVGError SVGNumberError "Unexpected Cm value")
        Svg.Point _ -> Left (SVGError SVGNumberError "Unexpected Point value")


convertPoint :: Svg.Point -> Either SVGError (V2 Double)
convertPoint = fmap (uncurry V2) . each convertNumber 

convertCircle :: Svg.Circle -> Either SVGError [Waterfall.Path2D]
convertCircle circle = do 
    center <- convertPoint (circle ^. Svg.circleCenter)
    radius <- circle ^. Svg.circleRadius & convertNumber
    return
        . fmap (Waterfall.translate2D center . Waterfall.uScale2D radius)
        . Waterfall.shapePaths 
        $ Waterfall.unitCircle

convertPoints :: [Svg.RPoint] -> [Waterfall.Path2D]
convertPoints (h:t) = pure $ Waterfall.pathFrom h (Waterfall.lineTo <$> t)
convertPoints [] = []

convertPolyLine  :: Svg.PolyLine -> [Waterfall.Path2D]
convertPolyLine polyLine = convertPoints (polyLine ^. Svg.polyLinePoints)

wrap :: [a] -> [a]
wrap (h:t) = h:t <> [h] 
wrap [] = []

convertPolygon  :: Svg.Polygon -> [Waterfall.Path2D]
convertPolygon polygon = convertPoints (polygon ^. Svg.polygonPoints & wrap)

convertLine :: Svg.Line -> Either SVGError Waterfall.Path2D
convertLine line = 
    Waterfall.line 
        <$> convertPoint (line ^. Svg.linePoint1)
        <*> convertPoint (line ^. Svg.linePoint2)
        
convertEllipse :: Svg.Ellipse -> Either SVGError [Waterfall.Path2D]
convertEllipse ellipse = do 
    center <- convertPoint (ellipse ^. Svg.ellipseCenter)
    rX <- ellipse ^. Svg.ellipseXRadius & convertNumber
    rY <- ellipse ^. Svg.ellipseYRadius & convertNumber
    return 
        . fmap (Waterfall.translate2D center . Waterfall.scale2D (V2 rX rY))
        . Waterfall.shapePaths
        $ Waterfall.unitCircle

convertRectangle :: Svg.Rectangle -> Either SVGError [Waterfall.Path2D]
convertRectangle rect = do
    upperLeft <- convertPoint (rect ^. Svg.rectUpperLeftCorner)    
    (rX', rY') <- each convertNumber (rect ^. Svg.rectCornerRadius)
    w <- convertNumber (rect ^. Svg.rectWidth)
    h <- convertNumber (rect ^. Svg.rectHeight)
    let rX = min rX' (w/2)
    let rY = min rY' (h/2)
    let w' = w - 2 * rX
    let h' = h - 2 * rY
    let quarterCircle = Waterfall.arcVia (negate $ unit _y) (normalize (V2 1 (-1))) (unit _x)
    let scaleBevel = Waterfall.scale2D (V2 rX rY)
    if rX == 0 || rY == 0 
        then Waterfall.unitSquare &
                Waterfall.scale2D (V2 w h) &
                Waterfall.translate2D upperLeft &
                Waterfall.shapePaths & 
                return
        else return . pure . Waterfall.pathFrom (V2 rX 0) . catMaybes $
                [ if w' > 0 then Just (Waterfall.lineRelative (w' *^ unit _x)) else Nothing
                , quarterCircle 
                    & scaleBevel 
                    & Waterfall.splice
                    & pure
                , if h' > 0 then Just (Waterfall.lineRelative (h' *^ unit _y)) else Nothing
                , quarterCircle 
                    & Waterfall.rotate2D (pi/2)
                    & scaleBevel 
                    & Waterfall.splice
                    & pure
                , if w' > 0 then Just (Waterfall.lineRelative (negate (w' *^ unit _x))) else Nothing
                , quarterCircle 
                    & Waterfall.rotate2D pi
                    & scaleBevel 
                    & Waterfall.splice
                    & pure
                , if h' > 0 then Just (Waterfall.lineRelative (negate (h' *^ unit _y))) else Nothing
                , quarterCircle 
                    & Waterfall.rotate2D (-pi/2)
                    & scaleBevel 
                    & Waterfall.splice
                    & pure
                ]

-- | Recursively convert an `Svg.Tree` into a list of `Waterfall.Path2D`s
--
-- Text elements are not supported
convertTree :: Svg.Tree -> Either SVGError [Waterfall.Path2D]
convertTree tree = do
    transform <- maybe (pure id) (fmap chain . traverse convertTransform) (tree ^. Svg.drawAttr . Svg.drawAttributes . Svg.transform)
    fmap transform <$> case tree of
        Svg.PathTree path -> convertPathCommands (path ^. Svg.pathDefinition)
        Svg.GroupTree group ->  mconcat <$> traverse convertTree (group ^. Svg.groupChildren)
        Svg.SymbolTree sym ->  mconcat <$> traverse convertTree (sym ^. Svg.groupOfSymbol . Svg.groupChildren)
        Svg.CircleTree circle -> convertCircle circle
        Svg.PolyLineTree polyLine -> pure $ convertPolyLine polyLine
        Svg.PolygonTree polygon -> pure $ convertPolygon polygon
        Svg.LineTree line -> pure <$> convertLine line
        Svg.EllipseTree ellipse -> convertEllipse ellipse
        Svg.RectangleTree rectangle -> convertRectangle rectangle
        _ -> Right []

-- | Convert an `Svg.Document` into a list of `Path2Ds`
convertDocument :: Svg.Document -> Either SVGError [Waterfall.Path2D]
convertDocument doc = fmap mconcat . traverse convertTree $ (doc ^. Svg.elements) 

-- | Load an SVG file into a `Waterfall.Path2D`
readSVG :: FilePath -> IO (Either SVGError [Waterfall.Path2D])
readSVG path =
    let fileReadErr = Left . SVGError SVGTreeError $ "Failed to parse svg tree in file: " <> path
        fileOpenErr = SVGError SVGIOError . show @IOException
    in (convertDocument <=< maybe fileReadErr Right <=< first fileOpenErr)
        <$> try (Svg.loadSvgFile path)