module Reanimate.PolyShape
( PolyShape(..)
, PolyShapeWithHoles(..)
, svgToPolyShapes
, svgToPolygons
, renderPolyShape
, renderPolyShapes
, renderPolyShapePoints
, plPathCommands
, plLineCommands
, plLength
, plArea
, plCurves
, isInsideOf
, plFromPolygon
, plToPolygon
, plPolygonify
, plDecompose
, unionPolyShapes
, unionPolyShapes'
, plDecompose'
, decomposePolygon
, plGroupShapes
, mergePolyShapeHoles
, polyShapeTolerance
, plPartial, plPartialGroup, plPartial'
, splitPolyShape
, plGroupTouching
) where
import Chiphunk.Low
import Control.Lens ((&), (.~))
import Data.AdditiveGroup
import Data.List (minimumBy, nub, partition, sortOn)
import Data.Ord
import qualified Data.Vector as V
import Geom2D (rotate90L, rotate90R, ($*), (^*))
import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..),
DPoint, FillRule (..), PathJoin (..),
Point (..), QuadBezier (..), arcLength,
arcLengthParam, bezierIntersection,
bezierSubsegment, closedPathCurves,
closest, colinear, curvesToClosed,
evalBezier, interpolateVector,
quadToCubic, reorient, splitBezier,
union, vectorDistance)
import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..),
defaultSvg, pathDefinition)
import Linear.V2
import Reanimate.Animation
import Reanimate.Constants
import Reanimate.Math.EarClip
import Reanimate.Math.Polygon (Polygon, mkPolygon, pIsCCW, pRing,
pdualPolygons, polygonPoints)
import Reanimate.Math.SSSP
import Reanimate.Svg
newtype PolyShape = PolyShape { unPolyShape :: ClosedPath Double }
deriving (Show)
data PolyShapeWithHoles = PolyShapeWithHoles
{ polyShapeParent :: PolyShape
, polyShapeHoles :: [PolyShape]
}
renderPolyShapes :: [PolyShape] -> Tree
renderPolyShapes pls =
PathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls
renderPolyShape :: PolyShape -> Tree
renderPolyShape pl =
PathTree $ defaultSvg & pathDefinition .~ plPathCommands pl
renderPolyShapePoints :: PolyShape -> Tree
renderPolyShapePoints = mkGroup . map renderPoint . plCurves
where
renderPoint (CubicBezier (Point x y) _ _ _) =
translate x y $ mkCircle 0.02
plLength :: PolyShape -> Double
plLength = sum . map cubicLength . plCurves
where
cubicLength c = arcLength c 1 polyShapeTolerance
plArea :: PolyShape -> Double
plArea pl = areaForPoly (map toVect $ plPolygonify polyShapeTolerance pl) 0
where
toVect (Point x y) = Vect x y
polyShapeTolerance :: Double
polyShapeTolerance = screenWidth/25600
plFromPolygon :: [RPoint] -> PolyShape
plFromPolygon = PolyShape . ClosedPath . map worker
where
worker (V2 x y) = (Point x y, JoinLine)
plToPolygon :: Double -> PolyShape -> Polygon
plToPolygon tol pl =
let p = V.init . V.fromList . map (\(Point x y) -> realToFrac <$> V2 x y) .
plPolygonify tol $ pl
in if pIsCCW (mkPolygon p) then mkPolygon p else mkPolygon (V.reverse p)
plPartial :: Double -> PolyShape -> PolyShape
plPartial delta pl | delta >= 1 = pl
plPartial delta pl = PolyShape $ curvesToClosed (lineOut ++ [joinB] ++ lineIn)
where
lineOutEnd = cubicC3 (last lineOut)
lineInBegin = cubicC0 (head lineIn)
joinB = CubicBezier lineOutEnd lineOutEnd lineOutEnd lineInBegin
lineOut = takeLen (len*delta/2) $ plCurves pl
lineIn =
reverse $ map reorient $
takeLen (len*delta/2) $ reverse $ map reorient $ plCurves pl
len = plLength pl
takeLen _ [] = []
takeLen l (c:cs) =
let cLen = arcLength c 1 polyShapeTolerance in
if l < cLen
then [bezierSubsegment c 0 (arcLengthParam c l polyShapeTolerance)]
else c : takeLen (l-cLen) cs
splitPolyShape :: Double -> Int -> PolyShape -> [PolyShape]
splitPolyShape tol n poly =
let polygon = toPolygon (plPolygonify tol poly)
trig = earClip $ pRing polygon
d = dual 0 trig
pd = toPDual (pRing polygon) d
reduced = pdualReduce (pRing polygon) pd n
polygons = pdualPolygons polygon reduced
in map toPolyShape polygons
where
toPolygon :: [Point Double] -> Polygon
toPolygon = mkPolygon . V.fromList . nub . map (\(Point x y) -> V2 (realToFrac x) (realToFrac y))
toPolyShape :: Polygon -> PolyShape
toPolyShape = plFromPolygon . map (fmap realToFrac) . V.toList . polygonPoints
plPartialGroup :: Double -> [PolyShape] -> [PolyShape]
plPartialGroup _delta [] = []
plPartialGroup delta pls =
[ plPartial (delta*(maxLen/plLength pl)) pl | pl <- pls ]
where
maxLen = maximum $ map plLength pls
plPartial' :: Double -> ([DPoint], 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 ]
plGroupTouching :: [PolyShape] -> [[([DPoint],PolyShape)]]
plGroupTouching [] = []
plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls
where
worker _ [] = []
worker seen shapes =
let (touching, notTouching) = partition (isTouching seen) shapes
in if null touching
then plGroupTouching notTouching
else map ((,) seen . changeOrigin seen) touching :
worker (seen ++ concatMap plPoints touching) notTouching
isTouching pts = any (`elem` pts) . plPoints
changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments
where
helper acc [] = reverse acc
helper acc lst@((startP,startJ):rest)
| startP `elem` seen = lst ++ reverse acc
| otherwise = helper ((startP, startJ):acc) rest
plPoints :: PolyShape -> [Point Double]
plPoints (PolyShape (ClosedPath lst)) =
[ p | (p,_) <- lst ]
plDecompose :: [PolyShape] -> [[RPoint]]
plDecompose = plDecompose' 0.001
plDecompose' :: Double -> [PolyShape] -> [[RPoint]]
plDecompose' tol =
concatMap (decomposePolygon . plPolygonify tol . mergePolyShapeHoles) .
plGroupShapes .
unionPolyShapes
decomposePolygon :: [Point Double] -> [[RPoint]]
decomposePolygon poly =
map (map fromVect . adjust) $ convexDecomposition (map toVect poly) tol
where
tol = polyShapeTolerance
toVect (Point x y) = Vect x y
fromVect (Vect x y) = V2 x y
adjust [] = []
adjust x = if head x == last x then adjust (init x) else x
plPolygonify :: Double -> PolyShape -> [Point Double]
plPolygonify tol shape =
startPoint (head curves) : concatMap worker curves
where
curves = plCurves shape
worker c | endPoint c == startPoint c =
[]
worker c =
if colinear c tol
then [endPoint c]
else
let (lhs,rhs) = splitBezier c 0.5
in worker lhs ++ worker rhs
endPoint (CubicBezier _ _ _ d) = d
startPoint (CubicBezier a _ _ _) = a
plPathCommands :: PolyShape -> [PathCommand]
plPathCommands = lineToPath . plLineCommands
plLineCommands :: PolyShape -> [LineCommand]
plLineCommands pl =
case curves of
[] -> []
(CubicBezier start _ _ _:_) ->
LineMove (toRPoint start) :
zipWith worker (drop 1 dstList ++ [start]) joinList ++
[LineEnd (toRPoint start)]
where
ClosedPath closedPath = unPolyShape pl
(dstList, joinList) = unzip closedPath
curves = plCurves pl
worker dst JoinLine =
LineBezier [toRPoint dst]
worker dst (JoinCurve a b) =
LineBezier $ map toRPoint [a,b,dst]
toRPoint :: Point Double -> RPoint
toRPoint (Point x y) = V2 x y
svgToPolyShapes :: Tree -> [PolyShape]
svgToPolyShapes = cmdsToPolyShapes . toLineCommands . extractPath
svgToPolygons :: Double -> SVG -> [Polygon]
svgToPolygons tol = map (toPolygon . plPolygonify tol) . svgToPolyShapes
where
toPolygon :: [Point Double] -> Polygon
toPolygon = mkPolygon .
V.fromList . nub . map (\(Point x y) -> V2 (realToFrac x) (realToFrac y))
cmdsToPolyShapes :: [LineCommand] -> [PolyShape]
cmdsToPolyShapes [] = []
cmdsToPolyShapes cmds =
case cmds of
(LineMove dst:cont) -> map PolyShape $ worker dst [] cont
_ -> bad
where
bad = error $ "Reanimate.PolyShape: Invalid commands: " ++ show cmds
finalize [] rest = rest
finalize acc rest = ClosedPath (reverse acc) : rest
worker _from acc [] = finalize acc []
worker _from acc (LineMove newStart : xs) =
finalize acc $
worker newStart [] xs
worker from acc (LineEnd orig:LineMove dst:xs) | from /= orig =
finalize ((toGPoint from, JoinLine):acc) $
worker dst [] xs
worker _from acc (LineEnd{}:LineMove dst:xs) =
finalize acc $
worker dst [] xs
worker from acc [LineEnd orig] | from /= orig =
finalize ((toGPoint from, JoinLine):acc) []
worker _from acc [LineEnd{}] =
finalize acc []
worker from acc (LineBezier [x]:xs) =
worker x ((toGPoint from, JoinLine) : acc) xs
worker from acc (LineBezier [a,b]:xs) =
let quad = QuadBezier (toGPoint from) (toGPoint a) (toGPoint b)
CubicBezier _ a' b' c' = quadToCubic quad
in worker from acc (LineBezier (map fromGPoint [a',b',c']):xs)
worker from acc (LineBezier [a,b,c]:xs) =
worker c ((toGPoint from, JoinCurve (toGPoint a) (toGPoint b)) : acc) xs
worker _ _ _ = bad
toGPoint :: RPoint -> Point Double
toGPoint (V2 x y) = Point x y
fromGPoint :: Point Double -> RPoint
fromGPoint (Point x y) = V2 x y
unionPolyShapes :: [PolyShape] -> [PolyShape]
unionPolyShapes shapes =
map PolyShape $
union (map unPolyShape shapes) NonZero (polyShapeTolerance/10000)
unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape]
unionPolyShapes' tol shapes =
map PolyShape $
union (map unPolyShape shapes) NonZero tol
isInsideOf :: PolyShape -> PolyShape -> Bool
lhs `isInsideOf` rhs =
odd (length upHits) && odd (length downHits)
where
(upHits, downHits) = polyIntersections origin rhs
origin = polyShapeOrigin lhs
polyIntersections :: DPoint -> PolyShape -> ([DPoint],[DPoint])
polyIntersections origin rhs =
(nub $ concatMap (intersections rayUp) curves
,nub $ concatMap (intersections rayDown) curves)
where
curves = plCurves rhs
intersections line bs =
map (evalBezier bs . fst) (bezierIntersection bs line polyShapeTolerance)
limit = 1000
rayUp = CubicBezier origin origin origin (Point limit limit)
rayDown = CubicBezier origin origin origin (Point (-limit) (-limit))
polyShapeOrigin :: PolyShape -> Point Double
polyShapeOrigin (PolyShape closedPath) =
case closedPath of
ClosedPath [] -> Point 0 0
ClosedPath ((start,_):_) -> start
plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles]
plGroupShapes = worker
where
worker (s:rest)
| null (parents s rest) =
let isOnlyChild x = parents x (s:rest) == [s]
(holes, nonHoles) = partition isOnlyChild rest
prime = PolyShapeWithHoles
{ polyShapeParent = s
, polyShapeHoles = holes }
in prime : worker nonHoles
| otherwise = worker (rest ++ [s])
worker [] = []
parents :: PolyShape -> [PolyShape] -> [PolyShape]
parents self = filter (self `isInsideOf`) . filter (/=self)
instance Eq PolyShape where
a == b = plCurves a == plCurves b
mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape
mergePolyShapeHoles (PolyShapeWithHoles parent []) = parent
mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) =
mergePolyShapeHoles $
PolyShapeWithHoles (mergePolyShapeHole parent child) children
mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape
mergePolyShapeHole parent child =
snd $ head $
sortOn fst
[ cutSingleHole newParent child
| newParent <- polyShapePermutations parent ]
cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape)
cutSingleHole parent child =
(score, PolyShape $ curvesToClosed $
p2b:pTail ++ [a2p] ++
[p2x] ++ childCurves ++
[x2p]
)
where
vect = (childOrigin ^-^ p) ^* 0
vectL = rotate90L $* vect
vectR = rotate90R $* vect
score = vectorDistance childOrigin p
childOrigin = polyShapeOrigin child
childOrigin' = childOrigin ^-^ vectL
(pHead:pTail) = plCurves parent
childCurves = plCurves child
pParam = closest pHead childOrigin polyShapeTolerance
(a2p, p2b') = splitBezier pHead pParam
p2b = case p2b' of
CubicBezier a b c d -> CubicBezier (a ^-^ vectL) b c d
p = evalBezier pHead pParam
p2x = lineBetween (p ^-^ vectR) childOrigin
x2p = lineBetween childOrigin' p
lineBetween a = CubicBezier a a a
plCurves :: PolyShape -> [CubicBezier Double]
plCurves = closedPathCurves . unPolyShape
polyShapePermutations :: PolyShape -> [PolyShape]
polyShapePermutations =
map (PolyShape . curvesToClosed) . cycleList . plCurves
where
cycleList lst =
let n = length lst in
[ take n $ drop i $ cycle lst
| i <- [0.. n-1] ]