{-|
Module      : Reanimate.PolyShape
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX

A PolyShape is a closed set of curves.

-}
module Reanimate.PolyShape
  ( PolyShape(..)
  , PolyShapeWithHoles
  , svgToPolyShapes     -- :: Tree -> [PolyShape]
  , svgToPolygons       -- :: Double -> Svg -> [Polygon]

  , renderPolyShape     -- :: PolyShape -> Tree
  , renderPolyShapes    -- :: [PolyShape] -> Tree
  , renderPolyShapePoints -- :: PolyShape -> Tree

  , plPathCommands      -- :: PolyShape -> [PathCommand]
  , plLineCommands      -- :: PolyShape -> [LineCommand]

  , plLength            -- :: PolyShape -> Double
  , plArea
  , plCurves            -- :: PolyShape -> [CubicBezier Double]
  , isInsideOf          -- :: PolyShape -> PolyShape -> Bool

  , plFromPolygon       -- :: [RPoint] -> PolyShape
  , plToPolygon         -- :: Double -> PolyShape -> Polygon
  , plDecompose         -- :: [PolyShape] -> [[RPoint]]
  , unionPolyShapes     -- :: [PolyShape] -> [PolyShape]
  , unionPolyShapes'    -- :: Double -> [PolyShape] -> [PolyShape]
  , plDecompose'        -- :: Double -> [PolyShape] -> [[RPoint]]
  , decomposePolygon    -- :: [Point Double] -> [[RPoint]]
  , plGroupShapes       -- :: [PolyShape] -> [PolyShapeWithHoles]
  , mergePolyShapeHoles -- :: PolyShapeWithHoles -> PolyShape
  , plPartial
  , plGroupTouching
  ) where

import           Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
import           Control.Lens                                         ((&), (.~), (^.))
import           Data.Ext
import           Data.Geometry.PlanarSubdivision                      (PolygonFaceData (..))
import qualified Data.Geometry.Point                                  as Geo
import qualified Data.Geometry.Polygon                                as Geo
import           Data.List                                            (nub, partition, sortOn)
import qualified Data.PlaneGraph                                      as Geo
import           Data.Proxy                                           (Proxy (Proxy))
import qualified Data.Vector                                          as V
import           Geom2D.CubicBezier.Linear                            (ClosedPath (..),
                                                                       CubicBezier (..),
                                                                       FillRule (..), PathJoin (..),
                                                                       QuadBezier (..), arcLength,
                                                                       arcLengthParam,
                                                                       bezierIntersection,
                                                                       bezierSubsegment,
                                                                       closedPathCurves, closest,
                                                                       colinear, curvesToClosed,
                                                                       evalBezier, quadToCubic,
                                                                       reorient, splitBezier, union,
                                                                       vectorDistance)
import           Graphics.SvgTree                                     (PathCommand (..), RPoint,
                                                                       Tree, defaultSvg,
                                                                       pathDefinition, pathTree)
import           Linear.V2
import           Reanimate.Animation
import           Reanimate.Constants
import           Reanimate.Math.Polygon                               (Polygon, mkPolygon, pArea,
                                                                       pIsCCW)
import           Reanimate.Svg

-- | Shape drawn by continuous line. May have overlap, may be convex.
newtype PolyShape = PolyShape { PolyShape -> ClosedPath Double
unPolyShape :: ClosedPath Double }
  deriving (Int -> PolyShape -> ShowS
[PolyShape] -> ShowS
PolyShape -> String
(Int -> PolyShape -> ShowS)
-> (PolyShape -> String)
-> ([PolyShape] -> ShowS)
-> Show PolyShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PolyShape] -> ShowS
$cshowList :: [PolyShape] -> ShowS
show :: PolyShape -> String
$cshow :: PolyShape -> String
showsPrec :: Int -> PolyShape -> ShowS
$cshowsPrec :: Int -> PolyShape -> ShowS
Show)

-- | Polyshape with smaller, fully-enclosed holes.
data PolyShapeWithHoles = PolyShapeWithHoles
  { PolyShapeWithHoles -> PolyShape
polyShapeParent :: PolyShape
  , PolyShapeWithHoles -> [PolyShape]
polyShapeHoles  :: [PolyShape]
  }


-- | Render a set of polyshapes as a single SVG path.
renderPolyShapes :: [PolyShape] -> Tree
renderPolyShapes :: [PolyShape] -> Tree
renderPolyShapes [PolyShape]
pls =
  Path -> Tree
pathTree (Path -> Tree) -> Path -> Tree
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg 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] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (PolyShape -> [PathCommand]) -> [PolyShape] -> [PathCommand]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PolyShape -> [PathCommand]
plPathCommands [PolyShape]
pls

-- | Render a polyshape as a single SVG path.
renderPolyShape :: PolyShape -> Tree
renderPolyShape :: PolyShape -> Tree
renderPolyShape PolyShape
pl =
    Path -> Tree
pathTree (Path -> Tree) -> Path -> Tree
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg 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] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyShape -> [PathCommand]
plPathCommands PolyShape
pl

-- | Render control-points of a polyshape as circles.
renderPolyShapePoints :: PolyShape -> Tree
renderPolyShapePoints :: PolyShape -> Tree
renderPolyShapePoints = [Tree] -> Tree
mkGroup ([Tree] -> Tree) -> (PolyShape -> [Tree]) -> PolyShape -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CubicBezier Double -> Tree) -> [CubicBezier Double] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map CubicBezier Double -> Tree
renderPoint ([CubicBezier Double] -> [Tree])
-> (PolyShape -> [CubicBezier Double]) -> PolyShape -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShape -> [CubicBezier Double]
plCurves
  where
    renderPoint :: CubicBezier Double -> Tree
renderPoint (CubicBezier (V2 Double
x Double
y) V2 Double
_ V2 Double
_ V2 Double
_) =
      Double -> Double -> Tree -> Tree
translate Double
x Double
y (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$ Double -> Tree
mkCircle Double
0.02

-- | Length of polyshape circumference.
plLength :: PolyShape -> Double
plLength :: PolyShape -> Double
plLength = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double)
-> (PolyShape -> [Double]) -> PolyShape -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CubicBezier Double -> Double) -> [CubicBezier Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map CubicBezier Double -> Double
cubicLength ([CubicBezier Double] -> [Double])
-> (PolyShape -> [CubicBezier Double]) -> PolyShape -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShape -> [CubicBezier Double]
plCurves
  where
    cubicLength :: CubicBezier Double -> Double
cubicLength CubicBezier Double
c = CubicBezier Double -> Double -> Double -> Double
arcLength CubicBezier Double
c Double
1 Double
polyShapeTolerance

-- | Area of polyshape.
plArea :: PolyShape -> Double
plArea :: PolyShape -> Double
plArea PolyShape
pl = Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ APolygon Rational -> Rational
forall a. Fractional a => APolygon a -> a
pArea (APolygon Rational -> Rational) -> APolygon Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Double -> PolyShape -> APolygon Rational
plToPolygon Double
polyShapeTolerance PolyShape
pl

-- 1/10th of a pixel if rendered at 2560x1440
polyShapeTolerance :: Double
polyShapeTolerance :: Double
polyShapeTolerance = Double
forall a. Fractional a => a
screenWidthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
25600

-- | Construct a polyshape from the vertices in a polygon.
plFromPolygon :: [RPoint] -> PolyShape
plFromPolygon :: [V2 Double] -> PolyShape
plFromPolygon = ClosedPath Double -> PolyShape
PolyShape (ClosedPath Double -> PolyShape)
-> ([V2 Double] -> ClosedPath Double) -> [V2 Double] -> PolyShape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(V2 Double, PathJoin Double)] -> ClosedPath Double
forall a. [(V2 a, PathJoin a)] -> ClosedPath a
ClosedPath ([(V2 Double, PathJoin Double)] -> ClosedPath Double)
-> ([V2 Double] -> [(V2 Double, PathJoin Double)])
-> [V2 Double]
-> ClosedPath Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Double -> (V2 Double, PathJoin Double))
-> [V2 Double] -> [(V2 Double, PathJoin Double)]
forall a b. (a -> b) -> [a] -> [b]
map V2 Double -> (V2 Double, PathJoin Double)
forall a a. a -> (a, PathJoin a)
worker
  where
    worker :: a -> (a, PathJoin a)
worker a
val = (a
val, PathJoin a
forall a. PathJoin a
JoinLine)

-- | Approximate a polyshape as a polygon within the given tolerance.
plToPolygon :: Double -> PolyShape -> Polygon
plToPolygon :: Double -> PolyShape -> APolygon Rational
plToPolygon Double
tol PolyShape
pl =
  let p :: Vector (V2 Rational)
p = Vector (V2 Rational) -> Vector (V2 Rational)
forall a. Vector a -> Vector a
V.init (Vector (V2 Rational) -> Vector (V2 Rational))
-> (PolyShape -> Vector (V2 Rational))
-> PolyShape
-> Vector (V2 Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V2 Rational] -> Vector (V2 Rational)
forall a. [a] -> Vector a
V.fromList ([V2 Rational] -> Vector (V2 Rational))
-> (PolyShape -> [V2 Rational])
-> PolyShape
-> Vector (V2 Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Double -> V2 Rational) -> [V2 Double] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Rational) -> V2 Double -> V2 Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac) ([V2 Double] -> [V2 Rational])
-> (PolyShape -> [V2 Double]) -> PolyShape -> [V2 Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Double -> PolyShape -> [V2 Double]
plPolygonify Double
tol (PolyShape -> Vector (V2 Rational))
-> PolyShape -> Vector (V2 Rational)
forall a b. (a -> b) -> a -> b
$ PolyShape
pl
  in if APolygon Rational -> Bool
pIsCCW (Vector (V2 Rational) -> APolygon Rational
forall a. PolyCtx a => Vector (V2 a) -> APolygon a
mkPolygon Vector (V2 Rational)
p) then Vector (V2 Rational) -> APolygon Rational
forall a. PolyCtx a => Vector (V2 a) -> APolygon a
mkPolygon Vector (V2 Rational)
p else Vector (V2 Rational) -> APolygon Rational
forall a. PolyCtx a => Vector (V2 a) -> APolygon a
mkPolygon (Vector (V2 Rational) -> Vector (V2 Rational)
forall a. Vector a -> Vector a
V.reverse Vector (V2 Rational)
p)

-- | Partially draw polyshape.
plPartial :: Double -> PolyShape -> PolyShape
plPartial :: Double -> PolyShape -> PolyShape
plPartial Double
delta PolyShape
pl | Double
delta Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1 = PolyShape
pl
plPartial Double
delta PolyShape
pl = ClosedPath Double -> PolyShape
PolyShape (ClosedPath Double -> PolyShape) -> ClosedPath Double -> PolyShape
forall a b. (a -> b) -> a -> b
$ [CubicBezier Double] -> ClosedPath Double
forall a. [CubicBezier a] -> ClosedPath a
curvesToClosed ([CubicBezier Double]
lineOut [CubicBezier Double]
-> [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a] -> [a]
++ [CubicBezier Double
joinB] [CubicBezier Double]
-> [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a] -> [a]
++ [CubicBezier Double]
lineIn)
  where
    lineOutEnd :: V2 Double
lineOutEnd = CubicBezier Double -> V2 Double
forall a. CubicBezier a -> V2 a
cubicC3 ([CubicBezier Double] -> CubicBezier Double
forall a. [a] -> a
last [CubicBezier Double]
lineOut)
    lineInBegin :: V2 Double
lineInBegin = CubicBezier Double -> V2 Double
forall a. CubicBezier a -> V2 a
cubicC0 ([CubicBezier Double] -> CubicBezier Double
forall a. [a] -> a
head [CubicBezier Double]
lineIn)
    joinB :: CubicBezier Double
joinB = V2 Double
-> V2 Double -> V2 Double -> V2 Double -> CubicBezier Double
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
CubicBezier V2 Double
lineOutEnd V2 Double
lineOutEnd V2 Double
lineOutEnd V2 Double
lineInBegin
    lineOut :: [CubicBezier Double]
lineOut = Double -> [CubicBezier Double] -> [CubicBezier Double]
takeLen (Double
lenDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
deltaDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) ([CubicBezier Double] -> [CubicBezier Double])
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> a -> b
$ PolyShape -> [CubicBezier Double]
plCurves PolyShape
pl
    lineIn :: [CubicBezier Double]
lineIn =
      [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a]
reverse ([CubicBezier Double] -> [CubicBezier Double])
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> a -> b
$ (CubicBezier Double -> CubicBezier Double)
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> [a] -> [b]
map CubicBezier Double -> CubicBezier Double
forall (b :: * -> *) a. (GenericBezier b, Unbox a) => b a -> b a
reorient ([CubicBezier Double] -> [CubicBezier Double])
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> a -> b
$
      Double -> [CubicBezier Double] -> [CubicBezier Double]
takeLen (Double
lenDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
deltaDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) ([CubicBezier Double] -> [CubicBezier Double])
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> a -> b
$ [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a]
reverse ([CubicBezier Double] -> [CubicBezier Double])
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> a -> b
$ (CubicBezier Double -> CubicBezier Double)
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> [a] -> [b]
map CubicBezier Double -> CubicBezier Double
forall (b :: * -> *) a. (GenericBezier b, Unbox a) => b a -> b a
reorient ([CubicBezier Double] -> [CubicBezier Double])
-> [CubicBezier Double] -> [CubicBezier Double]
forall a b. (a -> b) -> a -> b
$ PolyShape -> [CubicBezier Double]
plCurves PolyShape
pl
    len :: Double
len = PolyShape -> Double
plLength PolyShape
pl
    takeLen :: Double -> [CubicBezier Double] -> [CubicBezier Double]
takeLen Double
_ [] = []
    takeLen Double
l (CubicBezier Double
c:[CubicBezier Double]
cs) =
      let cLen :: Double
cLen = CubicBezier Double -> Double -> Double -> Double
arcLength CubicBezier Double
c Double
1 Double
polyShapeTolerance in
      if Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
cLen
        then [CubicBezier Double -> Double -> Double -> CubicBezier Double
forall a (b :: * -> *).
(Ord a, Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> a -> b a
bezierSubsegment CubicBezier Double
c Double
0 (CubicBezier Double -> Double -> Double -> Double
arcLengthParam CubicBezier Double
c Double
l Double
polyShapeTolerance)]
        else CubicBezier Double
c CubicBezier Double -> [CubicBezier Double] -> [CubicBezier Double]
forall a. a -> [a] -> [a]
: Double -> [CubicBezier Double] -> [CubicBezier Double]
takeLen (Double
lDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
cLen) [CubicBezier Double]
cs

-- plPartial' :: Double -> ([RPoint], PolyShape) -> PolyShape
-- plPartial' delta (seen', PolyShape (ClosedPath lst)) =
--   case lst of
--     []                         -> PolyShape (ClosedPath [])
--     (startP, startJoin) : rest -> PolyShape $ ClosedPath $
--       (startP, startJoin) : worker startP rest
--   where
--     seen = filter (`elem` plPoints) seen'
--     closestSeen pt = minimumBy (comparing (vectorDistance pt)) seen
--     worker _ [] = []
--     worker _ ((newP, newJoin) : rest)
--       | newP `elem` seen = (newP, newJoin) : worker newP rest
--       | otherwise =
--         let newAt = interpolateVector (closestSeen newP) newP delta
--         in (newAt, newJoin) : worker newAt rest
--     plPoints =
--       [ p | (p,_) <- lst ]

-- | Find intersection points.
plGroupTouching :: [PolyShape] -> [[([RPoint],PolyShape)]]
plGroupTouching :: [PolyShape] -> [[([V2 Double], PolyShape)]]
plGroupTouching [] = []
plGroupTouching [PolyShape]
pls = [V2 Double] -> [PolyShape] -> [[([V2 Double], PolyShape)]]
worker [PolyShape -> V2 Double
polyShapeOrigin ([PolyShape] -> PolyShape
forall a. [a] -> a
head [PolyShape]
pls)] [PolyShape]
pls
  where
    worker :: [V2 Double] -> [PolyShape] -> [[([V2 Double], PolyShape)]]
worker [V2 Double]
_ [] = []
    worker [V2 Double]
seen [PolyShape]
shapes =
      let ([PolyShape]
touching, [PolyShape]
notTouching) = (PolyShape -> Bool) -> [PolyShape] -> ([PolyShape], [PolyShape])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([V2 Double] -> PolyShape -> Bool
forall (t :: * -> *).
Foldable t =>
t (V2 Double) -> PolyShape -> Bool
isTouching [V2 Double]
seen) [PolyShape]
shapes
      in if [PolyShape] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PolyShape]
touching
        then [PolyShape] -> [[([V2 Double], PolyShape)]]
plGroupTouching [PolyShape]
notTouching
        else (PolyShape -> ([V2 Double], PolyShape))
-> [PolyShape] -> [([V2 Double], PolyShape)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) [V2 Double]
seen (PolyShape -> ([V2 Double], PolyShape))
-> (PolyShape -> PolyShape)
-> PolyShape
-> ([V2 Double], PolyShape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V2 Double] -> PolyShape -> PolyShape
forall (t :: * -> *).
Foldable t =>
t (V2 Double) -> PolyShape -> PolyShape
changeOrigin [V2 Double]
seen) [PolyShape]
touching   [([V2 Double], PolyShape)]
-> [[([V2 Double], PolyShape)]] -> [[([V2 Double], PolyShape)]]
forall a. a -> [a] -> [a]
:
             [V2 Double] -> [PolyShape] -> [[([V2 Double], PolyShape)]]
worker ([V2 Double]
seen [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ (PolyShape -> [V2 Double]) -> [PolyShape] -> [V2 Double]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PolyShape -> [V2 Double]
plPoints [PolyShape]
touching) [PolyShape]
notTouching
    isTouching :: t (V2 Double) -> PolyShape -> Bool
isTouching t (V2 Double)
pts = (V2 Double -> Bool) -> [V2 Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (V2 Double -> t (V2 Double) -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t (V2 Double)
pts) ([V2 Double] -> Bool)
-> (PolyShape -> [V2 Double]) -> PolyShape -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShape -> [V2 Double]
plPoints
    changeOrigin :: t (V2 Double) -> PolyShape -> PolyShape
changeOrigin t (V2 Double)
seen (PolyShape (ClosedPath [(V2 Double, PathJoin Double)]
segments)) = ClosedPath Double -> PolyShape
PolyShape (ClosedPath Double -> PolyShape) -> ClosedPath Double -> PolyShape
forall a b. (a -> b) -> a -> b
$ [(V2 Double, PathJoin Double)] -> ClosedPath Double
forall a. [(V2 a, PathJoin a)] -> ClosedPath a
ClosedPath ([(V2 Double, PathJoin Double)] -> ClosedPath Double)
-> [(V2 Double, PathJoin Double)] -> ClosedPath Double
forall a b. (a -> b) -> a -> b
$ [(V2 Double, PathJoin Double)]
-> [(V2 Double, PathJoin Double)] -> [(V2 Double, PathJoin Double)]
forall b. [(V2 Double, b)] -> [(V2 Double, b)] -> [(V2 Double, b)]
helper [] [(V2 Double, PathJoin Double)]
segments
      where
        helper :: [(V2 Double, b)] -> [(V2 Double, b)] -> [(V2 Double, b)]
helper [(V2 Double, b)]
acc [] = [(V2 Double, b)] -> [(V2 Double, b)]
forall a. [a] -> [a]
reverse [(V2 Double, b)]
acc
        helper [(V2 Double, b)]
acc lst :: [(V2 Double, b)]
lst@((V2 Double
startP,b
startJ):[(V2 Double, b)]
rest)
          | V2 Double
startP V2 Double -> t (V2 Double) -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t (V2 Double)
seen = [(V2 Double, b)]
lst [(V2 Double, b)] -> [(V2 Double, b)] -> [(V2 Double, b)]
forall a. [a] -> [a] -> [a]
++ [(V2 Double, b)] -> [(V2 Double, b)]
forall a. [a] -> [a]
reverse [(V2 Double, b)]
acc
          | Bool
otherwise = [(V2 Double, b)] -> [(V2 Double, b)] -> [(V2 Double, b)]
helper ((V2 Double
startP, b
startJ)(V2 Double, b) -> [(V2 Double, b)] -> [(V2 Double, b)]
forall a. a -> [a] -> [a]
:[(V2 Double, b)]
acc) [(V2 Double, b)]
rest
    plPoints :: PolyShape -> [RPoint]
    plPoints :: PolyShape -> [V2 Double]
plPoints (PolyShape (ClosedPath [(V2 Double, PathJoin Double)]
lst)) =
      [ V2 Double
p | (V2 Double
p,PathJoin Double
_) <- [(V2 Double, PathJoin Double)]
lst ]

-- | Deconstruct a polyshape into non-intersecting, convex polygons.
plDecompose :: [PolyShape] -> [[RPoint]]
plDecompose :: [PolyShape] -> [[V2 Double]]
plDecompose = Double -> [PolyShape] -> [[V2 Double]]
plDecompose' Double
0.001

-- | Deconstruct a polyshape into non-intersecting, convex polygons.
plDecompose' :: Double -> [PolyShape] -> [[RPoint]]
plDecompose' :: Double -> [PolyShape] -> [[V2 Double]]
plDecompose' Double
tol =
  (PolyShapeWithHoles -> [[V2 Double]])
-> [PolyShapeWithHoles] -> [[V2 Double]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([V2 Double] -> [[V2 Double]]
decomposePolygon ([V2 Double] -> [[V2 Double]])
-> (PolyShapeWithHoles -> [V2 Double])
-> PolyShapeWithHoles
-> [[V2 Double]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> PolyShape -> [V2 Double]
plPolygonify Double
tol (PolyShape -> [V2 Double])
-> (PolyShapeWithHoles -> PolyShape)
-> PolyShapeWithHoles
-> [V2 Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShapeWithHoles -> PolyShape
mergePolyShapeHoles) ([PolyShapeWithHoles] -> [[V2 Double]])
-> ([PolyShape] -> [PolyShapeWithHoles])
-> [PolyShape]
-> [[V2 Double]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [PolyShape] -> [PolyShapeWithHoles]
plGroupShapes ([PolyShape] -> [PolyShapeWithHoles])
-> ([PolyShape] -> [PolyShape])
-> [PolyShape]
-> [PolyShapeWithHoles]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [PolyShape] -> [PolyShape]
unionPolyShapes

-- | Split polygon into smaller, convex polygons.
decomposePolygon :: [RPoint] -> [[RPoint]]
decomposePolygon :: [V2 Double] -> [[V2 Double]]
decomposePolygon [V2 Double]
poly =
  [ [ Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
x Double
y
    | VertexId' Any
v <- Vector (VertexId' Any) -> [VertexId' Any]
forall a. Vector a -> [a]
V.toList (FaceId' Any
-> PlaneGraph Any () PolygonEdgeType PolygonFaceData Double
-> Vector (VertexId' Any)
forall k (s :: k) v e f r.
FaceId' s -> PlaneGraph s v e f r -> Vector (VertexId' s)
Geo.boundaryVertices FaceId' Any
f PlaneGraph Any () PolygonEdgeType PolygonFaceData Double
forall s. PlaneGraph s () PolygonEdgeType PolygonFaceData Double
pg)
    , let Geo.Point2 Double
x Double
y = PlaneGraph Any () PolygonEdgeType PolygonFaceData Double
forall s. PlaneGraph s () PolygonEdgeType PolygonFaceData Double
pgPlaneGraph Any () PolygonEdgeType PolygonFaceData Double
-> Getting
     (Point 2 Double)
     (PlaneGraph Any () PolygonEdgeType PolygonFaceData Double)
     (Point 2 Double)
-> Point 2 Double
forall s a. s -> Getting a s a -> a
^.VertexId' Any
-> Lens'
     (PlaneGraph Any () PolygonEdgeType PolygonFaceData Double)
     (VertexData Double ())
forall k (s :: k) v e f r.
VertexId' s -> Lens' (PlaneGraph s v e f r) (VertexData r v)
Geo.vertexDataOf VertexId' Any
v ((VertexData Double ()
  -> Const (Point 2 Double) (VertexData Double ()))
 -> PlaneGraph Any () PolygonEdgeType PolygonFaceData Double
 -> Const
      (Point 2 Double)
      (PlaneGraph Any () PolygonEdgeType PolygonFaceData Double))
-> ((Point 2 Double -> Const (Point 2 Double) (Point 2 Double))
    -> VertexData Double ()
    -> Const (Point 2 Double) (VertexData Double ()))
-> Getting
     (Point 2 Double)
     (PlaneGraph Any () PolygonEdgeType PolygonFaceData Double)
     (Point 2 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 Double -> Const (Point 2 Double) (Point 2 Double))
-> VertexData Double ()
-> Const (Point 2 Double) (VertexData Double ())
forall r1 v r2.
Lens (VertexData r1 v) (VertexData r2 v) (Point 2 r1) (Point 2 r2)
Geo.location ]
  | (FaceId' Any
f, PolygonFaceData
Inside) <- Vector (FaceId' Any, PolygonFaceData)
-> [(FaceId' Any, PolygonFaceData)]
forall a. Vector a -> [a]
V.toList (PlaneGraph Any () PolygonEdgeType PolygonFaceData Double
-> Vector (FaceId' Any, PolygonFaceData)
forall k r (s :: k) v e f.
(Ord r, Fractional r) =>
PlaneGraph s v e f r -> Vector (FaceId' s, f)
Geo.internalFaces PlaneGraph Any () PolygonEdgeType PolygonFaceData Double
forall s. PlaneGraph s () PolygonEdgeType PolygonFaceData Double
pg) ]

  where
    pg :: PlaneGraph s () PolygonEdgeType PolygonFaceData Double
pg = Proxy s
-> Polygon 'Simple () Double
-> PlaneGraph s () PolygonEdgeType PolygonFaceData Double
forall k r (proxy :: k -> *) (s :: k) (t :: PolygonType) p.
(Ord r, Fractional r) =>
proxy s
-> Polygon t p r
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
triangulate' Proxy s
forall k (t :: k). Proxy t
Proxy Polygon 'Simple () Double
p
    p :: Polygon 'Simple () Double
p = [Point 2 Double :+ ()] -> Polygon 'Simple () Double
forall r p. [Point 2 r :+ p] -> SimplePolygon p r
Geo.fromPoints ([Point 2 Double :+ ()] -> Polygon 'Simple () Double)
-> [Point 2 Double :+ ()] -> Polygon 'Simple () Double
forall a b. (a -> b) -> a -> b
$
      [ Double -> Double -> Point 2 Double
forall r. r -> r -> Point 2 r
Geo.Point2 Double
x Double
y Point 2 Double -> () -> Point 2 Double :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()
      | V2 Double
x Double
y <- [V2 Double]
poly ]

plPolygonify :: Double -> PolyShape -> [RPoint]
plPolygonify :: Double -> PolyShape -> [V2 Double]
plPolygonify Double
tol PolyShape
shape =
    CubicBezier Double -> V2 Double
forall a. CubicBezier a -> V2 a
startPoint ([CubicBezier Double] -> CubicBezier Double
forall a. [a] -> a
head [CubicBezier Double]
curves) V2 Double -> [V2 Double] -> [V2 Double]
forall a. a -> [a] -> [a]
: (CubicBezier Double -> [V2 Double])
-> [CubicBezier Double] -> [V2 Double]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CubicBezier Double -> [V2 Double]
worker [CubicBezier Double]
curves
  where
    curves :: [CubicBezier Double]
curves = PolyShape -> [CubicBezier Double]
plCurves PolyShape
shape
    worker :: CubicBezier Double -> [V2 Double]
worker CubicBezier Double
c | CubicBezier Double -> V2 Double
forall a. CubicBezier a -> V2 a
endPoint CubicBezier Double
c V2 Double -> V2 Double -> Bool
forall a. Eq a => a -> a -> Bool
== CubicBezier Double -> V2 Double
forall a. CubicBezier a -> V2 a
startPoint CubicBezier Double
c =
      [] -- error $ "Bad bezier: " ++ show c
    worker CubicBezier Double
c =
      if CubicBezier Double -> Double -> Bool
colinear CubicBezier Double
c Double
tol -- && arcLength c 1 tol < 1
        then [CubicBezier Double -> V2 Double
forall a. CubicBezier a -> V2 a
endPoint CubicBezier Double
c]
        else
          let (CubicBezier Double
lhs,CubicBezier Double
rhs) = CubicBezier Double
-> Double -> (CubicBezier Double, CubicBezier Double)
forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
c Double
0.5
          in CubicBezier Double -> [V2 Double]
worker CubicBezier Double
lhs [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> [V2 Double]
worker CubicBezier Double
rhs
    endPoint :: CubicBezier a -> V2 a
endPoint (CubicBezier V2 a
_ V2 a
_ V2 a
_ V2 a
d) = V2 a
d
    startPoint :: CubicBezier a -> V2 a
startPoint (CubicBezier V2 a
a V2 a
_ V2 a
_ V2 a
_) = V2 a
a

-- | Convert a polyshape to a list of SVG path commands.
plPathCommands :: PolyShape -> [PathCommand]
plPathCommands :: PolyShape -> [PathCommand]
plPathCommands = [LineCommand] -> [PathCommand]
lineToPath ([LineCommand] -> [PathCommand])
-> (PolyShape -> [LineCommand]) -> PolyShape -> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShape -> [LineCommand]
plLineCommands

-- | Convert a polyshape to a list of line commands.
plLineCommands :: PolyShape -> [LineCommand]
plLineCommands :: PolyShape -> [LineCommand]
plLineCommands PolyShape
pl =
  case [CubicBezier Double]
curves of
    []                  -> []
    (CubicBezier V2 Double
start V2 Double
_ V2 Double
_ V2 Double
_:[CubicBezier Double]
_) ->
      V2 Double -> LineCommand
LineMove V2 Double
start LineCommand -> [LineCommand] -> [LineCommand]
forall a. a -> [a] -> [a]
:
      (V2 Double -> PathJoin Double -> LineCommand)
-> [V2 Double] -> [PathJoin Double] -> [LineCommand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith V2 Double -> PathJoin Double -> LineCommand
worker (Int -> [V2 Double] -> [V2 Double]
forall a. Int -> [a] -> [a]
drop Int
1 [V2 Double]
dstList [V2 Double] -> [V2 Double] -> [V2 Double]
forall a. [a] -> [a] -> [a]
++ [V2 Double
start]) [PathJoin Double]
joinList [LineCommand] -> [LineCommand] -> [LineCommand]
forall a. [a] -> [a] -> [a]
++
      [V2 Double -> LineCommand
LineEnd V2 Double
start]
  where
    ClosedPath [(V2 Double, PathJoin Double)]
closedPath = PolyShape -> ClosedPath Double
unPolyShape PolyShape
pl
    ([V2 Double]
dstList, [PathJoin Double]
joinList) = [(V2 Double, PathJoin Double)] -> ([V2 Double], [PathJoin Double])
forall a b. [(a, b)] -> ([a], [b])
unzip [(V2 Double, PathJoin Double)]
closedPath
    curves :: [CubicBezier Double]
curves = PolyShape -> [CubicBezier Double]
plCurves PolyShape
pl
    worker :: V2 Double -> PathJoin Double -> LineCommand
worker V2 Double
dst PathJoin Double
JoinLine =
      [V2 Double] -> LineCommand
LineBezier [V2 Double
dst]
    worker V2 Double
dst (JoinCurve V2 Double
a V2 Double
b) =
      [V2 Double] -> LineCommand
LineBezier [V2 Double
a,V2 Double
b,V2 Double
dst]

-- | Extract all shapes from SVG nodes. Drawing attributes such
--   as stroke and fill color are discarded.
svgToPolyShapes :: Tree -> [PolyShape]
svgToPolyShapes :: Tree -> [PolyShape]
svgToPolyShapes = [LineCommand] -> [PolyShape]
cmdsToPolyShapes ([LineCommand] -> [PolyShape])
-> (Tree -> [LineCommand]) -> Tree -> [PolyShape]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathCommand] -> [LineCommand]
toLineCommands ([PathCommand] -> [LineCommand])
-> (Tree -> [PathCommand]) -> Tree -> [LineCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> [PathCommand]
extractPath

-- | Extract all polygons from SVG nodes. Curves are approximated to
--   within the given tolerance.
svgToPolygons :: Double -> SVG -> [Polygon]
svgToPolygons :: Double -> Tree -> [APolygon Rational]
svgToPolygons Double
tol = (PolyShape -> APolygon Rational)
-> [PolyShape] -> [APolygon Rational]
forall a b. (a -> b) -> [a] -> [b]
map ([V2 Double] -> APolygon Rational
toPolygon ([V2 Double] -> APolygon Rational)
-> (PolyShape -> [V2 Double]) -> PolyShape -> APolygon Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> PolyShape -> [V2 Double]
plPolygonify Double
tol) ([PolyShape] -> [APolygon Rational])
-> (Tree -> [PolyShape]) -> Tree -> [APolygon Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> [PolyShape]
svgToPolyShapes
  where
    toPolygon :: [RPoint] -> Polygon
    toPolygon :: [V2 Double] -> APolygon Rational
toPolygon = Vector (V2 Rational) -> APolygon Rational
forall a. PolyCtx a => Vector (V2 a) -> APolygon a
mkPolygon (Vector (V2 Rational) -> APolygon Rational)
-> ([V2 Double] -> Vector (V2 Rational))
-> [V2 Double]
-> APolygon Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [V2 Rational] -> Vector (V2 Rational)
forall a. [a] -> Vector a
V.fromList ([V2 Rational] -> Vector (V2 Rational))
-> ([V2 Double] -> [V2 Rational])
-> [V2 Double]
-> Vector (V2 Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V2 Rational] -> [V2 Rational]
forall a. Eq a => [a] -> [a]
nub ([V2 Rational] -> [V2 Rational])
-> ([V2 Double] -> [V2 Rational]) -> [V2 Double] -> [V2 Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Double -> V2 Rational) -> [V2 Double] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Rational) -> V2 Double -> V2 Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac)

cmdsToPolyShapes :: [LineCommand] -> [PolyShape]
cmdsToPolyShapes :: [LineCommand] -> [PolyShape]
cmdsToPolyShapes [] = []
cmdsToPolyShapes [LineCommand]
cmds =
    case [LineCommand]
cmds of
      (LineMove V2 Double
dst:[LineCommand]
cont) -> (ClosedPath Double -> PolyShape)
-> [ClosedPath Double] -> [PolyShape]
forall a b. (a -> b) -> [a] -> [b]
map ClosedPath Double -> PolyShape
PolyShape ([ClosedPath Double] -> [PolyShape])
-> [ClosedPath Double] -> [PolyShape]
forall a b. (a -> b) -> a -> b
$ V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
dst [] [LineCommand]
cont
      [LineCommand]
_                   -> [PolyShape]
forall a. a
bad
  where
    bad :: a
bad = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Reanimate.PolyShape: Invalid commands: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [LineCommand] -> String
forall a. Show a => a -> String
show [LineCommand]
cmds
    finalize :: [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize [] [ClosedPath a]
rest  = [ClosedPath a]
rest
    finalize [(V2 a, PathJoin a)]
acc [ClosedPath a]
rest = [(V2 a, PathJoin a)] -> ClosedPath a
forall a. [(V2 a, PathJoin a)] -> ClosedPath a
ClosedPath ([(V2 a, PathJoin a)] -> [(V2 a, PathJoin a)]
forall a. [a] -> [a]
reverse [(V2 a, PathJoin a)]
acc) ClosedPath a -> [ClosedPath a] -> [ClosedPath a]
forall a. a -> [a] -> [a]
: [ClosedPath a]
rest
    worker :: V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
_from [(V2 Double, PathJoin Double)]
acc [] = [(V2 Double, PathJoin Double)]
-> [ClosedPath Double] -> [ClosedPath Double]
forall a. [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize [(V2 Double, PathJoin Double)]
acc []
    worker V2 Double
_from [(V2 Double, PathJoin Double)]
acc (LineMove V2 Double
newStart : [LineCommand]
xs) =
      [(V2 Double, PathJoin Double)]
-> [ClosedPath Double] -> [ClosedPath Double]
forall a. [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize [(V2 Double, PathJoin Double)]
acc ([ClosedPath Double] -> [ClosedPath Double])
-> [ClosedPath Double] -> [ClosedPath Double]
forall a b. (a -> b) -> a -> b
$
      V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
newStart [] [LineCommand]
xs
    worker V2 Double
from [(V2 Double, PathJoin Double)]
acc (LineEnd V2 Double
orig:LineMove V2 Double
dst:[LineCommand]
xs) | V2 Double
from V2 Double -> V2 Double -> Bool
forall a. Eq a => a -> a -> Bool
/= V2 Double
orig =
      [(V2 Double, PathJoin Double)]
-> [ClosedPath Double] -> [ClosedPath Double]
forall a. [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize ((V2 Double
from, PathJoin Double
forall a. PathJoin a
JoinLine)(V2 Double, PathJoin Double)
-> [(V2 Double, PathJoin Double)] -> [(V2 Double, PathJoin Double)]
forall a. a -> [a] -> [a]
:[(V2 Double, PathJoin Double)]
acc) ([ClosedPath Double] -> [ClosedPath Double])
-> [ClosedPath Double] -> [ClosedPath Double]
forall a b. (a -> b) -> a -> b
$
      V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
dst [] [LineCommand]
xs
    worker V2 Double
_from [(V2 Double, PathJoin Double)]
acc (LineEnd{}:LineMove V2 Double
dst:[LineCommand]
xs) =
      [(V2 Double, PathJoin Double)]
-> [ClosedPath Double] -> [ClosedPath Double]
forall a. [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize [(V2 Double, PathJoin Double)]
acc ([ClosedPath Double] -> [ClosedPath Double])
-> [ClosedPath Double] -> [ClosedPath Double]
forall a b. (a -> b) -> a -> b
$
      V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
dst [] [LineCommand]
xs
    worker V2 Double
from [(V2 Double, PathJoin Double)]
acc [LineEnd V2 Double
orig] | V2 Double
from V2 Double -> V2 Double -> Bool
forall a. Eq a => a -> a -> Bool
/= V2 Double
orig =
      [(V2 Double, PathJoin Double)]
-> [ClosedPath Double] -> [ClosedPath Double]
forall a. [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize ((V2 Double
from, PathJoin Double
forall a. PathJoin a
JoinLine)(V2 Double, PathJoin Double)
-> [(V2 Double, PathJoin Double)] -> [(V2 Double, PathJoin Double)]
forall a. a -> [a] -> [a]
:[(V2 Double, PathJoin Double)]
acc) []
    worker V2 Double
_from [(V2 Double, PathJoin Double)]
acc [LineEnd{}] =
      [(V2 Double, PathJoin Double)]
-> [ClosedPath Double] -> [ClosedPath Double]
forall a. [(V2 a, PathJoin a)] -> [ClosedPath a] -> [ClosedPath a]
finalize [(V2 Double, PathJoin Double)]
acc []
    worker V2 Double
from [(V2 Double, PathJoin Double)]
acc (LineBezier [V2 Double
x]:[LineCommand]
xs) =
      V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
x ((V2 Double
from, PathJoin Double
forall a. PathJoin a
JoinLine) (V2 Double, PathJoin Double)
-> [(V2 Double, PathJoin Double)] -> [(V2 Double, PathJoin Double)]
forall a. a -> [a] -> [a]
: [(V2 Double, PathJoin Double)]
acc) [LineCommand]
xs
    worker V2 Double
from [(V2 Double, PathJoin Double)]
acc (LineBezier [V2 Double
a,V2 Double
b]:[LineCommand]
xs) =
      let quad :: QuadBezier Double
quad = V2 Double -> V2 Double -> V2 Double -> QuadBezier Double
forall a. V2 a -> V2 a -> V2 a -> QuadBezier a
QuadBezier V2 Double
from V2 Double
a V2 Double
b
          CubicBezier V2 Double
_ V2 Double
a' V2 Double
b' V2 Double
c' = QuadBezier Double -> CubicBezier Double
forall a. Fractional a => QuadBezier a -> CubicBezier a
quadToCubic QuadBezier Double
quad
      in V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
from [(V2 Double, PathJoin Double)]
acc ([V2 Double] -> LineCommand
LineBezier [V2 Double
a',V2 Double
b',V2 Double
c']LineCommand -> [LineCommand] -> [LineCommand]
forall a. a -> [a] -> [a]
:[LineCommand]
xs)
    worker V2 Double
from [(V2 Double, PathJoin Double)]
acc (LineBezier [V2 Double
a,V2 Double
b,V2 Double
c]:[LineCommand]
xs) =
      V2 Double
-> [(V2 Double, PathJoin Double)]
-> [LineCommand]
-> [ClosedPath Double]
worker V2 Double
c ((V2 Double
from, V2 Double -> V2 Double -> PathJoin Double
forall a. V2 a -> V2 a -> PathJoin a
JoinCurve V2 Double
a V2 Double
b) (V2 Double, PathJoin Double)
-> [(V2 Double, PathJoin Double)] -> [(V2 Double, PathJoin Double)]
forall a. a -> [a] -> [a]
: [(V2 Double, PathJoin Double)]
acc) [LineCommand]
xs
    worker V2 Double
_ [(V2 Double, PathJoin Double)]
_ [LineCommand]
_ = [ClosedPath Double]
forall a. a
bad

-- | Merge overlapping shapes.
unionPolyShapes :: [PolyShape] -> [PolyShape]
unionPolyShapes :: [PolyShape] -> [PolyShape]
unionPolyShapes [PolyShape]
shapes =
    (ClosedPath Double -> PolyShape)
-> [ClosedPath Double] -> [PolyShape]
forall a b. (a -> b) -> [a] -> [b]
map ClosedPath Double -> PolyShape
PolyShape ([ClosedPath Double] -> [PolyShape])
-> [ClosedPath Double] -> [PolyShape]
forall a b. (a -> b) -> a -> b
$
    [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
union ((PolyShape -> ClosedPath Double)
-> [PolyShape] -> [ClosedPath Double]
forall a b. (a -> b) -> [a] -> [b]
map PolyShape -> ClosedPath Double
unPolyShape [PolyShape]
shapes) FillRule
FillNonZero (Double
polyShapeToleranceDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
10000)

-- | Merge overlapping shapes to within given tolerance.
unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape]
unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape]
unionPolyShapes' Double
tol [PolyShape]
shapes =
    (ClosedPath Double -> PolyShape)
-> [ClosedPath Double] -> [PolyShape]
forall a b. (a -> b) -> [a] -> [b]
map ClosedPath Double -> PolyShape
PolyShape ([ClosedPath Double] -> [PolyShape])
-> [ClosedPath Double] -> [PolyShape]
forall a b. (a -> b) -> a -> b
$
    [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
union ((PolyShape -> ClosedPath Double)
-> [PolyShape] -> [ClosedPath Double]
forall a b. (a -> b) -> [a] -> [b]
map PolyShape -> ClosedPath Double
unPolyShape [PolyShape]
shapes) FillRule
FillNonZero Double
tol

-- | True iff lhs is inside of rhs.
--   lhs and rhs may not overlap.
--   Implementation: Trace a vertical line through the origin of A and check
--   of this line intersects and odd number of times on both sides of A.
isInsideOf :: PolyShape -> PolyShape -> Bool
PolyShape
lhs isInsideOf :: PolyShape -> PolyShape -> Bool
`isInsideOf` PolyShape
rhs =
    Int -> Bool
forall a. Integral a => a -> Bool
odd ([V2 Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [V2 Double]
upHits) Bool -> Bool -> Bool
&& Int -> Bool
forall a. Integral a => a -> Bool
odd ([V2 Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [V2 Double]
downHits)
  where
    ([V2 Double]
upHits, [V2 Double]
downHits) = V2 Double -> PolyShape -> ([V2 Double], [V2 Double])
polyIntersections V2 Double
origin PolyShape
rhs
    origin :: V2 Double
origin = PolyShape -> V2 Double
polyShapeOrigin PolyShape
lhs

polyIntersections :: RPoint -> PolyShape -> ([RPoint],[RPoint])
polyIntersections :: V2 Double -> PolyShape -> ([V2 Double], [V2 Double])
polyIntersections V2 Double
origin PolyShape
rhs =
    ([V2 Double] -> [V2 Double]
forall a. Eq a => [a] -> [a]
nub ([V2 Double] -> [V2 Double]) -> [V2 Double] -> [V2 Double]
forall a b. (a -> b) -> a -> b
$ (CubicBezier Double -> [V2 Double])
-> [CubicBezier Double] -> [V2 Double]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CubicBezier Double -> CubicBezier Double -> [V2 Double]
intersections CubicBezier Double
rayUp) [CubicBezier Double]
curves
    ,[V2 Double] -> [V2 Double]
forall a. Eq a => [a] -> [a]
nub ([V2 Double] -> [V2 Double]) -> [V2 Double] -> [V2 Double]
forall a b. (a -> b) -> a -> b
$ (CubicBezier Double -> [V2 Double])
-> [CubicBezier Double] -> [V2 Double]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CubicBezier Double -> CubicBezier Double -> [V2 Double]
intersections CubicBezier Double
rayDown) [CubicBezier Double]
curves)
  where
    curves :: [CubicBezier Double]
curves = PolyShape -> [CubicBezier Double]
plCurves PolyShape
rhs

    intersections :: CubicBezier Double -> CubicBezier Double -> [V2 Double]
intersections CubicBezier Double
line CubicBezier Double
bs =
      ((Double, Double) -> V2 Double)
-> [(Double, Double)] -> [V2 Double]
forall a b. (a -> b) -> [a] -> [b]
map (CubicBezier Double -> Double -> V2 Double
forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> V2 a
evalBezier CubicBezier Double
bs (Double -> V2 Double)
-> ((Double, Double) -> Double) -> (Double, Double) -> V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, Double) -> Double
forall a b. (a, b) -> a
fst) (CubicBezier Double
-> CubicBezier Double -> Double -> [(Double, Double)]
bezierIntersection CubicBezier Double
bs CubicBezier Double
line Double
polyShapeTolerance)
    limit :: Double
limit = Double
1000
    rayUp :: CubicBezier Double
rayUp = V2 Double
-> V2 Double -> V2 Double -> V2 Double -> CubicBezier Double
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
CubicBezier V2 Double
origin V2 Double
origin V2 Double
origin (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
limit Double
limit)
    rayDown :: CubicBezier Double
rayDown = V2 Double
-> V2 Double -> V2 Double -> V2 Double -> CubicBezier Double
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
CubicBezier V2 Double
origin V2 Double
origin V2 Double
origin (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 (-Double
limit) (-Double
limit))

polyShapeOrigin :: PolyShape -> V2 Double
polyShapeOrigin :: PolyShape -> V2 Double
polyShapeOrigin (PolyShape ClosedPath Double
closedPath) =
  case ClosedPath Double
closedPath of
    ClosedPath []            -> Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
0 Double
0
    ClosedPath ((V2 Double
start,PathJoin Double
_):[(V2 Double, PathJoin Double)]
_) -> V2 Double
start

-- | Find holes and group them with their parent.
plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles]
plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles]
plGroupShapes = [PolyShape] -> [PolyShapeWithHoles]
worker
  where
    worker :: [PolyShape] -> [PolyShapeWithHoles]
worker (PolyShape
s:[PolyShape]
rest)
      | [PolyShape] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PolyShape -> [PolyShape] -> [PolyShape]
parents PolyShape
s [PolyShape]
rest) =
        let isOnlyChild :: PolyShape -> Bool
isOnlyChild PolyShape
x = PolyShape -> [PolyShape] -> [PolyShape]
parents PolyShape
x (PolyShape
sPolyShape -> [PolyShape] -> [PolyShape]
forall a. a -> [a] -> [a]
:[PolyShape]
rest) [PolyShape] -> [PolyShape] -> Bool
forall a. Eq a => a -> a -> Bool
== [PolyShape
s]
            ([PolyShape]
holes, [PolyShape]
nonHoles) = (PolyShape -> Bool) -> [PolyShape] -> ([PolyShape], [PolyShape])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition PolyShape -> Bool
isOnlyChild [PolyShape]
rest
            prime :: PolyShapeWithHoles
prime = PolyShapeWithHoles :: PolyShape -> [PolyShape] -> PolyShapeWithHoles
PolyShapeWithHoles
              { polyShapeParent :: PolyShape
polyShapeParent = PolyShape
s
              , polyShapeHoles :: [PolyShape]
polyShapeHoles  = [PolyShape]
holes }
        in PolyShapeWithHoles
prime PolyShapeWithHoles -> [PolyShapeWithHoles] -> [PolyShapeWithHoles]
forall a. a -> [a] -> [a]
: [PolyShape] -> [PolyShapeWithHoles]
worker [PolyShape]
nonHoles
      | Bool
otherwise = [PolyShape] -> [PolyShapeWithHoles]
worker ([PolyShape]
rest [PolyShape] -> [PolyShape] -> [PolyShape]
forall a. [a] -> [a] -> [a]
++ [PolyShape
s])
    worker [] = []

    parents :: PolyShape -> [PolyShape] -> [PolyShape]
    parents :: PolyShape -> [PolyShape] -> [PolyShape]
parents PolyShape
self = (PolyShape -> Bool) -> [PolyShape] -> [PolyShape]
forall a. (a -> Bool) -> [a] -> [a]
filter (PolyShape
self PolyShape -> PolyShape -> Bool
`isInsideOf`) ([PolyShape] -> [PolyShape])
-> ([PolyShape] -> [PolyShape]) -> [PolyShape] -> [PolyShape]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolyShape -> Bool) -> [PolyShape] -> [PolyShape]
forall a. (a -> Bool) -> [a] -> [a]
filter (PolyShape -> PolyShape -> Bool
forall a. Eq a => a -> a -> Bool
/=PolyShape
self)

instance Eq PolyShape where
  PolyShape
a == :: PolyShape -> PolyShape -> Bool
== PolyShape
b = PolyShape -> [CubicBezier Double]
plCurves PolyShape
a [CubicBezier Double] -> [CubicBezier Double] -> Bool
forall a. Eq a => a -> a -> Bool
== PolyShape -> [CubicBezier Double]
plCurves PolyShape
b

-- | Cut out holes.
mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape
mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape
mergePolyShapeHoles (PolyShapeWithHoles PolyShape
parent []) = PolyShape
parent
mergePolyShapeHoles (PolyShapeWithHoles PolyShape
parent (PolyShape
child:[PolyShape]
children)) =
  PolyShapeWithHoles -> PolyShape
mergePolyShapeHoles (PolyShapeWithHoles -> PolyShape)
-> PolyShapeWithHoles -> PolyShape
forall a b. (a -> b) -> a -> b
$
    PolyShape -> [PolyShape] -> PolyShapeWithHoles
PolyShapeWithHoles (PolyShape -> PolyShape -> PolyShape
mergePolyShapeHole PolyShape
parent PolyShape
child) [PolyShape]
children

-- Merge
mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape
mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape
mergePolyShapeHole PolyShape
parent PolyShape
child =
  (Double, PolyShape) -> PolyShape
forall a b. (a, b) -> b
snd ((Double, PolyShape) -> PolyShape)
-> (Double, PolyShape) -> PolyShape
forall a b. (a -> b) -> a -> b
$ [(Double, PolyShape)] -> (Double, PolyShape)
forall a. [a] -> a
head ([(Double, PolyShape)] -> (Double, PolyShape))
-> [(Double, PolyShape)] -> (Double, PolyShape)
forall a b. (a -> b) -> a -> b
$
  ((Double, PolyShape) -> Double)
-> [(Double, PolyShape)] -> [(Double, PolyShape)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Double, PolyShape) -> Double
forall a b. (a, b) -> a
fst
  [ PolyShape -> PolyShape -> (Double, PolyShape)
cutSingleHole PolyShape
newParent PolyShape
child
  | PolyShape
newParent <- PolyShape -> [PolyShape]
polyShapePermutations PolyShape
parent ]

{-
parent:
  (a,b)
  (b,c)
  (c,a)

child:
  (x,y)
  (y,z)
  (z,x)

P = split (a,b)
new:
  (P,b) p2b
  (b,c) pTail
  (c,a) pTail
  (a,P) a2p

  (P,x) p2x

  (x,y) childCurves
  (y,z) childCurves
  (z,x) childCurves

  (x,P) x2p

-}
cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape)
cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape)
cutSingleHole PolyShape
parent PolyShape
child =
    (Double
score, ClosedPath Double -> PolyShape
PolyShape (ClosedPath Double -> PolyShape) -> ClosedPath Double -> PolyShape
forall a b. (a -> b) -> a -> b
$ [CubicBezier Double] -> ClosedPath Double
forall a. [CubicBezier a] -> ClosedPath a
curvesToClosed ([CubicBezier Double] -> ClosedPath Double)
-> [CubicBezier Double] -> ClosedPath Double
forall a b. (a -> b) -> a -> b
$
      CubicBezier Double
p2bCubicBezier Double -> [CubicBezier Double] -> [CubicBezier Double]
forall a. a -> [a] -> [a]
:[CubicBezier Double]
pTail [CubicBezier Double]
-> [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a] -> [a]
++ [CubicBezier Double
a2p] [CubicBezier Double]
-> [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a] -> [a]
++
      [CubicBezier Double
p2x] [CubicBezier Double]
-> [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a] -> [a]
++ [CubicBezier Double]
childCurves [CubicBezier Double]
-> [CubicBezier Double] -> [CubicBezier Double]
forall a. [a] -> [a] -> [a]
++
      [CubicBezier Double
x2p]
    )
  where
    -- vect = (childOrigin - p) * 0 -- 0.0001
    vectL :: V2 Double
vectL = V2 Double
0 -- rotate90L $* vect
    vectR :: V2 Double
vectR = V2 Double
0 -- rotate90R $* vect
    score :: Double
score = V2 Double -> V2 Double -> Double
forall a. Floating a => V2 a -> V2 a -> a
vectorDistance V2 Double
childOrigin V2 Double
p
    childOrigin :: V2 Double
childOrigin = PolyShape -> V2 Double
polyShapeOrigin PolyShape
child
    childOrigin' :: V2 Double
childOrigin' = V2 Double
childOrigin V2 Double -> V2 Double -> V2 Double
forall a. Num a => a -> a -> a
- V2 Double
vectL
    (CubicBezier Double
pHead:[CubicBezier Double]
pTail) = PolyShape -> [CubicBezier Double]
plCurves PolyShape
parent
    childCurves :: [CubicBezier Double]
childCurves = PolyShape -> [CubicBezier Double]
plCurves PolyShape
child

    pParam :: Double
pParam = CubicBezier Double -> V2 Double -> Double -> Double
closest CubicBezier Double
pHead V2 Double
childOrigin Double
polyShapeTolerance

    (CubicBezier Double
a2p, CubicBezier Double
p2b') = CubicBezier Double
-> Double -> (CubicBezier Double, CubicBezier Double)
forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
pHead Double
pParam
    p2b :: CubicBezier Double
p2b = case CubicBezier Double
p2b' of
      CubicBezier V2 Double
a V2 Double
b V2 Double
c V2 Double
d -> V2 Double
-> V2 Double -> V2 Double -> V2 Double -> CubicBezier Double
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
CubicBezier (V2 Double
a V2 Double -> V2 Double -> V2 Double
forall a. Num a => a -> a -> a
- V2 Double
vectL) V2 Double
b V2 Double
c V2 Double
d

    p :: V2 Double
p = CubicBezier Double -> Double -> V2 Double
forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> V2 a
evalBezier CubicBezier Double
pHead Double
pParam
    -- straight line to child origin
    p2x :: CubicBezier Double
p2x = V2 Double -> V2 Double -> CubicBezier Double
forall a. V2 a -> V2 a -> CubicBezier a
lineBetween (V2 Double
p V2 Double -> V2 Double -> V2 Double
forall a. Num a => a -> a -> a
- V2 Double
vectR) V2 Double
childOrigin
    -- straight line from child origin
    x2p :: CubicBezier Double
x2p = V2 Double -> V2 Double -> CubicBezier Double
forall a. V2 a -> V2 a -> CubicBezier a
lineBetween V2 Double
childOrigin' V2 Double
p

    lineBetween :: V2 a -> V2 a -> CubicBezier a
lineBetween V2 a
a = V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
forall a. V2 a -> V2 a -> V2 a -> V2 a -> CubicBezier a
CubicBezier V2 a
a V2 a
a V2 a
a

-- | Destruct a polyshape into constituent curves.
plCurves :: PolyShape -> [CubicBezier Double]
plCurves :: PolyShape -> [CubicBezier Double]
plCurves = ClosedPath Double -> [CubicBezier Double]
forall a. Fractional a => ClosedPath a -> [CubicBezier a]
closedPathCurves (ClosedPath Double -> [CubicBezier Double])
-> (PolyShape -> ClosedPath Double)
-> PolyShape
-> [CubicBezier Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShape -> ClosedPath Double
unPolyShape

polyShapePermutations :: PolyShape -> [PolyShape]
polyShapePermutations :: PolyShape -> [PolyShape]
polyShapePermutations =
    ([CubicBezier Double] -> PolyShape)
-> [[CubicBezier Double]] -> [PolyShape]
forall a b. (a -> b) -> [a] -> [b]
map (ClosedPath Double -> PolyShape
PolyShape (ClosedPath Double -> PolyShape)
-> ([CubicBezier Double] -> ClosedPath Double)
-> [CubicBezier Double]
-> PolyShape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CubicBezier Double] -> ClosedPath Double
forall a. [CubicBezier a] -> ClosedPath a
curvesToClosed) ([[CubicBezier Double]] -> [PolyShape])
-> (PolyShape -> [[CubicBezier Double]])
-> PolyShape
-> [PolyShape]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CubicBezier Double] -> [[CubicBezier Double]]
forall a. [a] -> [[a]]
cycleList ([CubicBezier Double] -> [[CubicBezier Double]])
-> (PolyShape -> [CubicBezier Double])
-> PolyShape
-> [[CubicBezier Double]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyShape -> [CubicBezier Double]
plCurves
  where
    cycleList :: [a] -> [[a]]
cycleList [a]
lst =
      let n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
lst in
      [ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
cycle [a]
lst
      | Int
i <- [Int
0.. Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]