{-# 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.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 = Lens' Document [Tree]
documentElements forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a b. (a -> b) -> [a] -> [b]
map TreeBranch -> Tree
Tree forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginOptions P -> [TreeBranch] -> [TreeBranch]
branches PluginOptions P
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. 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' forall a. [a] -> [a] -> [a]
++ [TreeBranch]
nonPolygons
  where
    ([TreeBranch]
nonPolygons, [(DrawAttributes, PolygonPath)]
polygons) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\TreeBranch
b -> forall a b. a -> Maybe b -> Either a b
maybeToEither TreeBranch
b forall a b. (a -> b) -> a -> b
$ Path -> Maybe (DrawAttributes, PolygonPath)
toPolygonPath 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) <- forall a b. (a, b) -> b
snd forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
(Functor f, Functor g, Functor h) =>
(a -> b) -> f (g (h a)) -> f (g (h b))
<<<$>>> forall b a. Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
classifyOn forall a b. (a, b) -> a
fst [(DrawAttributes, PolygonPath)]
polygons
        PolygonPath
merged <- PluginOptions P -> [PolygonPath] -> [PolygonPath]
mergePaths PluginOptions P
opts forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty PolygonPath
paths
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path -> TreeBranch
PathNode 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 forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> (b, a)
swap) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [(a, [a])]
select [PolygonPath]
ps of
        -- p can't be merged with any shape in ps
        [] -> PolygonPath
p 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 forall a b. (a -> b) -> a -> b
$ PolygonPath
p' forall a. a -> [a] -> [a]
: [PolygonPath]
ps'

mergePaths2 :: Opts -> PolygonPath -> PolygonPath -> Maybe PolygonPath
mergePaths2 :: PluginOptions P -> PolygonPath -> PolygonPath -> Maybe PolygonPath
mergePaths2 Opts{Double
PathStyle
pathStyle :: PathStyle
optsTolerance :: Double
pathStyle :: PluginOptions P -> PathStyle
optsTolerance :: PluginOptions P -> Double
..} PolygonPath
us PolygonPath
vs =
    forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
        PolygonPath -> PolygonPath -> Maybe PolygonPath
mergeOne
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IsLabel "unPolygonPath" a => a
forall (x :: Symbol) a. IsLabel x a => a
#unPolygonPath forall a. NonEmpty a -> [NonEmpty a]
equivalentCycles PolygonPath
us
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IsLabel "unPolygonPath" a => a
forall (x :: Symbol) a. IsLabel x a => a
#unPolygonPath forall a. NonEmpty a -> [NonEmpty a]
equivalentCycles PolygonPath
vs
  where
    V2 Double
a ~= :: V2 Double -> V2 Double -> Bool
~= V2 Double
b = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
a V2 Double
b 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ V2 Double
u0 V2 Double -> V2 Double -> Bool
~= V2 Double
v0
        V2 Double
u1 : [V2 Double]
_us1 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure [V2 Double]
us0
        V2 Double
v1 : [V2 Double]
vs1 <- 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 = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
u0 V2 Double
u1
            b :: Double
b = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
u0 V2 Double
v1
            c :: Double
c = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V2 Double
u1 V2 Double
v1
            d :: Double
d = ((Double
a forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) forall a. Num a => a -> a -> a
+ (Double
b forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) forall a. Num a => a -> a -> a
- (Double
c forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2)) forall a. Fractional a => a -> a -> a
/ (Double
2 forall a. Num a => a -> a -> a
* Double
a)
            r :: Double
r = forall a. Floating a => a -> a
sqrt forall a b. (a -> b) -> a -> b
$ (Double
b forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2) forall a. Num a => a -> a -> a
- (Double
d 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Double
a 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Double
d forall a. Ord a => a -> a -> Bool
<= Double
b

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

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

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

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

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