-- |
-- Copyright   : Written by David Himmelstrup
-- License     : Unlicense
-- Maintainer  : lemmih@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Reanimate.Svg.LineCommand
  ( CmdM,
    LineCommand (..),
    lineLength,
    toLineCommands,
    lineToPath,
    lineToPoints,
    partialSvg,
  )
where

import           Control.Lens              ((%~), (&), (.~))
import           Control.Monad.Fix         (MonadFix (mfix))
import           Control.Monad.State       (MonadState (get, put), State, evalState, forM, gets,
                                            modify)
import           Data.Functor              (($>))
import           Data.Maybe                (mapMaybe)
import qualified Data.Vector.Unboxed       as V
import qualified Geom2D.CubicBezier.Linear as Bezier
import           Graphics.SvgTree          (Coord, Origin (OriginAbsolute, OriginRelative),
                                            PathCommand (..), RPoint, Tree, mapTree, pathDefinition,
                                            pattern PathTree)
import           Linear.Metric             (Metric (distance))
import           Linear.V2                 (R1 (_x), R2 (_y), V2 (V2))
import           Linear.Vector             (Additive (lerp, zero))

-- | Line command monad used for keeping track of the current location.
type CmdM a = State RPoint a

-- | Simplified version of a PathCommand where all points are absolute.
data LineCommand
  = LineMove RPoint
  | -- | LineDraw RPoint
    LineBezier [RPoint]
  | LineEnd RPoint
  deriving (Int -> LineCommand -> ShowS
[LineCommand] -> ShowS
LineCommand -> String
(Int -> LineCommand -> ShowS)
-> (LineCommand -> String)
-> ([LineCommand] -> ShowS)
-> Show LineCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineCommand] -> ShowS
$cshowList :: [LineCommand] -> ShowS
show :: LineCommand -> String
$cshow :: LineCommand -> String
showsPrec :: Int -> LineCommand -> ShowS
$cshowsPrec :: Int -> LineCommand -> ShowS
Show)

-- | Convert from line commands to path commands.
lineToPath :: [LineCommand] -> [PathCommand]
lineToPath :: [LineCommand] -> [PathCommand]
lineToPath = (LineCommand -> PathCommand) -> [LineCommand] -> [PathCommand]
forall a b. (a -> b) -> [a] -> [b]
map LineCommand -> PathCommand
worker
  where
    worker :: LineCommand -> PathCommand
worker (LineMove RPoint
p)           = Origin -> [RPoint] -> PathCommand
MoveTo Origin
OriginAbsolute [RPoint
p]
    -- worker (LineDraw p)         = LineTo OriginAbsolute [p]
    worker (LineBezier [RPoint
a, RPoint
b, RPoint
c]) = Origin -> [(RPoint, RPoint, RPoint)] -> PathCommand
CurveTo Origin
OriginAbsolute [(RPoint
a, RPoint
b, RPoint
c)]
    worker (LineBezier [RPoint
a, RPoint
b])    = Origin -> [(RPoint, RPoint)] -> PathCommand
QuadraticBezier Origin
OriginAbsolute [(RPoint
a, RPoint
b)]
    worker (LineBezier [RPoint
a])       = Origin -> [RPoint] -> PathCommand
LineTo Origin
OriginAbsolute [RPoint
a]
    worker LineBezier {}          = String -> PathCommand
forall a. HasCallStack => String -> a
error String
"Reanimate.Svg.lineToPath: invalid bezier curve"
    worker LineEnd {}             = PathCommand
EndPath

-- | Using @n@ control points, approximate the path of the curves.
lineToPoints :: Int -> [LineCommand] -> [RPoint]
lineToPoints :: Int -> [LineCommand] -> [RPoint]
lineToPoints Int
nPoints [LineCommand]
cmds =
  ([LineCommand] -> Maybe RPoint) -> [[LineCommand]] -> [RPoint]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [LineCommand] -> Maybe RPoint
lineEnd [[LineCommand]]
lineSegments
  where
    lineSegments :: [[LineCommand]]
lineSegments = [Double -> [LineCommand] -> [LineCommand]
partialLine (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nPoints) [LineCommand]
cmds | Int
n <- [Int
0 .. Int
nPoints Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
    lineEnd :: [LineCommand] -> Maybe RPoint
lineEnd []               = Maybe RPoint
forall a. Maybe a
Nothing
    lineEnd [LineBezier [RPoint]
pts] = RPoint -> Maybe RPoint
forall a. a -> Maybe a
Just ([RPoint] -> RPoint
forall a. [a] -> a
last [RPoint]
pts)
    lineEnd (LineCommand
_ : [LineCommand]
xs)         = [LineCommand] -> Maybe RPoint
lineEnd [LineCommand]
xs

partialLine :: Double -> [LineCommand] -> [LineCommand]
partialLine :: Double -> [LineCommand] -> [LineCommand]
partialLine Double
alpha [LineCommand]
cmds = State RPoint [LineCommand] -> RPoint -> [LineCommand]
forall s a. State s a -> s -> a
evalState (Double -> [LineCommand] -> State RPoint [LineCommand]
worker Double
0 [LineCommand]
cmds) RPoint
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  where
    worker :: Double -> [LineCommand] -> State RPoint [LineCommand]
worker Double
_d [] = [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    worker Double
d (LineCommand
cmd : [LineCommand]
xs) = do
      RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get
      Double
len <- LineCommand -> CmdM Double
lineLength LineCommand
cmd
      let frac :: Double
frac = (Double
targetLen Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
d) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
len
      if Double
len Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
|| Double
frac Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1
        then (LineCommand
cmd LineCommand -> [LineCommand] -> [LineCommand]
forall a. a -> [a] -> [a]
:) ([LineCommand] -> [LineCommand])
-> State RPoint [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> [LineCommand] -> State RPoint [LineCommand]
worker (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
len) [LineCommand]
xs
        else [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Double -> RPoint -> LineCommand -> LineCommand
adjustLineLength Double
frac RPoint
from LineCommand
cmd]
    totalLen :: Double
totalLen = CmdM Double -> RPoint -> Double
forall s a. State s a -> s -> a
evalState ([Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double)
-> StateT RPoint Identity [Double] -> CmdM Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LineCommand -> CmdM Double)
-> [LineCommand] -> StateT RPoint Identity [Double]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LineCommand -> CmdM Double
lineLength [LineCommand]
cmds) RPoint
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
    targetLen :: Double
targetLen = Double
totalLen Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
alpha

adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
adjustLineLength Double
alpha RPoint
from LineCommand
cmd =
  case LineCommand
cmd of
    LineBezier [RPoint]
points -> [RPoint] -> LineCommand
LineBezier ([RPoint] -> LineCommand) -> [RPoint] -> LineCommand
forall a b. (a -> b) -> a -> b
$ Int -> [RPoint] -> [RPoint]
forall a. Int -> [a] -> [a]
drop Int
1 ([RPoint] -> [RPoint]) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> a -> b
$ [RPoint] -> Double -> Double -> [RPoint]
partialBezierPoints (RPoint
from RPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
: [RPoint]
points) Double
0 Double
alpha
    LineMove RPoint
p        -> RPoint -> LineCommand
LineMove RPoint
p
    -- LineDraw t -> LineDraw (lerp alpha t from)
    LineEnd RPoint
p         -> [RPoint] -> LineCommand
LineBezier [Double -> RPoint -> RPoint -> RPoint
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp Double
alpha RPoint
p RPoint
from]

-- | Estimated length of all segments in a line.
lineLength :: LineCommand -> CmdM Double
lineLength :: LineCommand -> CmdM Double
lineLength LineCommand
cmd =
  case LineCommand
cmd of
    LineMove RPoint
to -> Double
0 Double -> StateT RPoint Identity () -> CmdM Double
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
to
    -- Straight line:
    LineBezier [RPoint
dst] -> (RPoint -> Double) -> CmdM Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (RPoint -> RPoint -> Double
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance RPoint
dst) CmdM Double -> StateT RPoint Identity () -> CmdM Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
dst
    -- Some kind of curve:
    LineBezier [RPoint]
lst -> do
      RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get
      let bezier :: CubicBezier Double
bezier = [RPoint] -> CubicBezier Double
rpointsToBezier (RPoint
from RPoint -> [RPoint] -> [RPoint]
forall a. a -> [a] -> [a]
: [RPoint]
lst)
          tol :: Double
tol = Double
0.0001
      RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([RPoint] -> RPoint
forall a. [a] -> a
last [RPoint]
lst)
      Double -> CmdM Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> CmdM Double) -> Double -> CmdM Double
forall a b. (a -> b) -> a -> b
$ CubicBezier Double -> Double -> Double -> Double
Bezier.arcLength CubicBezier Double
bezier Double
1 Double
tol
    LineEnd RPoint
to -> (RPoint -> Double) -> CmdM Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (RPoint -> RPoint -> Double
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance RPoint
to) CmdM Double -> StateT RPoint Identity () -> CmdM Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
to

rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double
rpointsToBezier :: [RPoint] -> CubicBezier Double
rpointsToBezier [RPoint]
lst =
  case [RPoint]
lst of
    [RPoint
a, RPoint
b]       -> RPoint -> RPoint -> RPoint -> RPoint -> CubicBezier Double
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
Bezier.CubicBezier RPoint
a RPoint
a RPoint
b RPoint
b
    [RPoint
a, RPoint
b, RPoint
c]    -> QuadBezier Double -> CubicBezier Double
forall a. Fractional a => QuadBezier a -> CubicBezier a
Bezier.quadToCubic (RPoint -> RPoint -> RPoint -> QuadBezier Double
forall a. V2 a -> V2 a -> V2 a -> QuadBezier a
Bezier.QuadBezier RPoint
a RPoint
b RPoint
c)
    [RPoint
a, RPoint
b, RPoint
c, RPoint
d] -> RPoint -> RPoint -> RPoint -> RPoint -> CubicBezier Double
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
Bezier.CubicBezier RPoint
a RPoint
b RPoint
c RPoint
d
    [RPoint]
_            -> String -> CubicBezier Double
forall a. HasCallStack => String -> a
error (String -> CubicBezier Double) -> String -> CubicBezier Double
forall a b. (a -> b) -> a -> b
$ String
"rpointsToBezier: Invalid list of points: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [RPoint] -> String
forall a. Show a => a -> String
show [RPoint]
lst

-- | Convert from path commands to line commands.
toLineCommands :: [PathCommand] -> [LineCommand]
toLineCommands :: [PathCommand] -> [LineCommand]
toLineCommands [PathCommand]
ps = State RPoint [LineCommand] -> RPoint -> [LineCommand]
forall s a. State s a -> s -> a
evalState (RPoint
-> Maybe RPoint -> [PathCommand] -> State RPoint [LineCommand]
worker RPoint
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero Maybe RPoint
forall a. Maybe a
Nothing [PathCommand]
ps) RPoint
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  where
    worker :: RPoint
-> Maybe RPoint -> [PathCommand] -> State RPoint [LineCommand]
worker RPoint
_startPos Maybe RPoint
_mbPrevControlPt [] = [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    worker RPoint
startPos Maybe RPoint
mbPrevControlPt (PathCommand
cmd : [PathCommand]
cmds) = do
      [LineCommand]
lcmds <- RPoint -> Maybe RPoint -> PathCommand -> State RPoint [LineCommand]
toLineCommand RPoint
startPos Maybe RPoint
mbPrevControlPt PathCommand
cmd
      let startPos' :: RPoint
startPos' =
            case [LineCommand]
lcmds of
              [LineMove RPoint
pos] -> RPoint
pos
              [LineCommand]
_              -> RPoint
startPos
      ([LineCommand]
lcmds [LineCommand] -> [LineCommand] -> [LineCommand]
forall a. [a] -> [a] -> [a]
++) ([LineCommand] -> [LineCommand])
-> State RPoint [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RPoint
-> Maybe RPoint -> [PathCommand] -> State RPoint [LineCommand]
worker RPoint
startPos' (LineCommand -> Maybe RPoint
cmdToControlPoint (LineCommand -> Maybe RPoint) -> LineCommand -> Maybe RPoint
forall a b. (a -> b) -> a -> b
$ [LineCommand] -> LineCommand
forall a. [a] -> a
last [LineCommand]
lcmds) [PathCommand]
cmds

cmdToControlPoint :: LineCommand -> Maybe RPoint
cmdToControlPoint :: LineCommand -> Maybe RPoint
cmdToControlPoint (LineBezier [RPoint]
points) = RPoint -> Maybe RPoint
forall a. a -> Maybe a
Just ([RPoint] -> RPoint
forall a. [a] -> a
last ([RPoint] -> [RPoint]
forall a. [a] -> [a]
init [RPoint]
points))
cmdToControlPoint LineCommand
_                   = Maybe RPoint
forall a. Maybe a
Nothing

mkStraightLine :: RPoint -> LineCommand
mkStraightLine :: RPoint -> LineCommand
mkStraightLine RPoint
p = [RPoint] -> LineCommand
LineBezier [RPoint
p]

toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand]
toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> State RPoint [LineCommand]
toLineCommand RPoint
startPos Maybe RPoint
mbPrevControlPt PathCommand
cmd =
  case PathCommand
cmd of
    MoveTo Origin
OriginAbsolute [] -> [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    MoveTo Origin
OriginAbsolute [RPoint]
lst -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([RPoint] -> RPoint
forall a. [a] -> a
last [RPoint]
lst) StateT RPoint Identity ()
-> State RPoint [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> [LineCommand]) -> State RPoint [LineCommand]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (LineCommand -> [LineCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineCommand -> [LineCommand])
-> (RPoint -> LineCommand) -> RPoint -> [LineCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> LineCommand
LineMove)
    MoveTo Origin
OriginRelative [RPoint]
lst -> (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ [RPoint] -> RPoint
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [RPoint]
lst) StateT RPoint Identity ()
-> State RPoint [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> [LineCommand]) -> State RPoint [LineCommand]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (LineCommand -> [LineCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineCommand -> [LineCommand])
-> (RPoint -> LineCommand) -> RPoint -> [LineCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> LineCommand
LineMove)
    LineTo Origin
OriginAbsolute [RPoint]
lst -> [RPoint]
-> (RPoint -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RPoint]
lst (\RPoint
to -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
to StateT RPoint Identity ()
-> LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> RPoint -> LineCommand
mkStraightLine RPoint
to)
    LineTo Origin
OriginRelative [RPoint]
lst -> [RPoint]
-> (RPoint -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RPoint]
lst (\RPoint
to -> (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint
to) StateT RPoint Identity ()
-> StateT RPoint Identity LineCommand
-> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> LineCommand) -> StateT RPoint Identity LineCommand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RPoint -> LineCommand
mkStraightLine)
    HorizontalTo Origin
OriginAbsolute [Double]
lst ->
      [Double]
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Double]
lst ((Double -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \Double
x -> (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Double -> Identity Double) -> RPoint -> Identity RPoint
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x ((Double -> Identity Double) -> RPoint -> Identity RPoint)
-> Double -> RPoint -> RPoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
x) StateT RPoint Identity ()
-> StateT RPoint Identity LineCommand
-> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> LineCommand) -> StateT RPoint Identity LineCommand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RPoint -> LineCommand
mkStraightLine
    HorizontalTo Origin
OriginRelative [Double]
lst ->
      [Double]
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Double]
lst ((Double -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \Double
x -> (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Double -> Identity Double) -> RPoint -> Identity RPoint
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x ((Double -> Identity Double) -> RPoint -> Identity RPoint)
-> (Double -> Double) -> RPoint -> RPoint
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x)) StateT RPoint Identity ()
-> StateT RPoint Identity LineCommand
-> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> LineCommand) -> StateT RPoint Identity LineCommand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RPoint -> LineCommand
mkStraightLine
    VerticalTo Origin
OriginAbsolute [Double]
lst ->
      [Double]
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Double]
lst ((Double -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \Double
y -> (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Double -> Identity Double) -> RPoint -> Identity RPoint
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y ((Double -> Identity Double) -> RPoint -> Identity RPoint)
-> Double -> RPoint -> RPoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
y) StateT RPoint Identity ()
-> StateT RPoint Identity LineCommand
-> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> LineCommand) -> StateT RPoint Identity LineCommand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RPoint -> LineCommand
mkStraightLine
    VerticalTo Origin
OriginRelative [Double]
lst ->
      [Double]
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Double]
lst ((Double -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> (Double -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \Double
y -> (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Double -> Identity Double) -> RPoint -> Identity RPoint
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y ((Double -> Identity Double) -> RPoint -> Identity RPoint)
-> (Double -> Double) -> RPoint -> RPoint
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y)) StateT RPoint Identity ()
-> StateT RPoint Identity LineCommand
-> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RPoint -> LineCommand) -> StateT RPoint Identity LineCommand
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RPoint -> LineCommand
mkStraightLine
    CurveTo Origin
OriginAbsolute [(RPoint, RPoint, RPoint)]
quads ->
      [(RPoint, RPoint, RPoint)]
-> ((RPoint, RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RPoint, RPoint, RPoint)]
quads (((RPoint, RPoint, RPoint) -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> ((RPoint, RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \(RPoint
a, RPoint
b, RPoint
c) -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
c StateT RPoint Identity ()
-> LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [RPoint] -> LineCommand
LineBezier [RPoint
a, RPoint
b, RPoint
c]
    CurveTo Origin
OriginRelative [(RPoint, RPoint, RPoint)]
quads ->
      [(RPoint, RPoint, RPoint)]
-> ((RPoint, RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RPoint, RPoint, RPoint)]
quads (((RPoint, RPoint, RPoint) -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> ((RPoint, RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \(RPoint
a, RPoint
b, RPoint
c) -> do
        RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get StateT RPoint Identity RPoint
-> StateT RPoint Identity () -> StateT RPoint Identity RPoint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint
c)
        LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineCommand -> StateT RPoint Identity LineCommand)
-> LineCommand -> StateT RPoint Identity LineCommand
forall a b. (a -> b) -> a -> b
$ [RPoint] -> LineCommand
LineBezier ([RPoint] -> LineCommand) -> [RPoint] -> LineCommand
forall a b. (a -> b) -> a -> b
$ (RPoint -> RPoint) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint
from) [RPoint
a, RPoint
b, RPoint
c]
    SmoothCurveTo Origin
o [(RPoint, RPoint)]
lst -> ([LineCommand] -> State RPoint [LineCommand])
-> State RPoint [LineCommand]
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (([LineCommand] -> State RPoint [LineCommand])
 -> State RPoint [LineCommand])
-> ([LineCommand] -> State RPoint [LineCommand])
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \[LineCommand]
result -> do
      let ctrl :: [Maybe RPoint]
ctrl = Maybe RPoint
mbPrevControlPt Maybe RPoint -> [Maybe RPoint] -> [Maybe RPoint]
forall a. a -> [a] -> [a]
: (LineCommand -> Maybe RPoint) -> [LineCommand] -> [Maybe RPoint]
forall a b. (a -> b) -> [a] -> [b]
map LineCommand -> Maybe RPoint
cmdToControlPoint [LineCommand]
result
      [((RPoint, RPoint), Maybe RPoint)]
-> (((RPoint, RPoint), Maybe RPoint)
    -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(RPoint, RPoint)]
-> [Maybe RPoint] -> [((RPoint, RPoint), Maybe RPoint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(RPoint, RPoint)]
lst [Maybe RPoint]
ctrl) ((((RPoint, RPoint), Maybe RPoint)
  -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> (((RPoint, RPoint), Maybe RPoint)
    -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \((RPoint
c2, RPoint
to), Maybe RPoint
mbControl) -> do
        RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get StateT RPoint Identity RPoint
-> StateT RPoint Identity () -> StateT RPoint Identity RPoint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Origin -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *).
(MonadState s m, Num s) =>
Origin -> s -> m ()
adjustPosition Origin
o RPoint
to
        let c1 :: RPoint
c1 = RPoint -> (RPoint -> RPoint) -> Maybe RPoint -> RPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Origin -> RPoint -> RPoint -> RPoint
forall a. Num a => Origin -> a -> a -> a
makeAbsolute Origin
o RPoint
from RPoint
c2) (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
mirrorPoint RPoint
from) Maybe RPoint
mbControl
        LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineCommand -> StateT RPoint Identity LineCommand)
-> LineCommand -> StateT RPoint Identity LineCommand
forall a b. (a -> b) -> a -> b
$ [RPoint] -> LineCommand
LineBezier [RPoint
c1, Origin -> RPoint -> RPoint -> RPoint
forall a. Num a => Origin -> a -> a -> a
makeAbsolute Origin
o RPoint
from RPoint
c2, Origin -> RPoint -> RPoint -> RPoint
forall a. Num a => Origin -> a -> a -> a
makeAbsolute Origin
o RPoint
from RPoint
to]
    QuadraticBezier Origin
OriginAbsolute [(RPoint, RPoint)]
pairs ->
      [(RPoint, RPoint)]
-> ((RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RPoint, RPoint)]
pairs (((RPoint, RPoint) -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> ((RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \(RPoint
a, RPoint
b) -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
b StateT RPoint Identity ()
-> LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [RPoint] -> LineCommand
LineBezier [RPoint
a, RPoint
b]
    QuadraticBezier Origin
OriginRelative [(RPoint, RPoint)]
pairs ->
      [(RPoint, RPoint)]
-> ((RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RPoint, RPoint)]
pairs (((RPoint, RPoint) -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> ((RPoint, RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \(RPoint
a, RPoint
b) -> do
        RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get StateT RPoint Identity RPoint
-> StateT RPoint Identity () -> StateT RPoint Identity RPoint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (RPoint -> RPoint) -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint
b)
        LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineCommand -> StateT RPoint Identity LineCommand)
-> LineCommand -> StateT RPoint Identity LineCommand
forall a b. (a -> b) -> a -> b
$ [RPoint] -> LineCommand
LineBezier ([RPoint] -> LineCommand) -> [RPoint] -> LineCommand
forall a b. (a -> b) -> a -> b
$ (RPoint -> RPoint) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint
from) [RPoint
a, RPoint
b]
    SmoothQuadraticBezierCurveTo Origin
o [RPoint]
lst -> ([LineCommand] -> State RPoint [LineCommand])
-> State RPoint [LineCommand]
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (([LineCommand] -> State RPoint [LineCommand])
 -> State RPoint [LineCommand])
-> ([LineCommand] -> State RPoint [LineCommand])
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \[LineCommand]
result -> do
      let ctrl :: [Maybe RPoint]
ctrl = Maybe RPoint
mbPrevControlPt Maybe RPoint -> [Maybe RPoint] -> [Maybe RPoint]
forall a. a -> [a] -> [a]
: (LineCommand -> Maybe RPoint) -> [LineCommand] -> [Maybe RPoint]
forall a b. (a -> b) -> [a] -> [b]
map LineCommand -> Maybe RPoint
cmdToControlPoint [LineCommand]
result
      [(RPoint, Maybe RPoint)]
-> ((RPoint, Maybe RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([RPoint] -> [Maybe RPoint] -> [(RPoint, Maybe RPoint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [RPoint]
lst [Maybe RPoint]
ctrl) (((RPoint, Maybe RPoint) -> StateT RPoint Identity LineCommand)
 -> State RPoint [LineCommand])
-> ((RPoint, Maybe RPoint) -> StateT RPoint Identity LineCommand)
-> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ \(RPoint
to, Maybe RPoint
mbControl) -> do
        RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get StateT RPoint Identity RPoint
-> StateT RPoint Identity () -> StateT RPoint Identity RPoint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Origin -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *).
(MonadState s m, Num s) =>
Origin -> s -> m ()
adjustPosition Origin
o RPoint
to
        let c1 :: RPoint
c1 = RPoint -> (RPoint -> RPoint) -> Maybe RPoint -> RPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RPoint
from (RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
mirrorPoint RPoint
from) Maybe RPoint
mbControl
        LineCommand -> StateT RPoint Identity LineCommand
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LineCommand -> StateT RPoint Identity LineCommand)
-> LineCommand -> StateT RPoint Identity LineCommand
forall a b. (a -> b) -> a -> b
$ [RPoint] -> LineCommand
LineBezier [RPoint
c1, Origin -> RPoint -> RPoint -> RPoint
forall a. Num a => Origin -> a -> a -> a
makeAbsolute Origin
o RPoint
from RPoint
to]
    EllipticalArc Origin
o [(Double, Double, Double, Bool, Bool, RPoint)]
points ->
      [[LineCommand]] -> [LineCommand]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        ([[LineCommand]] -> [LineCommand])
-> StateT RPoint Identity [[LineCommand]]
-> State RPoint [LineCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Double, Double, Double, Bool, Bool, RPoint)]
-> ((Double, Double, Double, Bool, Bool, RPoint)
    -> State RPoint [LineCommand])
-> StateT RPoint Identity [[LineCommand]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
          [(Double, Double, Double, Bool, Bool, RPoint)]
points
          ( \(Double
rotX, Double
rotY, Double
angle, Bool
largeArc, Bool
sweepFlag, RPoint
to) -> do
              RPoint
from <- StateT RPoint Identity RPoint
forall s (m :: * -> *). MonadState s m => m s
get StateT RPoint Identity RPoint
-> StateT RPoint Identity () -> StateT RPoint Identity RPoint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Origin -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *).
(MonadState s m, Num s) =>
Origin -> s -> m ()
adjustPosition Origin
o RPoint
to
              [LineCommand] -> State RPoint [LineCommand]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LineCommand] -> State RPoint [LineCommand])
-> [LineCommand] -> State RPoint [LineCommand]
forall a b. (a -> b) -> a -> b
$ RPoint
-> Double
-> Double
-> Double
-> Bool
-> Bool
-> RPoint
-> [LineCommand]
convertSvgArc RPoint
from Double
rotX Double
rotY Double
angle Bool
largeArc Bool
sweepFlag (Origin -> RPoint -> RPoint -> RPoint
forall a. Num a => Origin -> a -> a -> a
makeAbsolute Origin
o RPoint
from RPoint
to)
          )
    PathCommand
EndPath -> RPoint -> StateT RPoint Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RPoint
startPos StateT RPoint Identity ()
-> [LineCommand] -> State RPoint [LineCommand]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [RPoint -> LineCommand
LineEnd RPoint
startPos]
  where
    mirrorPoint :: a -> a -> a
mirrorPoint a
c a
p = a
c a -> a -> a
forall a. Num a => a -> a -> a
* a
2 a -> a -> a
forall a. Num a => a -> a -> a
- a
p
    adjustPosition :: Origin -> s -> m ()
adjustPosition Origin
OriginRelative s
p = (s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (s -> s -> s
forall a. Num a => a -> a -> a
+ s
p)
    adjustPosition Origin
OriginAbsolute s
p = s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
p
    makeAbsolute :: Origin -> a -> a -> a
makeAbsolute Origin
OriginAbsolute a
_from a
p = a
p
    makeAbsolute Origin
OriginRelative a
from a
p  = a
from a -> a -> a
forall a. Num a => a -> a -> a
+ a
p

calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
calculateVectorAngle Double
ux Double
uy Double
vx Double
vy
  | Double
tb Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
ta =
    Double
tb Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ta
  | Bool
otherwise =
    Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
ta Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tb)
  where
    ta :: Double
ta = Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
uy Double
ux
    tb :: Double
tb = Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
vy Double
vx

-- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs
{- HLINT ignore convertSvgArc -}
convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand]
convertSvgArc :: RPoint
-> Double
-> Double
-> Double
-> Bool
-> Bool
-> RPoint
-> [LineCommand]
convertSvgArc (V2 Double
x0 Double
y0) Double
radiusX Double
radiusY Double
angle Bool
largeArcFlag Bool
sweepFlag (V2 Double
x Double
y)
  | Double
x0 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
x Bool -> Bool -> Bool
&& Double
y0 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y =
    []
  | Double
radiusX Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0 Bool -> Bool -> Bool
&& Double
radiusY Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0 =
    [[RPoint] -> LineCommand
LineBezier [Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
x Double
y]]
  | Bool
otherwise =
    Double -> Double -> Double -> Integer -> [LineCommand]
forall t.
(Eq t, Num t) =>
Double -> Double -> Double -> t -> [LineCommand]
calcSegments Double
x0 Double
y0 Double
theta1' Integer
segments'
  where
    sinPhi :: Double
sinPhi = Double -> Double
forall a. Floating a => a -> a
sin (Double
angle 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)
    cosPhi :: Double
cosPhi = Double -> Double
forall a. Floating a => a -> a
cos (Double
angle 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)

    x1dash :: Double
x1dash = Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
x0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
y0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0
    y1dash :: Double
y1dash = - Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
x0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
y0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0

    numerator :: Double
numerator = Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x1dash

    s :: Double
s = Double -> Double
forall a. Floating a => a -> a
sqrt (Double
1.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
numerator Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusY))
    rx :: Double
rx = if (Double
numerator Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.0) then (Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s) else Double
radiusX
    ry :: Double
ry = if (Double
numerator Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.0) then (Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
s) else Double
radiusY
    root :: Double
root =
      if (Double
numerator Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.0)
        then (Double
0.0)
        else
          ( (if ((Bool
largeArcFlag Bool -> Bool -> Bool
&& Bool
sweepFlag) Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
largeArcFlag Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sweepFlag)) then (-Double
1.0) else Double
1.0)
              Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sqrt (Double
numerator Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radiusY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x1dash))
          )

    cxdash :: Double
cxdash = Double
root Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y1dash Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ry
    cydash :: Double
cydash = - Double
root Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x1dash Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
rx

    cx :: Double
cx = Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cxdash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cydash Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
x0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0
    cy :: Double
cy = Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cxdash Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cydash Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
y0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0

    theta1' :: Double
theta1' = Double -> Double -> Double -> Double -> Double
calculateVectorAngle Double
1.0 Double
0.0 ((Double
x1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cxdash) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
rx) ((Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cydash) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ry)
    dtheta' :: Double
dtheta' = Double -> Double -> Double -> Double -> Double
calculateVectorAngle ((Double
x1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cxdash) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
rx) ((Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cydash) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ry) ((- Double
x1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cxdash) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
rx) ((- Double
y1dash Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cydash) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ry)
    dtheta :: Double
dtheta =
      if (Bool -> Bool
not Bool
sweepFlag Bool -> Bool -> Bool
&& Double
dtheta' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)
        then (Double
dtheta' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi)
        else (if (Bool
sweepFlag Bool -> Bool -> Bool
&& Double
dtheta' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0) then Double
dtheta' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi else Double
dtheta')

    segments' :: Integer
segments' = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double
forall a. Num a => a -> a
abs (Double
dtheta Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0)))
    delta :: Double
delta = Double
dtheta Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
segments'
    t :: Double
t = Double
8.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Double
delta Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
4.0) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Double
delta Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
4.0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sin (Double
delta Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0)

    calcSegments :: Double -> Double -> Double -> t -> [LineCommand]
calcSegments Double
startX Double
startY Double
theta1 t
segments
      | t
segments t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 =
        []
      | Bool
otherwise =
        [RPoint] -> LineCommand
LineBezier
          [ Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 (Double
startX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dx1) (Double
startY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dy1),
            Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 (Double
endpointX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dxe) (Double
endpointY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
dye),
            Double -> Double -> RPoint
forall a. a -> a -> V2 a
V2 Double
endpointX Double
endpointY
          ] LineCommand -> [LineCommand] -> [LineCommand]
forall a. a -> [a] -> [a]
:
        Double -> Double -> Double -> t -> [LineCommand]
calcSegments Double
endpointX Double
endpointY Double
theta2 (t
segments t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
      where
        cosTheta1 :: Double
cosTheta1 = Double -> Double
forall a. Floating a => a -> a
cos Double
theta1
        sinTheta1 :: Double
sinTheta1 = Double -> Double
forall a. Floating a => a -> a
sin Double
theta1
        theta2 :: Double
theta2 = Double
theta1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
delta
        cosTheta2 :: Double
cosTheta2 = Double -> Double
forall a. Floating a => a -> a
cos Double
theta2
        sinTheta2 :: Double
sinTheta2 = Double -> Double
forall a. Floating a => a -> a
sin Double
theta2

        endpointX :: Double
endpointX = Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cosTheta2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sinTheta2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
cx
        endpointY :: Double
endpointY = Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cosTheta2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sinTheta2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
cy

        dx1 :: Double
dx1 = Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* (- Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sinTheta1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cosTheta1)
        dy1 :: Double
dy1 = Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* (- Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sinTheta1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cosTheta1)

        dxe :: Double
dxe = Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sinTheta2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cosTheta2)
        dye :: Double
dye = Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
sinPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sinTheta2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cosPhi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ry Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cosTheta2)

partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint]
partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint]
partialBezierPoints [RPoint]
ps Double
a Double
b =
  let c1 :: AnyBezier Double
c1 = Vector RPoint -> AnyBezier Double
forall a. Vector (V2 a) -> AnyBezier a
Bezier.AnyBezier ([RPoint] -> Vector RPoint
forall a. Unbox a => [a] -> Vector a
V.fromList [RPoint]
ps)
      Bezier.AnyBezier Vector RPoint
os = AnyBezier Double -> Double -> Double -> AnyBezier Double
forall a (b :: * -> *).
(Ord a, Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> a -> b a
Bezier.bezierSubsegment AnyBezier Double
c1 Double
a Double
b
   in Vector RPoint -> [RPoint]
forall a. Unbox a => Vector a -> [a]
V.toList Vector RPoint
os

-- | Create an image showing portion of a path.
--     Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath').
--     You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify').
--
--     Typical usage:
--
--    > animate $ \t -> partialSvg t myPath
partialSvg ::
  -- | number between 0 and 1 inclusively, determining what portion of the path to show
  Double ->
  -- | Image representing a path, of which we only want to display a portion determined by the first argument
  Tree ->
  Tree
partialSvg :: Double -> Tree -> Tree
partialSvg Double
alpha | Double
alpha Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1 = Tree -> Tree
forall a. a -> a
id
partialSvg Double
alpha = (Tree -> Tree) -> Tree -> Tree
mapTree Tree -> Tree
worker
  where
    worker :: Tree -> Tree
worker (PathTree Path
path) =
      Path -> Tree
PathTree (Path -> Tree) -> Path -> Tree
forall a b. (a -> b) -> a -> b
$ Path
path Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> ([PathCommand] -> [PathCommand]) -> Path -> Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [LineCommand] -> [PathCommand]
lineToPath ([LineCommand] -> [PathCommand])
-> ([PathCommand] -> [LineCommand])
-> [PathCommand]
-> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [LineCommand] -> [LineCommand]
partialLine Double
alpha ([LineCommand] -> [LineCommand])
-> ([PathCommand] -> [LineCommand])
-> [PathCommand]
-> [LineCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathCommand] -> [LineCommand]
toLineCommands
    worker Tree
t = Tree
t