{-# OPTIONS_GHC -Wno-type-defaults #-}

module Svgone.Plugin.MergePaths (P, PluginOptions (..), PathStyle (..)) where

import Control.Lens
import Control.Monad
import Data.Either
import Data.Either.Extra
import Data.Generics.Labels ()
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Monoid
import Data.Tuple
import GHC.Generics
import Graphics.SvgTree hiding (Text)
import Linear
import Svgone.Plugin
import Util

data P
type Opts = PluginOptions P

data PathStyle
    = -- | Just use absolute coordinates.
      AbsolutePath
    | -- | Use relative offsets and horizontal/vertical lines where possible.
      SmartPath

instance Plugin P where
    data PluginOptions P = Opts
        { -- | For floating-point equality.
          PluginOptions P -> Double
optsTolerance :: Double
        , PluginOptions P -> PathStyle
pathStyle :: PathStyle
        }
    defaultOpts :: PluginOptions P
defaultOpts = Double -> PathStyle -> PluginOptions P
Opts Double
1 PathStyle
SmartPath
    plugin :: Opts -> Document -> Document
    plugin :: PluginOptions P -> Document -> Document
plugin PluginOptions P
opts = ([Tree] -> Identity [Tree]) -> Document -> Identity Document
Lens' Document [Tree]
documentElements (([Tree] -> Identity [Tree]) -> Document -> Identity Document)
-> ([Tree] -> [Tree]) -> Document -> Document
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TreeBranch -> Tree) -> [TreeBranch] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map TreeBranch -> Tree
Tree ([TreeBranch] -> [Tree])
-> ([Tree] -> [TreeBranch]) -> [Tree] -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginOptions P -> [TreeBranch] -> [TreeBranch]
branches PluginOptions P
opts ([TreeBranch] -> [TreeBranch])
-> ([Tree] -> [TreeBranch]) -> [Tree] -> [TreeBranch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree -> TreeBranch) -> [Tree] -> [TreeBranch]
forall a b. (a -> b) -> [a] -> [b]
map (Tree -> Getting TreeBranch Tree TreeBranch -> TreeBranch
forall s a. s -> Getting a s a -> a
^. Getting TreeBranch Tree TreeBranch
Lens' Tree TreeBranch
treeBranch)
    pluginName :: Text
pluginName = Text
"merge-paths"

branches :: Opts -> [TreeBranch] -> [TreeBranch]
branches :: PluginOptions P -> [TreeBranch] -> [TreeBranch]
branches PluginOptions P
opts [TreeBranch]
bs = [TreeBranch]
polygons' [TreeBranch] -> [TreeBranch] -> [TreeBranch]
forall a. [a] -> [a] -> [a]
++ [TreeBranch]
nonPolygons
  where
    ([TreeBranch]
nonPolygons, [(DrawAttributes, PolygonPath)]
polygons) = [Either TreeBranch (DrawAttributes, PolygonPath)]
-> ([TreeBranch], [(DrawAttributes, PolygonPath)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either TreeBranch (DrawAttributes, PolygonPath)]
 -> ([TreeBranch], [(DrawAttributes, PolygonPath)]))
-> [Either TreeBranch (DrawAttributes, PolygonPath)]
-> ([TreeBranch], [(DrawAttributes, PolygonPath)])
forall a b. (a -> b) -> a -> b
$ (TreeBranch -> Either TreeBranch (DrawAttributes, PolygonPath))
-> [TreeBranch]
-> [Either TreeBranch (DrawAttributes, PolygonPath)]
forall a b. (a -> b) -> [a] -> [b]
map (\TreeBranch
b -> TreeBranch
-> Maybe (DrawAttributes, PolygonPath)
-> Either TreeBranch (DrawAttributes, PolygonPath)
forall a b. a -> Maybe b -> Either a b
maybeToEither TreeBranch
b (Maybe (DrawAttributes, PolygonPath)
 -> Either TreeBranch (DrawAttributes, PolygonPath))
-> Maybe (DrawAttributes, PolygonPath)
-> Either TreeBranch (DrawAttributes, PolygonPath)
forall a b. (a -> b) -> a -> b
$ Path -> Maybe (DrawAttributes, PolygonPath)
toPolygonPath (Path -> Maybe (DrawAttributes, PolygonPath))
-> Maybe Path -> Maybe (DrawAttributes, PolygonPath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeBranch -> Maybe Path
pathBranch TreeBranch
b) [TreeBranch]
bs
    polygons' :: [TreeBranch]
polygons' = do
        (DrawAttributes
attrs, NonEmpty PolygonPath
paths) <- (DrawAttributes, PolygonPath) -> PolygonPath
forall a b. (a, b) -> b
snd ((DrawAttributes, PolygonPath) -> PolygonPath)
-> [(DrawAttributes, NonEmpty (DrawAttributes, PolygonPath))]
-> [(DrawAttributes, NonEmpty PolygonPath)]
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
(Functor f, Functor g, Functor h) =>
(a -> b) -> f (g (h a)) -> f (g (h b))
<<<$>>> ((DrawAttributes, PolygonPath) -> DrawAttributes)
-> [(DrawAttributes, PolygonPath)]
-> [(DrawAttributes, NonEmpty (DrawAttributes, PolygonPath))]
forall b a. Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
classifyOn (DrawAttributes, PolygonPath) -> DrawAttributes
forall a b. (a, b) -> a
fst [(DrawAttributes, PolygonPath)]
polygons
        PolygonPath
merged <- PluginOptions P -> [PolygonPath] -> [PolygonPath]
mergePaths PluginOptions P
opts ([PolygonPath] -> [PolygonPath]) -> [PolygonPath] -> [PolygonPath]
forall a b. (a -> b) -> a -> b
$ NonEmpty PolygonPath -> [PolygonPath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PolygonPath
paths
        TreeBranch -> [TreeBranch]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeBranch -> [TreeBranch]) -> TreeBranch -> [TreeBranch]
forall a b. (a -> b) -> a -> b
$ Path -> TreeBranch
PathNode (Path -> TreeBranch) -> Path -> TreeBranch
forall a b. (a -> b) -> a -> b
$ PluginOptions P -> PolygonPath -> DrawAttributes -> Path
fromPolygonPath PluginOptions P
opts PolygonPath
merged DrawAttributes
attrs

mergePaths :: Opts -> [PolygonPath] -> [PolygonPath]
mergePaths :: PluginOptions P -> [PolygonPath] -> [PolygonPath]
mergePaths PluginOptions P
opts = \case
    [] -> []
    PolygonPath
p : [PolygonPath]
ps -> case ((PolygonPath, [PolygonPath])
 -> Maybe ([PolygonPath], PolygonPath))
-> [(PolygonPath, [PolygonPath])] -> [([PolygonPath], PolygonPath)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((PolygonPath -> Maybe PolygonPath)
-> ([PolygonPath], PolygonPath)
-> Maybe ([PolygonPath], PolygonPath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PluginOptions P -> PolygonPath -> PolygonPath -> Maybe PolygonPath
mergePaths2 PluginOptions P
opts PolygonPath
p) (([PolygonPath], PolygonPath)
 -> Maybe ([PolygonPath], PolygonPath))
-> ((PolygonPath, [PolygonPath]) -> ([PolygonPath], PolygonPath))
-> (PolygonPath, [PolygonPath])
-> Maybe ([PolygonPath], PolygonPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolygonPath, [PolygonPath]) -> ([PolygonPath], PolygonPath)
forall a b. (a, b) -> (b, a)
swap) ([(PolygonPath, [PolygonPath])] -> [([PolygonPath], PolygonPath)])
-> [(PolygonPath, [PolygonPath])] -> [([PolygonPath], PolygonPath)]
forall a b. (a -> b) -> a -> b
$ [PolygonPath] -> [(PolygonPath, [PolygonPath])]
forall a. [a] -> [(a, [a])]
select [PolygonPath]
ps of
        -- p can't be merged with any shape in ps
        [] -> PolygonPath
p PolygonPath -> [PolygonPath] -> [PolygonPath]
forall a. a -> [a] -> [a]
: PluginOptions P -> [PolygonPath] -> [PolygonPath]
mergePaths PluginOptions P
opts [PolygonPath]
ps
        -- p' is p merged with whichever path is missing from ps' - run again
        ([PolygonPath]
ps', PolygonPath
p') : [([PolygonPath], PolygonPath)]
_ -> PluginOptions P -> [PolygonPath] -> [PolygonPath]
mergePaths PluginOptions P
opts ([PolygonPath] -> [PolygonPath]) -> [PolygonPath] -> [PolygonPath]
forall a b. (a -> b) -> a -> b
$ PolygonPath
p' PolygonPath -> [PolygonPath] -> [PolygonPath]
forall a. a -> [a] -> [a]
: [PolygonPath]
ps'

mergePaths2 :: Opts -> PolygonPath -> PolygonPath -> Maybe PolygonPath
mergePaths2 :: PluginOptions P -> PolygonPath -> PolygonPath -> Maybe PolygonPath
mergePaths2 Opts{..} PolygonPath
us PolygonPath
vs =
    [PolygonPath] -> Maybe PolygonPath
forall a. [a] -> Maybe a
listToMaybe ([PolygonPath] -> Maybe PolygonPath)
-> ([Maybe PolygonPath] -> [PolygonPath])
-> [Maybe PolygonPath]
-> Maybe PolygonPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe PolygonPath] -> [PolygonPath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe PolygonPath] -> Maybe PolygonPath)
-> [Maybe PolygonPath] -> Maybe PolygonPath
forall a b. (a -> b) -> a -> b
$
        PolygonPath -> PolygonPath -> Maybe PolygonPath
mergeOne
            (PolygonPath -> PolygonPath -> Maybe PolygonPath)
-> [PolygonPath] -> [PolygonPath -> Maybe PolygonPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IsLabel
  "unPolygonPath"
  ((NonEmpty (V2 Double) -> [NonEmpty (V2 Double)])
   -> PolygonPath -> [PolygonPath])
(NonEmpty (V2 Double) -> [NonEmpty (V2 Double)])
-> PolygonPath -> [PolygonPath]
#unPolygonPath NonEmpty (V2 Double) -> [NonEmpty (V2 Double)]
forall a. NonEmpty a -> [NonEmpty a]
equivalentCycles PolygonPath
us
            [PolygonPath -> Maybe PolygonPath]
-> [PolygonPath] -> [Maybe PolygonPath]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IsLabel
  "unPolygonPath"
  ((NonEmpty (V2 Double) -> [NonEmpty (V2 Double)])
   -> PolygonPath -> [PolygonPath])
(NonEmpty (V2 Double) -> [NonEmpty (V2 Double)])
-> PolygonPath -> [PolygonPath]
#unPolygonPath NonEmpty (V2 Double) -> [NonEmpty (V2 Double)]
forall a. NonEmpty a -> [NonEmpty a]
equivalentCycles PolygonPath
vs
  where
    V2 Double
a ~= :: V2 Double -> V2 Double -> Bool
~= V2 Double
b = V2 Double -> V2 Double -> Double
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
a V2 Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
optsTolerance
    mergeOne :: PolygonPath -> PolygonPath -> Maybe PolygonPath
mergeOne (PolygonPath (V2 Double
u0 :| [V2 Double]
us0)) (PolygonPath (V2 Double
v0 :| [V2 Double]
vs0)) = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ V2 Double
u0 V2 Double -> V2 Double -> Bool
~= V2 Double
v0
        V2 Double
u1 : [V2 Double]
_us1 <- [V2 Double] -> Maybe [V2 Double]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [V2 Double]
us0
        V2 Double
v1 : [V2 Double]
vs1 <- [V2 Double] -> Maybe [V2 Double]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [V2 Double]
vs0

        -- we don't care about intersections at the points we're merging
        let here :: V2 Double -> Bool
            here :: V2 Double -> Bool
here V2 Double
w = V2 Double
w V2 Double -> V2 Double -> Bool
~= V2 Double
u0 Bool -> Bool -> Bool
|| V2 Double
w V2 Double -> V2 Double -> Bool
~= V2 Double
u1

        let a :: Double
a = V2 Double -> V2 Double -> Double
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
u0 V2 Double
u1
            b :: Double
b = V2 Double -> V2 Double -> Double
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
u0 V2 Double
v1
            c :: Double
c = V2 Double -> V2 Double -> Double
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
u1 V2 Double
v1
            d :: Double
d = ((Double
a Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
b Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
c Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a)
            r :: Double
r = Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ (Double
b Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
d Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) -- distance from v1 to the closest point on (u0,u1)

        -- avoid exceptions in calculating r
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 -- would mean 'us' contains adjacent duplicates
        -- d is one side of a triangle of which b is the hypotenuse:
        -- this can only fail if v1 is right on the line and we get rounding errors
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
b

        -- v1 is on the line
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
optsTolerance

        -- the shapes have no other intersections
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (V2 Double -> Bool) -> [V2 Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all V2 Double -> Bool
here ([V2 Double] -> Bool) -> [V2 Double] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe (V2 Double)] -> [V2 Double]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (V2 Double)] -> [V2 Double])
-> [Maybe (V2 Double)] -> [V2 Double]
forall a b. (a -> b) -> a -> b
$ (V2 Double, V2 Double)
-> (V2 Double, V2 Double) -> Maybe (V2 Double)
forall a.
(Eq a, Ord a, Fractional a, Show a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
intersectLines ((V2 Double, V2 Double)
 -> (V2 Double, V2 Double) -> Maybe (V2 Double))
-> [(V2 Double, V2 Double)]
-> [(V2 Double, V2 Double) -> Maybe (V2 Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [V2 Double] -> [(V2 Double, V2 Double)]
forall a. [a] -> [(a, a)]
pairAdjacent ([V2 Double]
us0 [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ [V2 Double
u0]) [(V2 Double, V2 Double) -> Maybe (V2 Double)]
-> [(V2 Double, V2 Double)] -> [Maybe (V2 Double)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [V2 Double] -> [(V2 Double, V2 Double)]
forall a. [a] -> [(a, a)]
pairAdjacent ([V2 Double]
vs0 [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ [V2 Double
v0])

        PolygonPath -> Maybe PolygonPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolygonPath -> Maybe PolygonPath)
-> PolygonPath -> Maybe PolygonPath
forall a b. (a -> b) -> a -> b
$ NonEmpty (V2 Double) -> PolygonPath
PolygonPath (NonEmpty (V2 Double) -> PolygonPath)
-> NonEmpty (V2 Double) -> PolygonPath
forall a b. (a -> b) -> a -> b
$ V2 Double
u0 V2 Double -> [V2 Double] -> NonEmpty (V2 Double)
forall a. a -> [a] -> NonEmpty a
:| [V2 Double] -> [V2 Double]
forall a. [a] -> [a]
reverse [V2 Double]
us0 [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ [V2 Double
v1 | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ V2 Double
u1 V2 Double -> V2 Double -> Bool
~= V2 Double
v1] [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ [V2 Double]
vs1

newtype PolygonPath = PolygonPath {PolygonPath -> NonEmpty (V2 Double)
unPolygonPath :: NonEmpty (V2 Double)}
    deriving (PolygonPath -> PolygonPath -> Bool
(PolygonPath -> PolygonPath -> Bool)
-> (PolygonPath -> PolygonPath -> Bool) -> Eq PolygonPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PolygonPath -> PolygonPath -> Bool
$c/= :: PolygonPath -> PolygonPath -> Bool
== :: PolygonPath -> PolygonPath -> Bool
$c== :: PolygonPath -> PolygonPath -> Bool
Eq, Int -> PolygonPath -> ShowS
[PolygonPath] -> ShowS
PolygonPath -> String
(Int -> PolygonPath -> ShowS)
-> (PolygonPath -> String)
-> ([PolygonPath] -> ShowS)
-> Show PolygonPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PolygonPath] -> ShowS
$cshowList :: [PolygonPath] -> ShowS
show :: PolygonPath -> String
$cshow :: PolygonPath -> String
showsPrec :: Int -> PolygonPath -> ShowS
$cshowsPrec :: Int -> PolygonPath -> ShowS
Show, (forall x. PolygonPath -> Rep PolygonPath x)
-> (forall x. Rep PolygonPath x -> PolygonPath)
-> Generic PolygonPath
forall x. Rep PolygonPath x -> PolygonPath
forall x. PolygonPath -> Rep PolygonPath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PolygonPath x -> PolygonPath
$cfrom :: forall x. PolygonPath -> Rep PolygonPath x
Generic)

toPolygonPath :: Path -> Maybe (DrawAttributes, PolygonPath)
toPolygonPath :: Path -> Maybe (DrawAttributes, PolygonPath)
toPolygonPath (Path DrawAttributes
attrs [PathCommand]
pcs) = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ -- only proceed if there is no visible stroke
        Bool -> (Number -> Bool) -> Maybe Number -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Number -> Bool
nearZeroNumber (Last Number -> Maybe Number
forall a. Last a -> Maybe a
getLast (Last Number -> Maybe Number) -> Last Number -> Maybe Number
forall a b. (a -> b) -> a -> b
$ DrawAttributes
attrs DrawAttributes
-> Getting (Last Number) DrawAttributes (Last Number)
-> Last Number
forall s a. s -> Getting a s a -> a
^. Getting (Last Number) DrawAttributes (Last Number)
forall c. HasDrawAttributes c => Lens' c (Last Number)
strokeWidth)
            Bool -> Bool -> Bool
|| Bool -> (Float -> Bool) -> Maybe Float -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Float -> Bool
forall a. Epsilon a => a -> Bool
nearZero (DrawAttributes
attrs DrawAttributes
-> Getting (Maybe Float) DrawAttributes (Maybe Float)
-> Maybe Float
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Float) DrawAttributes (Maybe Float)
forall c. HasDrawAttributes c => Lens' c (Maybe Float)
strokeOpacity)
    MoveTo Origin
OriginAbsolute [V2 Double
v] : [PathCommand]
xs <- [PathCommand] -> Maybe [PathCommand]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PathCommand]
pcs
    (DrawAttributes
attrs,) (PolygonPath -> (DrawAttributes, PolygonPath))
-> ([V2 Double] -> PolygonPath)
-> [V2 Double]
-> (DrawAttributes, PolygonPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (V2 Double) -> PolygonPath
PolygonPath (NonEmpty (V2 Double) -> PolygonPath)
-> ([V2 Double] -> NonEmpty (V2 Double))
-> [V2 Double]
-> PolygonPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Double
v V2 Double -> [V2 Double] -> NonEmpty (V2 Double)
forall a. a -> [a] -> NonEmpty a
:|) ([V2 Double] -> (DrawAttributes, PolygonPath))
-> Maybe [V2 Double] -> Maybe (DrawAttributes, PolygonPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Double -> [PathCommand] -> Maybe [V2 Double]
f V2 Double
v [PathCommand]
xs
  where
    f :: V2 Double -> [PathCommand] -> Maybe [V2 Double]
    f :: V2 Double -> [PathCommand] -> Maybe [V2 Double]
f v0 :: V2 Double
v0@(V2 Double
x0 Double
y0) = \case
        PathCommand
c : [PathCommand]
cs -> case PathCommand
c of
            LineTo Origin
OriginRelative [V2 Double
v] -> V2 Double -> Maybe [V2 Double]
g (V2 Double -> Maybe [V2 Double]) -> V2 Double -> Maybe [V2 Double]
forall a b. (a -> b) -> a -> b
$ V2 Double
v0 V2 Double -> V2 Double -> V2 Double
forall a. Num a => a -> a -> a
+ V2 Double
v
            LineTo Origin
OriginAbsolute [V2 Double
v] -> V2 Double -> Maybe [V2 Double]
g V2 Double
v
            HorizontalTo Origin
OriginAbsolute [Double
x] -> V2 Double -> Maybe [V2 Double]
g (V2 Double -> Maybe [V2 Double]) -> V2 Double -> Maybe [V2 Double]
forall a b. (a -> b) -> a -> b
$ Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
x Double
y0
            HorizontalTo Origin
OriginRelative [Double
x] -> V2 Double -> Maybe [V2 Double]
g (V2 Double -> Maybe [V2 Double]) -> V2 Double -> Maybe [V2 Double]
forall a b. (a -> b) -> a -> b
$ Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 (Double
x0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x) Double
y0
            VerticalTo Origin
OriginAbsolute [Double
y] -> V2 Double -> Maybe [V2 Double]
g (V2 Double -> Maybe [V2 Double]) -> V2 Double -> Maybe [V2 Double]
forall a b. (a -> b) -> a -> b
$ Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
x0 Double
y
            VerticalTo Origin
OriginRelative [Double
y] -> V2 Double -> Maybe [V2 Double]
g (V2 Double -> Maybe [V2 Double]) -> V2 Double -> Maybe [V2 Double]
forall a b. (a -> b) -> a -> b
$ Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
x0 (Double
y0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y)
            PathCommand
EndPath -> [V2 Double] -> Maybe [V2 Double]
forall a. a -> Maybe a
Just []
            PathCommand
_ -> Maybe [V2 Double]
forall a. Maybe a
Nothing
          where
            g :: V2 Double -> Maybe [V2 Double]
g V2 Double
v = (V2 Double
v V2 Double -> [V2 Double] -> [V2 Double]
forall a. a -> [a] -> [a]
:) ([V2 Double] -> [V2 Double])
-> Maybe [V2 Double] -> Maybe [V2 Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Double -> [PathCommand] -> Maybe [V2 Double]
f V2 Double
v [PathCommand]
cs
        [] -> Maybe [V2 Double]
forall a. Maybe a
Nothing -- should end with 'EndPath'

fromPolygonPath :: Opts -> PolygonPath -> DrawAttributes -> Path
fromPolygonPath :: PluginOptions P -> PolygonPath -> DrawAttributes -> Path
fromPolygonPath Opts{..} (PolygonPath p :: NonEmpty (V2 Double)
p@(V2 Double
v0 :| [V2 Double]
p')) =
    (DrawAttributes -> [PathCommand] -> Path)
-> [PathCommand] -> DrawAttributes -> Path
forall a b c. (a -> b -> c) -> b -> a -> c
flip DrawAttributes -> [PathCommand] -> Path
Path ([PathCommand] -> DrawAttributes -> Path)
-> ([PathCommand] -> [PathCommand])
-> [PathCommand]
-> DrawAttributes
-> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Origin -> [V2 Double] -> PathCommand
MoveTo Origin
OriginAbsolute [V2 Double
v0] PathCommand -> [PathCommand] -> [PathCommand]
forall a. a -> [a] -> [a]
:) ([PathCommand] -> DrawAttributes -> Path)
-> [PathCommand] -> DrawAttributes -> Path
forall a b. (a -> b) -> a -> b
$ ([PathCommand] -> [PathCommand] -> [PathCommand]
forall a. [a] -> [a] -> [a]
++ [PathCommand
EndPath]) case PathStyle
pathStyle of
        PathStyle
AbsolutePath -> (V2 Double -> PathCommand) -> [V2 Double] -> [PathCommand]
forall a b. (a -> b) -> [a] -> [b]
map (Origin -> [V2 Double] -> PathCommand
LineTo Origin
OriginAbsolute ([V2 Double] -> PathCommand)
-> (V2 Double -> [V2 Double]) -> V2 Double -> PathCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 Double -> [V2 Double]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [V2 Double]
p'
        PathStyle
SmartPath -> ((V2 Double, V2 Double) -> PathCommand)
-> [(V2 Double, V2 Double)] -> [PathCommand]
forall a b. (a -> b) -> [a] -> [b]
map ((V2 Double -> V2 Double -> PathCommand)
-> (V2 Double, V2 Double) -> PathCommand
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry V2 Double -> V2 Double -> PathCommand
fromTo) ([(V2 Double, V2 Double)] -> [PathCommand])
-> ([V2 Double] -> [(V2 Double, V2 Double)])
-> [V2 Double]
-> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V2 Double] -> [(V2 Double, V2 Double)]
forall a. [a] -> [(a, a)]
pairAdjacent ([V2 Double] -> [PathCommand]) -> [V2 Double] -> [PathCommand]
forall a b. (a -> b) -> a -> b
$ NonEmpty (V2 Double) -> [V2 Double]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (V2 Double)
p
  where
    fromTo :: V2 Double -> V2 Double -> PathCommand
fromTo V2 Double
a V2 Double
b
        | Double -> Double
forall a. Num a => a -> a
abs (V2 Double
d V2 Double -> Getting Double (V2 Double) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (V2 Double) Double
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
optsTolerance = Origin -> [Double] -> PathCommand
HorizontalTo Origin
OriginRelative [V2 Double
d V2 Double -> Getting Double (V2 Double) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (V2 Double) Double
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x]
        | Double -> Double
forall a. Num a => a -> a
abs (V2 Double
d V2 Double -> Getting Double (V2 Double) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (V2 Double) Double
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
optsTolerance = Origin -> [Double] -> PathCommand
VerticalTo Origin
OriginRelative [V2 Double
d V2 Double -> Getting Double (V2 Double) Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double (V2 Double) Double
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y]
        | Bool
otherwise = Origin -> [V2 Double] -> PathCommand
LineTo Origin
OriginRelative [V2 Double
b V2 Double -> V2 Double -> V2 Double
forall a. Num a => a -> a -> a
- V2 Double
a]
      where
        d :: V2 Double
d = V2 Double
b V2 Double -> V2 Double -> V2 Double
forall a. Num a => a -> a -> a
- V2 Double
a