{-|
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 Data.Foldable (foldl')
import Control.Monad (join, (<=<))
import Data.Maybe (catMaybes)
import Data.Function ((&))

-- | Categories of error that may occur when processing an SVG
data SVGErrorKind = SVGIOError | SVGParseError | SVGPathError | SVGTransformError | SVGNumberError
    deriving (SVGErrorKind -> SVGErrorKind -> Bool
(SVGErrorKind -> SVGErrorKind -> Bool)
-> (SVGErrorKind -> SVGErrorKind -> Bool) -> Eq SVGErrorKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SVGErrorKind -> SVGErrorKind -> Bool
== :: SVGErrorKind -> SVGErrorKind -> Bool
$c/= :: SVGErrorKind -> SVGErrorKind -> Bool
/= :: SVGErrorKind -> SVGErrorKind -> Bool
Eq, Eq SVGErrorKind
Eq SVGErrorKind =>
(SVGErrorKind -> SVGErrorKind -> Ordering)
-> (SVGErrorKind -> SVGErrorKind -> Bool)
-> (SVGErrorKind -> SVGErrorKind -> Bool)
-> (SVGErrorKind -> SVGErrorKind -> Bool)
-> (SVGErrorKind -> SVGErrorKind -> Bool)
-> (SVGErrorKind -> SVGErrorKind -> SVGErrorKind)
-> (SVGErrorKind -> SVGErrorKind -> SVGErrorKind)
-> Ord SVGErrorKind
SVGErrorKind -> SVGErrorKind -> Bool
SVGErrorKind -> SVGErrorKind -> Ordering
SVGErrorKind -> SVGErrorKind -> SVGErrorKind
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SVGErrorKind -> SVGErrorKind -> Ordering
compare :: SVGErrorKind -> SVGErrorKind -> Ordering
$c< :: SVGErrorKind -> SVGErrorKind -> Bool
< :: SVGErrorKind -> SVGErrorKind -> Bool
$c<= :: SVGErrorKind -> SVGErrorKind -> Bool
<= :: SVGErrorKind -> SVGErrorKind -> Bool
$c> :: SVGErrorKind -> SVGErrorKind -> Bool
> :: SVGErrorKind -> SVGErrorKind -> Bool
$c>= :: SVGErrorKind -> SVGErrorKind -> Bool
>= :: SVGErrorKind -> SVGErrorKind -> Bool
$cmax :: SVGErrorKind -> SVGErrorKind -> SVGErrorKind
max :: SVGErrorKind -> SVGErrorKind -> SVGErrorKind
$cmin :: SVGErrorKind -> SVGErrorKind -> SVGErrorKind
min :: SVGErrorKind -> SVGErrorKind -> SVGErrorKind
Ord, Int -> SVGErrorKind -> ShowS
[SVGErrorKind] -> ShowS
SVGErrorKind -> String
(Int -> SVGErrorKind -> ShowS)
-> (SVGErrorKind -> String)
-> ([SVGErrorKind] -> ShowS)
-> Show SVGErrorKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SVGErrorKind -> ShowS
showsPrec :: Int -> SVGErrorKind -> ShowS
$cshow :: SVGErrorKind -> String
show :: SVGErrorKind -> String
$cshowList :: [SVGErrorKind] -> ShowS
showList :: [SVGErrorKind] -> ShowS
Show)

-- | Type representing an error that occured when processing an SVG
data SVGError = SVGError SVGErrorKind String
        deriving (SVGError -> SVGError -> Bool
(SVGError -> SVGError -> Bool)
-> (SVGError -> SVGError -> Bool) -> Eq SVGError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SVGError -> SVGError -> Bool
== :: SVGError -> SVGError -> Bool
$c/= :: SVGError -> SVGError -> Bool
/= :: SVGError -> SVGError -> Bool
Eq, Eq SVGError
Eq SVGError =>
(SVGError -> SVGError -> Ordering)
-> (SVGError -> SVGError -> Bool)
-> (SVGError -> SVGError -> Bool)
-> (SVGError -> SVGError -> Bool)
-> (SVGError -> SVGError -> Bool)
-> (SVGError -> SVGError -> SVGError)
-> (SVGError -> SVGError -> SVGError)
-> Ord SVGError
SVGError -> SVGError -> Bool
SVGError -> SVGError -> Ordering
SVGError -> SVGError -> SVGError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SVGError -> SVGError -> Ordering
compare :: SVGError -> SVGError -> Ordering
$c< :: SVGError -> SVGError -> Bool
< :: SVGError -> SVGError -> Bool
$c<= :: SVGError -> SVGError -> Bool
<= :: SVGError -> SVGError -> Bool
$c> :: SVGError -> SVGError -> Bool
> :: SVGError -> SVGError -> Bool
$c>= :: SVGError -> SVGError -> Bool
>= :: SVGError -> SVGError -> Bool
$cmax :: SVGError -> SVGError -> SVGError
max :: SVGError -> SVGError -> SVGError
$cmin :: SVGError -> SVGError -> SVGError
min :: SVGError -> SVGError -> SVGError
Ord, Int -> SVGError -> ShowS
[SVGError] -> ShowS
SVGError -> String
(Int -> SVGError -> ShowS)
-> (SVGError -> String) -> ([SVGError] -> ShowS) -> Show SVGError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SVGError -> ShowS
showsPrec :: Int -> SVGError -> ShowS
$cshow :: SVGError -> String
show :: SVGError -> String
$cshowList :: [SVGError] -> ShowS
showList :: [SVGError] -> ShowS
Show)

uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
uncurry6 :: forall a b c d e f g.
(a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
uncurry6 a -> b -> c -> d -> e -> f -> g
fn (a
a, b
b, c
c, d
d, e
e, f
f) = a -> b -> c -> d -> e -> f -> g
fn a
a b
b c
c d
d e
e f
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 :: [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> RPoint -> Either SVGError (RPoint, Path2D)
pathFromToWithControlPoint [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
commands RPoint
start = 
    let go :: (t, (t, [b])) -> (t -> t -> f (d, (d, b))) -> f (d, (d, [b]))
go (t
cp, (t
pos, [b]
paths)) t -> t -> f (d, (d, b))
cmd = ((d, b) -> (d, [b])) -> (d, (d, b)) -> (d, (d, [b]))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((b -> [b]) -> (d, b) -> (d, [b])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
paths)) ((d, (d, b)) -> (d, (d, [b]))) -> f (d, (d, b)) -> f (d, (d, [b]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> f (d, (d, b))
cmd t
cp t
pos
        go' :: m (t, (t, [b])) -> (t -> t -> m (d, (d, b))) -> m (d, (d, [b]))
go' m (t, (t, [b]))
b t -> t -> m (d, (d, b))
a = m (m (d, (d, [b]))) -> m (d, (d, [b]))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ((t, (t, [b])) -> (t -> t -> m (d, (d, b))) -> m (d, (d, [b]))
forall {f :: * -> *} {t} {t} {b} {d} {d}.
Functor f =>
(t, (t, [b])) -> (t -> t -> f (d, (d, b))) -> f (d, (d, [b]))
go ((t, (t, [b])) -> (t -> t -> m (d, (d, b))) -> m (d, (d, [b])))
-> m (t, (t, [b]))
-> m ((t -> t -> m (d, (d, b))) -> m (d, (d, [b])))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (t, (t, [b]))
b m ((t -> t -> m (d, (d, b))) -> m (d, (d, [b])))
-> m (t -> t -> m (d, (d, b))) -> m (m (d, (d, [b])))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (t -> t -> m (d, (d, b))) -> m (t -> t -> m (d, (d, b)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t -> t -> m (d, (d, b))
a)
    in case (Either SVGError (Maybe RPoint, (RPoint, [Path2D]))
 -> (Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
 -> Either SVGError (Maybe RPoint, (RPoint, [Path2D])))
-> Either SVGError (Maybe RPoint, (RPoint, [Path2D]))
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError (Maybe RPoint, (RPoint, [Path2D]))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either SVGError (Maybe RPoint, (RPoint, [Path2D]))
-> (Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> Either SVGError (Maybe RPoint, (RPoint, [Path2D]))
forall {m :: * -> *} {t} {t} {b} {d} {d}.
Monad m =>
m (t, (t, [b])) -> (t -> t -> m (d, (d, b))) -> m (d, (d, [b]))
go' ((Maybe RPoint, (RPoint, [Path2D]))
-> Either SVGError (Maybe RPoint, (RPoint, [Path2D]))
forall a b. b -> Either a b
Right (Maybe RPoint
forall a. Maybe a
Nothing, (RPoint
start, []))) [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
commands of
        Right (Maybe RPoint
_cp, (RPoint
end, [Path2D]
allPaths)) -> (RPoint, Path2D) -> Either SVGError (RPoint, Path2D)
forall a b. b -> Either a b
Right (RPoint
end, [Path2D] -> Path2D
forall a. Monoid a => [a] -> a
mconcat ([Path2D] -> Path2D)
-> ([Path2D] -> [Path2D]) -> [Path2D] -> Path2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path2D] -> [Path2D]
forall a. [a] -> [a]
reverse ([Path2D] -> Path2D) -> [Path2D] -> Path2D
forall a b. (a -> b) -> a -> b
$ [Path2D]
allPaths)
        Left SVGError
err -> SVGError -> Either SVGError (RPoint, Path2D)
forall a b. a -> Either a b
Left SVGError
err

ellipseToRelative :: Double -> Double -> Double -> Bool -> Bool -> V2 Double -> V2 Double -> (V2 Double, Waterfall.Path2D)
ellipseToRelative :: Double
-> Double
-> Double
-> Bool
-> Bool
-> RPoint
-> RPoint
-> (RPoint, Path2D)
ellipseToRelative Double
rx Double
ry Double
angleDeg Bool
largeArcFlag Bool
sweepFlag RPoint
relativeEnd =
    let angleRads :: Double
angleRads = Double
angleDeg Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
180
        scaleFac :: Double
scaleFac = Double
ry Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
rx
        transformForward :: Waterfall.Transformable2D a => a -> a
        transformForward :: forall a. Transformable2D a => a -> a
transformForward = Double -> a -> a
forall a. Transformable2D a => Double -> a -> a
Waterfall.rotate2D (Double
angleRads) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> a -> a
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.scale2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
scaleFac) Double
1)
        transformBack :: Waterfall.Transformable2D a => a -> a
        transformBack :: forall a. Transformable2D a => a -> a
transformBack = RPoint -> a -> a
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.scale2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 (Double
scaleFac) Double
1) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> a -> a
forall a. Transformable2D a => Double -> a -> a
Waterfall.rotate2D (-Double
angleRads)
        relativeEndTransformed :: RPoint
relativeEndTransformed@(V2 Double
retX Double
retY) = RPoint -> RPoint
forall a. Transformable2D a => a -> a
transformBack RPoint
relativeEnd
        transformedDistance :: Double
transformedDistance = RPoint -> Double
forall a. Floating a => V2 a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm RPoint
relativeEndTransformed
        halfTD :: Double
halfTD = Double
transformedDistance Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.5
        perp :: RPoint
perp = RPoint -> RPoint
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 (-Double
retY) Double
retX)
        p1 :: RPoint
p1 = if Bool
sweepFlag Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
largeArcFlag then RPoint -> RPoint
forall a. Num a => a -> a
negate RPoint
perp else RPoint
perp
        p2 :: RPoint
p2 = if Bool
largeArcFlag then RPoint
p1 else RPoint -> RPoint
forall a. Num a => a -> a
negate RPoint
p1
        radius :: Double
radius = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
ry Double
halfTD 
        centerPerpDistance :: Double
centerPerpDistance = Double -> Double
forall a. Floating a => a -> a
sqrt (Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
halfTD Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
halfTD)
        center :: RPoint
center = (RPoint
relativeEndTransformed RPoint -> Double -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Double
0.5) RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ (RPoint
p1 RPoint -> Double -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Double
centerPerpDistance)
        midPoint :: RPoint
midPoint = RPoint
center RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ (RPoint
p2 RPoint -> Double -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Double
radius)
        
        in Path2D -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Num point) =>
path -> point -> (point, path)
Waterfall.splice (Path2D -> RPoint -> (RPoint, Path2D))
-> (Path2D -> Path2D) -> Path2D -> RPoint -> (RPoint, Path2D)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path2D -> Path2D
forall a. Transformable2D a => a -> a
transformForward (Path2D -> RPoint -> (RPoint, Path2D))
-> Path2D -> RPoint -> (RPoint, Path2D)
forall a b. (a -> b) -> a -> b
$ RPoint -> RPoint -> RPoint -> Path2D
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> point -> path
Waterfall.arcVia RPoint
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero RPoint
midPoint RPoint
relativeEndTransformed 

quadraticBezierAbsolute :: V2 Double -> V2 Double -> V2 Double -> (V2 Double, Waterfall.Path2D)
quadraticBezierAbsolute :: RPoint -> RPoint -> RPoint -> (RPoint, Path2D)
quadraticBezierAbsolute RPoint
p0 RPoint
p1 RPoint
p2 = (RPoint
p2, RPoint -> RPoint -> RPoint -> RPoint -> Path2D
Waterfall.bezier2D RPoint
p0 (RPoint
p0 RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ ((RPoint
p1 RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
- RPoint
p0) RPoint -> Double -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (Double
2Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3))) (RPoint
p2 RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ ((RPoint
p1 RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
- RPoint
p2) RPoint -> Double -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (Double
2Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3))) RPoint
p2)

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

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

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

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

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

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

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

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

smoothQuadraticBezierCurveToRelative :: V2 Double -> Maybe (V2 Double) -> V2 Double -> Either SVGError (Maybe (V2 Double), (V2 Double, Waterfall.Path2D))
smoothQuadraticBezierCurveToRelative :: RPoint
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
smoothQuadraticBezierCurveToRelative RPoint
_ Maybe RPoint
Nothing RPoint
_ = SVGError -> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall a b. a -> Either a b
Left (SVGErrorKind -> String -> SVGError
SVGError SVGErrorKind
SVGPathError String
"t command must follow either an T, t, Q or q command")
smoothQuadraticBezierCurveToRelative RPoint
cp2 Maybe RPoint
cp1 RPoint
cp0 = RPoint
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
smoothQuadraticBezierCurveToRelative (RPoint
cp0 RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint
cp2) Maybe RPoint
cp1 RPoint
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 :: [PathCommand] -> Either SVGError [Path2D]
convertPathCommands [PathCommand]
cs =
    let
        relativeLocation :: p -> Origin -> p -> p
relativeLocation p
_ Origin
Svg.OriginAbsolute p
v = p
v
        relativeLocation p
curPos Origin
Svg.OriginRelative p
v = p
curPos p -> p -> p
forall a. Num a => a -> a -> a
+ p
v
        buildPathInProgress :: (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> Either SVGError (RPoint, Path2D)
buildPathInProgress (RPoint
origin, [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments) = 
            [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> RPoint -> Either SVGError (RPoint, Path2D)
pathFromToWithControlPoint [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments RPoint
origin
        withoutControlPoint :: (t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint t -> b
f p
_cp t
o = (Maybe a, b) -> Either a (Maybe a, b)
forall a b. b -> Either a b
Right (Maybe a
forall a. Maybe a
Nothing, t -> b
f t
o)
        go :: [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go (PathCommand
cmd:[PathCommand]
rest) pathInProgress :: (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
pathInProgress@(RPoint
o, [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments) [Path2D]
paths = 
            let goSegment :: [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
ss = [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go [PathCommand]
rest (RPoint
o, [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall a. Semigroup a => a -> a -> a
<> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
ss) [Path2D]
paths  
            in case PathCommand
cmd of
                (Svg.MoveTo Origin
origin (RPoint
v:[RPoint]
vs)) ->
                    let restPlusImplicitLineTo :: [PathCommand]
restPlusImplicitLineTo =
                            case [RPoint]
vs of
                                [] -> [PathCommand]
rest
                                [RPoint]
implicitLineTos -> Origin -> [RPoint] -> PathCommand
Svg.LineTo Origin
origin [RPoint]
implicitLineTos PathCommand -> [PathCommand] -> [PathCommand]
forall a. a -> [a] -> [a]
: [PathCommand]
rest
                    in if [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments
                        then [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go [PathCommand]
restPlusImplicitLineTo (RPoint -> Origin -> RPoint -> RPoint
forall {p}. Num p => p -> Origin -> p -> p
relativeLocation RPoint
o Origin
origin RPoint
v, []) [Path2D]
paths
                        else case (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> Either SVGError (RPoint, Path2D)
buildPathInProgress (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
pathInProgress of
                            Right (RPoint
currentPosition, Path2D
newPath) ->  [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go [PathCommand]
restPlusImplicitLineTo (RPoint -> Origin -> RPoint -> RPoint
forall {p}. Num p => p -> Origin -> p -> p
relativeLocation RPoint
currentPosition Origin
origin RPoint
v, []) (Path2D
newPath Path2D -> [Path2D] -> [Path2D]
forall a. a -> [a] -> [a]
: [Path2D]
paths)
                            Left SVGError
err -> SVGError -> Either SVGError [Path2D]
forall a b. a -> Either a b
Left SVGError
err
                (Svg.MoveTo Origin
_ []) -> SVGError -> Either SVGError [Path2D]
forall a b. a -> Either a b
Left (SVGErrorKind -> String -> SVGError
SVGError SVGErrorKind
SVGPathError String
"Empty MoveTo command")
                (Svg.LineTo Origin
Svg.OriginAbsolute [RPoint]
vs) -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> (RPoint -> RPoint -> (RPoint, Path2D))
-> RPoint
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> RPoint -> (RPoint, Path2D)
Waterfall.lineTo2D (RPoint
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [RPoint]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RPoint]
vs )
                (Svg.LineTo Origin
Svg.OriginRelative [RPoint]
vs) -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> (RPoint -> RPoint -> (RPoint, Path2D))
-> RPoint
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> RPoint -> (RPoint, Path2D)
Waterfall.lineRelative2D (RPoint
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [RPoint]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RPoint]
vs)
                (Svg.HorizontalTo Origin
Svg.OriginAbsolute [Double]
ds) -> 
                    let f :: Double -> RPoint -> (RPoint, Path2D)
f Double
d v :: RPoint
v@(V2 Double
_x Double
y) = let v' :: RPoint
v' = Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
d Double
y in (RPoint
v', RPoint -> RPoint -> Path2D
Waterfall.line2D RPoint
v RPoint
v')
                        in [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> (Double -> RPoint -> (RPoint, Path2D))
-> Double
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> RPoint -> (RPoint, Path2D)
f (Double
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [Double]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
ds) 
                (Svg.HorizontalTo Origin
Svg.OriginRelative [Double]
ds) -> 
                    let f :: Double -> RPoint -> (RPoint, Path2D)
f Double
d RPoint
v = let v' :: RPoint
v' = RPoint
v RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
d Double
0 in (RPoint
v', RPoint -> RPoint -> Path2D
Waterfall.line2D RPoint
v RPoint
v')
                    in [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> (Double -> RPoint -> (RPoint, Path2D))
-> Double
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> RPoint -> (RPoint, Path2D)
f (Double
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [Double]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
ds)
                (Svg.VerticalTo Origin
Svg.OriginAbsolute [Double]
ds) -> 
                    let f :: Double -> RPoint -> (RPoint, Path2D)
f Double
d v :: RPoint
v@(V2 Double
x Double
_y) = let v' :: RPoint
v' = Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
d in (RPoint
v', RPoint -> RPoint -> Path2D
Waterfall.line2D RPoint
v RPoint
v')
                     in [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> (Double -> RPoint -> (RPoint, Path2D))
-> Double
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> RPoint -> (RPoint, Path2D)
f (Double
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [Double]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
ds) 
                (Svg.VerticalTo Origin
Svg.OriginRelative [Double]
ds) -> 
                    let f :: Double -> RPoint -> (RPoint, Path2D)
f Double
d RPoint
v = let v' :: RPoint
v' = RPoint
v RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
0 Double
d in (RPoint
v', RPoint -> RPoint -> Path2D
Waterfall.line2D RPoint
v RPoint
v')
                     in [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> (Double -> RPoint -> (RPoint, Path2D))
-> Double
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> RPoint -> (RPoint, Path2D)
f (Double
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [Double]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
ds) 
                (Svg.CurveTo Origin
Svg.OriginAbsolute [(RPoint, RPoint, RPoint)]
points) -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint, RPoint, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
curveToAbsolute ((RPoint, RPoint, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(RPoint, RPoint, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RPoint, RPoint, RPoint)]
points)
                (Svg.CurveTo Origin
Svg.OriginRelative [(RPoint, RPoint, RPoint)]
points) -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint, RPoint, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
curveToRelative ((RPoint, RPoint, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(RPoint, RPoint, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RPoint, RPoint, RPoint)]
points)
                (Svg.EllipticalArc Origin
Svg.OriginAbsolute [(Double, Double, Double, Bool, Bool, RPoint)]
points) -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> ((Double, Double, Double, Bool, Bool, RPoint)
    -> RPoint -> (RPoint, Path2D))
-> (Double, Double, Double, Bool, Bool, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
 -> Double
 -> Double
 -> Bool
 -> Bool
 -> RPoint
 -> RPoint
 -> (RPoint, Path2D))
-> (Double, Double, Double, Bool, Bool, RPoint)
-> RPoint
-> (RPoint, Path2D)
forall a b c d e f g.
(a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
uncurry6 Double
-> Double
-> Double
-> Bool
-> Bool
-> RPoint
-> RPoint
-> (RPoint, Path2D)
ellipseToAbsolute ((Double, Double, Double, Bool, Bool, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(Double, Double, Double, Bool, Bool, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Double, Double, Double, Bool, Bool, RPoint)]
points)
                (Svg.EllipticalArc Origin
Svg.OriginRelative [(Double, Double, Double, Bool, Bool, RPoint)]
points) -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint -> (RPoint, Path2D))
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall {t} {b} {p} {a} {a}.
(t -> b) -> p -> t -> Either a (Maybe a, b)
withoutControlPoint ((RPoint -> (RPoint, Path2D))
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> ((Double, Double, Double, Bool, Bool, RPoint)
    -> RPoint -> (RPoint, Path2D))
-> (Double, Double, Double, Bool, Bool, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
 -> Double
 -> Double
 -> Bool
 -> Bool
 -> RPoint
 -> RPoint
 -> (RPoint, Path2D))
-> (Double, Double, Double, Bool, Bool, RPoint)
-> RPoint
-> (RPoint, Path2D)
forall a b c d e f g.
(a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
uncurry6 Double
-> Double
-> Double
-> Bool
-> Bool
-> RPoint
-> RPoint
-> (RPoint, Path2D)
ellipseToRelative ((Double, Double, Double, Bool, Bool, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(Double, Double, Double, Bool, Bool, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Double, Double, Double, Bool, Bool, RPoint)]
points)
                Svg.QuadraticBezier Origin
Svg.OriginAbsolute [(RPoint, RPoint)]
points -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
quadraticBezierAbsolute' ((RPoint, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(RPoint, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RPoint, RPoint)]
points)
                Svg.QuadraticBezier Origin
Svg.OriginRelative [(RPoint, RPoint)]
points -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
quadraticBezierRelative' ((RPoint, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(RPoint, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RPoint, RPoint)]
points)
                Svg.SmoothCurveTo Origin
Svg.OriginAbsolute [(RPoint, RPoint)]
points -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
smoothCurveToAbsolute ((RPoint, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(RPoint, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RPoint, RPoint)]
points)
                Svg.SmoothCurveTo Origin
Svg.OriginRelative [(RPoint, RPoint)]
points -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment ((RPoint, RPoint)
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
smoothCurveToRelative ((RPoint, RPoint)
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [(RPoint, RPoint)]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RPoint, RPoint)]
points)
                Svg.SmoothQuadraticBezierCurveTo Origin
Svg.OriginAbsolute [RPoint]
points -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment (RPoint
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
smoothQuadraticBezierCurveToAbsolute (RPoint
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [RPoint]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RPoint]
points)
                Svg.SmoothQuadraticBezierCurveTo Origin
Svg.OriginRelative [RPoint]
points -> [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Either SVGError [Path2D]
goSegment (RPoint
-> Maybe RPoint
-> RPoint
-> Either SVGError (Maybe RPoint, (RPoint, Path2D))
smoothQuadraticBezierCurveToRelative (RPoint
 -> Maybe RPoint
 -> RPoint
 -> Either SVGError (Maybe RPoint, (RPoint, Path2D)))
-> [RPoint]
-> [Maybe RPoint
    -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RPoint]
points)
                PathCommand
Svg.EndPath -> 
                    if [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments 
                        then [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go [PathCommand]
rest (RPoint
o, []) [Path2D]
paths
                        else case (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> Either SVGError (RPoint, Path2D)
buildPathInProgress (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
pathInProgress of
                                 Right (RPoint
_, Path2D
newPath) -> [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go [PathCommand]
rest (RPoint
o, []) (Path2D -> Path2D
forall point path.
(AnyPath point path, Monoid path, Epsilon point) =>
path -> path
Waterfall.closeLoop Path2D
newPath Path2D -> [Path2D] -> [Path2D]
forall a. a -> [a] -> [a]
: [Path2D]
paths)
                                 Left SVGError
err -> SVGError -> Either SVGError [Path2D]
forall a b. a -> Either a b
Left SVGError
err
        go [] pathInProgress :: (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
pathInProgress@(RPoint
_o, [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments) [Path2D]
paths = 
            if [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe RPoint
 -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))]
segments 
                then [Path2D] -> Either SVGError [Path2D]
forall a b. b -> Either a b
Right [Path2D]
paths
                else (Path2D -> [Path2D] -> [Path2D]
forall a. a -> [a] -> [a]
:[Path2D]
paths) (Path2D -> [Path2D])
-> ((RPoint, Path2D) -> Path2D) -> (RPoint, Path2D) -> [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RPoint, Path2D) -> Path2D
forall a b. (a, b) -> b
snd ((RPoint, Path2D) -> [Path2D])
-> Either SVGError (RPoint, Path2D) -> Either SVGError [Path2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> Either SVGError (RPoint, Path2D)
buildPathInProgress (RPoint,
 [Maybe RPoint
  -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
pathInProgress
    in [Path2D] -> [Path2D]
forall a. [a] -> [a]
reverse ([Path2D] -> [Path2D])
-> Either SVGError [Path2D] -> Either SVGError [Path2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PathCommand]
-> (RPoint,
    [Maybe RPoint
     -> RPoint -> Either SVGError (Maybe RPoint, (RPoint, Path2D))])
-> [Path2D]
-> Either SVGError [Path2D]
go [PathCommand]
cs (RPoint
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
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 :: String -> Either SVGError [Path2D]
parsePath String
s =
    case Parser [PathCommand] -> Text -> Either String [PathCommand]
forall a. Parser a -> Text -> Either String a
Atto.parseOnly (Parser [PathCommand]
pathParser Parser [PathCommand] -> Parser Text () -> Parser [PathCommand]
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput) (String -> Text
T.pack String
s) of 
        Right [PathCommand]
r -> [PathCommand] -> Either SVGError [Path2D]
convertPathCommands [PathCommand]
r
        Left String
msg -> SVGError -> Either SVGError [Path2D]
forall a b. a -> Either a b
Left (SVGErrorKind -> String -> SVGError
SVGError SVGErrorKind
SVGParseError String
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 :: forall a.
Transformable2D a =>
Transformation -> Either SVGError (a -> a)
convertTransform (Svg.TransformMatrix Double
a Double
b Double
c Double
d Double
e Double
f) = (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right ((a -> a) -> Either SVGError (a -> a))
-> (a -> a) -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ M23 Double -> a -> a
forall a. Transformable2D a => M23 Double -> a -> a
Waterfall.matTransform2D (V3 Double -> V3 Double -> M23 Double
forall a. a -> a -> V2 a
V2 (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
a Double
c Double
e) (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
b Double
d Double
f))
convertTransform (Svg.Translate Double
x Double
y) = (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right ((a -> a) -> Either SVGError (a -> a))
-> (a -> a) -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ RPoint -> a -> a
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
y)
convertTransform (Svg.Scale Double
v Maybe Double
Nothing) = (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right ((a -> a) -> Either SVGError (a -> a))
-> (a -> a) -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ Double -> a -> a
forall a. Transformable2D a => Double -> a -> a
Waterfall.uScale2D Double
v
convertTransform (Svg.Scale Double
x (Just Double
y)) = (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right ((a -> a) -> Either SVGError (a -> a))
-> (a -> a) -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ RPoint -> a -> a
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.scale2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
y)
convertTransform (Svg.Rotate Double
angleDeg Maybe (Double, Double)
center) = 
    let center' :: RPoint
center' = RPoint
-> ((Double, Double) -> RPoint) -> Maybe (Double, Double) -> RPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RPoint
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero ((Double -> Double -> RPoint) -> (Double, Double) -> RPoint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2) Maybe (Double, Double)
center 
        fwd :: a -> a
fwd = RPoint -> a -> a
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D (RPoint -> RPoint
forall a. Num a => a -> a
negate RPoint
center')
        angleRad :: Double
angleRad = Double
angleDeg Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
180
        back :: a -> a
back = RPoint -> a -> a
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D RPoint
center'
     in (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right (a -> a
back (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> a -> a
forall a. Transformable2D a => Double -> a -> a
Waterfall.rotate2D Double
angleRad (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
fwd)
convertTransform (Svg.SkewX Double
x) = (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right ((a -> a) -> Either SVGError (a -> a))
-> (a -> a) -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ M23 Double -> a -> a
forall a. Transformable2D a => M23 Double -> a -> a
Waterfall.matTransform2D (V3 Double -> V3 Double -> M23 Double
forall a. a -> a -> V2 a
V2 (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
x Double
0 Double
0) (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
0 Double
1 Double
0))
convertTransform (Svg.SkewY Double
y) = (a -> a) -> Either SVGError (a -> a)
forall a b. b -> Either a b
Right ((a -> a) -> Either SVGError (a -> a))
-> (a -> a) -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ M23 Double -> a -> a
forall a. Transformable2D a => M23 Double -> a -> a
Waterfall.matTransform2D (V3 Double -> V3 Double -> M23 Double
forall a. a -> a -> V2 a
V2 (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
1 Double
0 Double
0) (Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 Double
0 Double
y Double
0))
convertTransform Transformation
Svg.TransformUnknown = SVGError -> Either SVGError (a -> a)
forall a b. a -> Either a b
Left (SVGError -> Either SVGError (a -> a))
-> (String -> SVGError) -> String -> Either SVGError (a -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SVGErrorKind -> String -> SVGError
SVGError SVGErrorKind
SVGTransformError) (String -> Either SVGError (a -> a))
-> String -> Either SVGError (a -> a)
forall a b. (a -> b) -> a -> b
$ String
"Unknown Transform"

chain :: [a -> a] -> a -> a
chain :: forall a. [a -> a] -> a -> a
chain = (Unwrapped (Endo a) -> Endo a)
-> ((Unwrapped (Endo a) -> Endo a) -> [a -> a] -> Endo a)
-> [a -> a]
-> Unwrapped (Endo a)
forall (f :: * -> *) s t.
(Functor f, Rewrapping s t) =>
(Unwrapped s -> s)
-> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
ala Unwrapped (Endo a) -> Endo a
(a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo (Unwrapped (Endo a) -> Endo a) -> [Unwrapped (Endo a)] -> Endo a
(Unwrapped (Endo a) -> Endo a) -> [a -> a] -> Endo a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap

svgDPI :: Svg.Dpi
svgDPI :: Int
svgDPI = Int
300

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


convertPoint :: Svg.Point -> Either SVGError (V2 Double)
convertPoint :: Point -> Either SVGError RPoint
convertPoint = ((Double, Double) -> RPoint)
-> Either SVGError (Double, Double) -> Either SVGError RPoint
forall a b. (a -> b) -> Either SVGError a -> Either SVGError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Double -> Double -> RPoint) -> (Double, Double) -> RPoint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2) (Either SVGError (Double, Double) -> Either SVGError RPoint)
-> (Point -> Either SVGError (Double, Double))
-> Point
-> Either SVGError RPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Number -> Either SVGError Double)
-> Point -> Either SVGError (Double, Double)
forall s t a b. Each s t a b => Traversal s t a b
Traversal Point (Double, Double) Number Double
each Number -> Either SVGError Double
convertNumber 

convertCircle :: Svg.Circle -> Either SVGError [Waterfall.Path2D]
convertCircle :: Circle -> Either SVGError [Path2D]
convertCircle Circle
circle = do 
    RPoint
center <- Point -> Either SVGError RPoint
convertPoint (Circle
circle Circle -> Getting Point Circle Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point Circle Point
forall a. HasCircle a => Lens' a Point
Lens' Circle Point
Svg.circleCenter)
    Double
radius <- Circle
circle Circle -> Getting Number Circle Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Circle Number
forall a. HasCircle a => Lens' a Number
Lens' Circle Number
Svg.circleRadius Number
-> (Number -> Either SVGError Double) -> Either SVGError Double
forall a b. a -> (a -> b) -> b
& Number -> Either SVGError Double
convertNumber
    [Path2D] -> Either SVGError [Path2D]
forall a. a -> Either SVGError a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ([Path2D] -> Either SVGError [Path2D])
-> (Shape -> [Path2D]) -> Shape -> Either SVGError [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path2D -> Path2D) -> [Path2D] -> [Path2D]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RPoint -> Path2D -> Path2D
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D RPoint
center (Path2D -> Path2D) -> (Path2D -> Path2D) -> Path2D -> Path2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Path2D -> Path2D
forall a. Transformable2D a => Double -> a -> a
Waterfall.uScale2D Double
radius)
        ([Path2D] -> [Path2D]) -> (Shape -> [Path2D]) -> Shape -> [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shape -> [Path2D]
Waterfall.shapePaths 
        (Shape -> Either SVGError [Path2D])
-> Shape -> Either SVGError [Path2D]
forall a b. (a -> b) -> a -> b
$ Shape
Waterfall.unitCircle

convertPoints :: [Svg.RPoint] -> [Waterfall.Path2D]
convertPoints :: [RPoint] -> [Path2D]
convertPoints (RPoint
h:[RPoint]
t) = Path2D -> [Path2D]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path2D -> [Path2D]) -> Path2D -> [Path2D]
forall a b. (a -> b) -> a -> b
$ RPoint -> [RPoint -> (RPoint, Path2D)] -> Path2D
forall path point.
Monoid path =>
point -> [point -> (point, path)] -> path
Waterfall.pathFrom RPoint
h (RPoint -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
Waterfall.lineTo (RPoint -> RPoint -> (RPoint, Path2D))
-> [RPoint] -> [RPoint -> (RPoint, Path2D)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RPoint]
t)
convertPoints [] = []

convertPolyLine  :: Svg.PolyLine -> [Waterfall.Path2D]
convertPolyLine :: PolyLine -> [Path2D]
convertPolyLine PolyLine
polyLine = [RPoint] -> [Path2D]
convertPoints (PolyLine
polyLine PolyLine -> Getting [RPoint] PolyLine [RPoint] -> [RPoint]
forall s a. s -> Getting a s a -> a
^. Getting [RPoint] PolyLine [RPoint]
forall a. HasPolyLine a => Lens' a [RPoint]
Lens' PolyLine [RPoint]
Svg.polyLinePoints)

wrap :: [a] -> [a]
wrap :: forall a. [a] -> [a]
wrap (a
h:[a]
t) = a
ha -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
t [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
h] 
wrap [] = []

convertPolygon  :: Svg.Polygon -> [Waterfall.Path2D]
convertPolygon :: Polygon -> [Path2D]
convertPolygon Polygon
polygon = [RPoint] -> [Path2D]
convertPoints (Polygon
polygon Polygon -> Getting [RPoint] Polygon [RPoint] -> [RPoint]
forall s a. s -> Getting a s a -> a
^. Getting [RPoint] Polygon [RPoint]
forall a. HasPolygon a => Lens' a [RPoint]
Lens' Polygon [RPoint]
Svg.polygonPoints [RPoint] -> ([RPoint] -> [RPoint]) -> [RPoint]
forall a b. a -> (a -> b) -> b
& [RPoint] -> [RPoint]
forall a. [a] -> [a]
wrap)

convertLine :: Svg.Line -> Either SVGError Waterfall.Path2D
convertLine :: Line -> Either SVGError Path2D
convertLine Line
line = 
    RPoint -> RPoint -> Path2D
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> path
Waterfall.line 
        (RPoint -> RPoint -> Path2D)
-> Either SVGError RPoint -> Either SVGError (RPoint -> Path2D)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> Either SVGError RPoint
convertPoint (Line
line Line -> Getting Point Line Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point Line Point
forall a. HasLine a => Lens' a Point
Lens' Line Point
Svg.linePoint1)
        Either SVGError (RPoint -> Path2D)
-> Either SVGError RPoint -> Either SVGError Path2D
forall a b.
Either SVGError (a -> b) -> Either SVGError a -> Either SVGError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> Either SVGError RPoint
convertPoint (Line
line Line -> Getting Point Line Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point Line Point
forall a. HasLine a => Lens' a Point
Lens' Line Point
Svg.linePoint2)
        
convertEllipse :: Svg.Ellipse -> Either SVGError [Waterfall.Path2D]
convertEllipse :: Ellipse -> Either SVGError [Path2D]
convertEllipse Ellipse
ellipse = do 
    RPoint
center <- Point -> Either SVGError RPoint
convertPoint (Ellipse
ellipse Ellipse -> Getting Point Ellipse Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point Ellipse Point
forall c_amWt. HasEllipse c_amWt => Lens' c_amWt Point
Lens' Ellipse Point
Svg.ellipseCenter)
    Double
rX <- Ellipse
ellipse Ellipse -> Getting Number Ellipse Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Ellipse Number
forall c_amWt. HasEllipse c_amWt => Lens' c_amWt Number
Lens' Ellipse Number
Svg.ellipseXRadius Number
-> (Number -> Either SVGError Double) -> Either SVGError Double
forall a b. a -> (a -> b) -> b
& Number -> Either SVGError Double
convertNumber
    Double
rY <- Ellipse
ellipse Ellipse -> Getting Number Ellipse Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Ellipse Number
forall c_amWt. HasEllipse c_amWt => Lens' c_amWt Number
Lens' Ellipse Number
Svg.ellipseYRadius Number
-> (Number -> Either SVGError Double) -> Either SVGError Double
forall a b. a -> (a -> b) -> b
& Number -> Either SVGError Double
convertNumber
    [Path2D] -> Either SVGError [Path2D]
forall a. a -> Either SVGError a
forall (m :: * -> *) a. Monad m => a -> m a
return 
        ([Path2D] -> Either SVGError [Path2D])
-> (Shape -> [Path2D]) -> Shape -> Either SVGError [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path2D -> Path2D) -> [Path2D] -> [Path2D]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RPoint -> Path2D -> Path2D
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D RPoint
center (Path2D -> Path2D) -> (Path2D -> Path2D) -> Path2D -> Path2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> Path2D -> Path2D
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.scale2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
rX Double
rY))
        ([Path2D] -> [Path2D]) -> (Shape -> [Path2D]) -> Shape -> [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shape -> [Path2D]
Waterfall.shapePaths
        (Shape -> Either SVGError [Path2D])
-> Shape -> Either SVGError [Path2D]
forall a b. (a -> b) -> a -> b
$ Shape
Waterfall.unitCircle

convertRectangle :: Svg.Rectangle -> Either SVGError [Waterfall.Path2D]
convertRectangle :: Rectangle -> Either SVGError [Path2D]
convertRectangle Rectangle
rect = do
    RPoint
upperLeft <- Point -> Either SVGError RPoint
convertPoint (Rectangle
rect Rectangle -> Getting Point Rectangle Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point Rectangle Point
forall a. HasRectangle a => Lens' a Point
Lens' Rectangle Point
Svg.rectUpperLeftCorner)    
    (Double
rX', Double
rY') <- (Number -> Either SVGError Double)
-> Point -> Either SVGError (Double, Double)
forall s t a b. Each s t a b => Traversal s t a b
Traversal Point (Double, Double) Number Double
each Number -> Either SVGError Double
convertNumber (Rectangle
rect Rectangle -> Getting Point Rectangle Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point Rectangle Point
forall a. HasRectangle a => Lens' a Point
Lens' Rectangle Point
Svg.rectCornerRadius)
    Double
w <- Number -> Either SVGError Double
convertNumber (Rectangle
rect Rectangle -> Getting Number Rectangle Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Rectangle Number
forall a. HasRectangle a => Lens' a Number
Lens' Rectangle Number
Svg.rectWidth)
    Double
h <- Number -> Either SVGError Double
convertNumber (Rectangle
rect Rectangle -> Getting Number Rectangle Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Rectangle Number
forall a. HasRectangle a => Lens' a Number
Lens' Rectangle Number
Svg.rectHeight)
    let rX :: Double
rX = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
rX' (Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
    let rY :: Double
rY = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
rY' (Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
    let w' :: Double
w' = Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rX
    let h' :: Double
h' = Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rY
    let quarterCircle :: Path2D
quarterCircle = RPoint -> RPoint -> RPoint -> Path2D
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> point -> path
Waterfall.arcVia (RPoint -> RPoint
forall a. Num a => a -> a
negate (RPoint -> RPoint) -> RPoint -> RPoint
forall a b. (a -> b) -> a -> b
$ ASetter' RPoint Double -> RPoint
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (RPoint -> RPoint
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
1 (-Double
1))) (ASetter' RPoint Double -> RPoint
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
    let scaleBevel :: Path2D -> Path2D
scaleBevel = RPoint -> Path2D -> Path2D
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.scale2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
rX Double
rY)
    if Double
rX Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
|| Double
rY Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 
        then Shape
Waterfall.unitSquare Shape -> (Shape -> Shape) -> Shape
forall a b. a -> (a -> b) -> b
&
                RPoint -> Shape -> Shape
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.scale2D (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
w Double
h) Shape -> (Shape -> Shape) -> Shape
forall a b. a -> (a -> b) -> b
&
                RPoint -> Shape -> Shape
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D RPoint
upperLeft Shape -> (Shape -> [Path2D]) -> [Path2D]
forall a b. a -> (a -> b) -> b
&
                Shape -> [Path2D]
Waterfall.shapePaths [Path2D]
-> ([Path2D] -> Either SVGError [Path2D])
-> Either SVGError [Path2D]
forall a b. a -> (a -> b) -> b
& 
                [Path2D] -> Either SVGError [Path2D]
forall a. a -> Either SVGError a
forall (m :: * -> *) a. Monad m => a -> m a
return
        else [Path2D] -> Either SVGError [Path2D]
forall a. a -> Either SVGError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Path2D] -> Either SVGError [Path2D])
-> ([Maybe (RPoint -> (RPoint, Path2D))] -> [Path2D])
-> [Maybe (RPoint -> (RPoint, Path2D))]
-> Either SVGError [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path2D -> [Path2D]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path2D -> [Path2D])
-> ([Maybe (RPoint -> (RPoint, Path2D))] -> Path2D)
-> [Maybe (RPoint -> (RPoint, Path2D))]
-> [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> [RPoint -> (RPoint, Path2D)] -> Path2D
forall path point.
Monoid path =>
point -> [point -> (point, path)] -> path
Waterfall.pathFrom (Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
rX Double
0) ([RPoint -> (RPoint, Path2D)] -> Path2D)
-> ([Maybe (RPoint -> (RPoint, Path2D))]
    -> [RPoint -> (RPoint, Path2D)])
-> [Maybe (RPoint -> (RPoint, Path2D))]
-> Path2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (RPoint -> (RPoint, Path2D))]
-> [RPoint -> (RPoint, Path2D)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (RPoint -> (RPoint, Path2D))] -> Either SVGError [Path2D])
-> [Maybe (RPoint -> (RPoint, Path2D))] -> Either SVGError [Path2D]
forall a b. (a -> b) -> a -> b
$
                [ if Double
w' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
Just (RPoint -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
Waterfall.lineRelative (Double
w' Double -> RPoint -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ASetter' RPoint Double -> RPoint
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)) else Maybe (RPoint -> (RPoint, Path2D))
forall a. Maybe a
Nothing
                , Path2D
quarterCircle 
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Path2D -> Path2D
scaleBevel 
                    Path2D
-> (Path2D -> RPoint -> (RPoint, Path2D))
-> RPoint
-> (RPoint, Path2D)
forall a b. a -> (a -> b) -> b
& Path2D -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Num point) =>
path -> point -> (point, path)
Waterfall.splice
                    (RPoint -> (RPoint, Path2D))
-> ((RPoint -> (RPoint, Path2D))
    -> Maybe (RPoint -> (RPoint, Path2D)))
-> Maybe (RPoint -> (RPoint, Path2D))
forall a b. a -> (a -> b) -> b
& (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                , if Double
h' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
Just (RPoint -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
Waterfall.lineRelative (Double
h' Double -> RPoint -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ASetter' RPoint Double -> RPoint
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y)) else Maybe (RPoint -> (RPoint, Path2D))
forall a. Maybe a
Nothing
                , Path2D
quarterCircle 
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Double -> Path2D -> Path2D
forall a. Transformable2D a => Double -> a -> a
Waterfall.rotate2D (Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Path2D -> Path2D
scaleBevel 
                    Path2D
-> (Path2D -> RPoint -> (RPoint, Path2D))
-> RPoint
-> (RPoint, Path2D)
forall a b. a -> (a -> b) -> b
& Path2D -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Num point) =>
path -> point -> (point, path)
Waterfall.splice
                    (RPoint -> (RPoint, Path2D))
-> ((RPoint -> (RPoint, Path2D))
    -> Maybe (RPoint -> (RPoint, Path2D)))
-> Maybe (RPoint -> (RPoint, Path2D))
forall a b. a -> (a -> b) -> b
& (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                , if Double
w' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
Just (RPoint -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
Waterfall.lineRelative (RPoint -> RPoint
forall a. Num a => a -> a
negate (Double
w' Double -> RPoint -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ASetter' RPoint Double -> RPoint
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x))) else Maybe (RPoint -> (RPoint, Path2D))
forall a. Maybe a
Nothing
                , Path2D
quarterCircle 
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Double -> Path2D -> Path2D
forall a. Transformable2D a => Double -> a -> a
Waterfall.rotate2D Double
forall a. Floating a => a
pi
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Path2D -> Path2D
scaleBevel 
                    Path2D
-> (Path2D -> RPoint -> (RPoint, Path2D))
-> RPoint
-> (RPoint, Path2D)
forall a b. a -> (a -> b) -> b
& Path2D -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Num point) =>
path -> point -> (point, path)
Waterfall.splice
                    (RPoint -> (RPoint, Path2D))
-> ((RPoint -> (RPoint, Path2D))
    -> Maybe (RPoint -> (RPoint, Path2D)))
-> Maybe (RPoint -> (RPoint, Path2D))
forall a b. a -> (a -> b) -> b
& (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                , if Double
h' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
Just (RPoint -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
Waterfall.lineRelative (RPoint -> RPoint
forall a. Num a => a -> a
negate (Double
h' Double -> RPoint -> RPoint
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ ASetter' RPoint Double -> RPoint
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y))) else Maybe (RPoint -> (RPoint, Path2D))
forall a. Maybe a
Nothing
                , Path2D
quarterCircle 
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Double -> Path2D -> Path2D
forall a. Transformable2D a => Double -> a -> a
Waterfall.rotate2D (-Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
                    Path2D -> (Path2D -> Path2D) -> Path2D
forall a b. a -> (a -> b) -> b
& Path2D -> Path2D
scaleBevel 
                    Path2D
-> (Path2D -> RPoint -> (RPoint, Path2D))
-> RPoint
-> (RPoint, Path2D)
forall a b. a -> (a -> b) -> b
& Path2D -> RPoint -> (RPoint, Path2D)
forall point path.
(AnyPath point path, Num point) =>
path -> point -> (point, path)
Waterfall.splice
                    (RPoint -> (RPoint, Path2D))
-> ((RPoint -> (RPoint, Path2D))
    -> Maybe (RPoint -> (RPoint, Path2D)))
-> Maybe (RPoint -> (RPoint, Path2D))
forall a b. a -> (a -> b) -> b
& (RPoint -> (RPoint, Path2D)) -> Maybe (RPoint -> (RPoint, Path2D))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
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 -> Either SVGError [Path2D]
convertTree Tree
tree = do
    Path2D -> Path2D
transform <- Either SVGError (Path2D -> Path2D)
-> ([Transformation] -> Either SVGError (Path2D -> Path2D))
-> Maybe [Transformation]
-> Either SVGError (Path2D -> Path2D)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Path2D -> Path2D) -> Either SVGError (Path2D -> Path2D)
forall a. a -> Either SVGError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path2D -> Path2D
forall a. a -> a
id) (([Path2D -> Path2D] -> Path2D -> Path2D)
-> Either SVGError [Path2D -> Path2D]
-> Either SVGError (Path2D -> Path2D)
forall a b. (a -> b) -> Either SVGError a -> Either SVGError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Path2D -> Path2D] -> Path2D -> Path2D
forall a. [a -> a] -> a -> a
chain (Either SVGError [Path2D -> Path2D]
 -> Either SVGError (Path2D -> Path2D))
-> ([Transformation] -> Either SVGError [Path2D -> Path2D])
-> [Transformation]
-> Either SVGError (Path2D -> Path2D)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transformation -> Either SVGError (Path2D -> Path2D))
-> [Transformation] -> Either SVGError [Path2D -> Path2D]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Transformation -> Either SVGError (Path2D -> Path2D)
forall a.
Transformable2D a =>
Transformation -> Either SVGError (a -> a)
convertTransform) (Tree
tree Tree
-> Getting (Maybe [Transformation]) Tree (Maybe [Transformation])
-> Maybe [Transformation]
forall s a. s -> Getting a s a -> a
^. (DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
-> Tree -> Const (Maybe [Transformation]) Tree
forall a. WithDrawAttributes a => Lens' a DrawAttributes
Lens' Tree DrawAttributes
Svg.drawAttr ((DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
 -> Tree -> Const (Maybe [Transformation]) Tree)
-> ((Maybe [Transformation]
     -> Const (Maybe [Transformation]) (Maybe [Transformation]))
    -> DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
-> Getting (Maybe [Transformation]) Tree (Maybe [Transformation])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
-> DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes
forall a. HasDrawAttributes a => Lens' a DrawAttributes
Lens' DrawAttributes DrawAttributes
Svg.drawAttributes ((DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
 -> DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
-> ((Maybe [Transformation]
     -> Const (Maybe [Transformation]) (Maybe [Transformation]))
    -> DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes)
-> (Maybe [Transformation]
    -> Const (Maybe [Transformation]) (Maybe [Transformation]))
-> DrawAttributes
-> Const (Maybe [Transformation]) DrawAttributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [Transformation]
 -> Const (Maybe [Transformation]) (Maybe [Transformation]))
-> DrawAttributes -> Const (Maybe [Transformation]) DrawAttributes
forall a. HasDrawAttributes a => Lens' a (Maybe [Transformation])
Lens' DrawAttributes (Maybe [Transformation])
Svg.transform)
    (Path2D -> Path2D) -> [Path2D] -> [Path2D]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path2D -> Path2D
transform ([Path2D] -> [Path2D])
-> Either SVGError [Path2D] -> Either SVGError [Path2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Tree
tree of
        Svg.PathTree Path
path -> [PathCommand] -> Either SVGError [Path2D]
convertPathCommands (Path
path Path -> Getting [PathCommand] Path [PathCommand] -> [PathCommand]
forall s a. s -> Getting a s a -> a
^. Getting [PathCommand] Path [PathCommand]
forall c_alhy. HasPath c_alhy => Lens' c_alhy [PathCommand]
Lens' Path [PathCommand]
Svg.pathDefinition)
        Svg.GroupTree Group Tree
group ->  [[Path2D]] -> [Path2D]
forall a. Monoid a => [a] -> a
mconcat ([[Path2D]] -> [Path2D])
-> Either SVGError [[Path2D]] -> Either SVGError [Path2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree -> Either SVGError [Path2D])
-> [Tree] -> Either SVGError [[Path2D]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Tree -> Either SVGError [Path2D]
convertTree (Group Tree
group Group Tree -> Getting [Tree] (Group Tree) [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^. Getting [Tree] (Group Tree) [Tree]
forall g a. HasGroup g a => Lens' g [a]
Lens' (Group Tree) [Tree]
Svg.groupChildren)
        Svg.SymbolTree Symbol Tree
sym ->  [[Path2D]] -> [Path2D]
forall a. Monoid a => [a] -> a
mconcat ([[Path2D]] -> [Path2D])
-> Either SVGError [[Path2D]] -> Either SVGError [Path2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree -> Either SVGError [Path2D])
-> [Tree] -> Either SVGError [[Path2D]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Tree -> Either SVGError [Path2D]
convertTree (Symbol Tree
sym Symbol Tree -> Getting [Tree] (Symbol Tree) [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^. (Group Tree -> Const [Tree] (Group Tree))
-> Symbol Tree -> Const [Tree] (Symbol Tree)
forall s t (f :: * -> *).
Functor f =>
(Group s -> f (Group t)) -> Symbol s -> f (Symbol t)
Svg.groupOfSymbol ((Group Tree -> Const [Tree] (Group Tree))
 -> Symbol Tree -> Const [Tree] (Symbol Tree))
-> Getting [Tree] (Group Tree) [Tree]
-> Getting [Tree] (Symbol Tree) [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [Tree] (Group Tree) [Tree]
forall g a. HasGroup g a => Lens' g [a]
Lens' (Group Tree) [Tree]
Svg.groupChildren)
        Svg.CircleTree Circle
circle -> Circle -> Either SVGError [Path2D]
convertCircle Circle
circle
        Svg.PolyLineTree PolyLine
polyLine -> [Path2D] -> Either SVGError [Path2D]
forall a. a -> Either SVGError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path2D] -> Either SVGError [Path2D])
-> [Path2D] -> Either SVGError [Path2D]
forall a b. (a -> b) -> a -> b
$ PolyLine -> [Path2D]
convertPolyLine PolyLine
polyLine
        Svg.PolygonTree Polygon
polygon -> [Path2D] -> Either SVGError [Path2D]
forall a. a -> Either SVGError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path2D] -> Either SVGError [Path2D])
-> [Path2D] -> Either SVGError [Path2D]
forall a b. (a -> b) -> a -> b
$ Polygon -> [Path2D]
convertPolygon Polygon
polygon
        Svg.LineTree Line
line -> Path2D -> [Path2D]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path2D -> [Path2D])
-> Either SVGError Path2D -> Either SVGError [Path2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Line -> Either SVGError Path2D
convertLine Line
line
        Svg.EllipseTree Ellipse
ellipse -> Ellipse -> Either SVGError [Path2D]
convertEllipse Ellipse
ellipse
        Svg.RectangleTree Rectangle
rectangle -> Rectangle -> Either SVGError [Path2D]
convertRectangle Rectangle
rectangle
        Tree
_ -> [Path2D] -> Either SVGError [Path2D]
forall a b. b -> Either a b
Right []

-- | Convert an `Svg.Document` into a list of `Path2Ds`
convertDocument :: Svg.Document -> Either SVGError [Waterfall.Path2D]
convertDocument :: Document -> Either SVGError [Path2D]
convertDocument Document
doc = ([[Path2D]] -> [Path2D])
-> Either SVGError [[Path2D]] -> Either SVGError [Path2D]
forall a b. (a -> b) -> Either SVGError a -> Either SVGError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Path2D]] -> [Path2D]
forall a. Monoid a => [a] -> a
mconcat (Either SVGError [[Path2D]] -> Either SVGError [Path2D])
-> ([Tree] -> Either SVGError [[Path2D]])
-> [Tree]
-> Either SVGError [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree -> Either SVGError [Path2D])
-> [Tree] -> Either SVGError [[Path2D]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Tree -> Either SVGError [Path2D]
convertTree ([Tree] -> Either SVGError [Path2D])
-> [Tree] -> Either SVGError [Path2D]
forall a b. (a -> b) -> a -> b
$ (Document
doc Document -> Getting [Tree] Document [Tree] -> [Tree]
forall s a. s -> Getting a s a -> a
^. Getting [Tree] Document [Tree]
forall c_aqpq. HasDocument c_aqpq => Lens' c_aqpq [Tree]
Lens' Document [Tree]
Svg.elements) 

-- | Load an SVG file into a `Waterfall.Path2D`
readSVG :: FilePath -> IO (Either SVGError [Waterfall.Path2D])
readSVG :: String -> IO (Either SVGError [Path2D])
readSVG String
path = 
    let fileReadErr :: Either SVGError b
fileReadErr = SVGError -> Either SVGError b
forall a b. a -> Either a b
Left (SVGError -> Either SVGError b)
-> (String -> SVGError) -> String -> Either SVGError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVGErrorKind -> String -> SVGError
SVGError SVGErrorKind
SVGIOError (String -> Either SVGError b) -> String -> Either SVGError b
forall a b. (a -> b) -> a -> b
$ String
"Failed to read svg from file: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path
    in ( Document -> Either SVGError [Path2D]
convertDocument (Document -> Either SVGError [Path2D])
-> (Maybe Document -> Either SVGError Document)
-> Maybe Document
-> Either SVGError [Path2D]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either SVGError Document
-> (Document -> Either SVGError Document)
-> Maybe Document
-> Either SVGError Document
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either SVGError Document
forall {b}. Either SVGError b
fileReadErr Document -> Either SVGError Document
forall a b. b -> Either a b
Right) (Maybe Document -> Either SVGError [Path2D])
-> IO (Maybe Document) -> IO (Either SVGError [Path2D])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Document)
Svg.loadSvgFile String
path