module Reanimate.PolyShape
( PolyShape(..)
, PolyShapeWithHoles(..)
, svgToPolyShapes
, renderPolyShape
, renderPolyShapes
, renderPolyShapePoints
, plPathCommands
, plLineCommands
, plLength
, plArea
, plCurves
, isInsideOf
, plFromPolygon
, plPolygonify
, plDecompose
, unionPolyShapes
, unionPolyShapes'
, plDecompose'
, decomposePolygon
, plGroupShapes
, mergePolyShapeHoles
, polyShapeTolerance
, plPartial, plPartialGroup, plPartial'
, plGroupTouching
) where
import Chiphunk.Low
import Control.Lens ((&), (.~))
import Data.List (minimumBy, nub, partition, sortOn)
import Data.Ord
import Debug.Trace
import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint,
FillRule (..), PathJoin (..), Point (..),
arcLength, arcLengthParam,
bezierIntersection, bezierSubsegment,
closedPathCurves, closest, colinear,
curvesToClosed, evalBezier,
interpolateVector, reorient, splitBezier,
union, vectorDistance)
import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..),
defaultSvg, pathDefinition)
import Linear.V2
import Reanimate.Constants
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)
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
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
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,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
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 = trace "Found hole, putting back" $ 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
score = vectorDistance childOrigin p
childOrigin = polyShapeOrigin child
(pHead:pTail) = plCurves parent
childCurves = plCurves child
pParam = closest pHead childOrigin polyShapeTolerance
(a2p, p2b) = splitBezier pHead pParam
p = evalBezier pHead pParam
p2x = lineBetween p 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] ]