module Reanimate.Math.EarClip
( earClip
, earClip'
, isEarCorner
) where
import Data.List
import qualified Data.Set as Set
import Reanimate.Math.Common
import Reanimate.Math.Triangulate
earClip :: (Fractional a, Ord a) => Ring a -> Triangulation
earClip = last . earClip'
earClip' :: (Fractional a, Ord a) => Ring a -> [Triangulation]
earClip' p = map (edgesToTriangulation $ ringSize p) $ inits $
let ears = Set.fromList [ i
| i <- elts
, isEarCorner p elts (mod (i-1) n) i (mod (i+1) n) ]
in worker ears (mkQueue elts)
where
n = ringSize p
elts = [0 .. n-1]
worker _ears queue | isSimpleQ queue = []
worker ears queue
| x `Set.member` ears =
let dq = dropQ queue
v0 = prevQ 1 queue
v1 = prevQ 0 queue
v3 = peekQ dq
v4 = peekQ (nextQ dq)
e1 = if isEarCorner p (toList dq) v0 v1 v3
then Set.insert v1 ears
else Set.delete v1 ears
e2 = if isEarCorner p (toList dq) v1 v3 v4
then Set.insert v3 e1
else Set.delete v3 e1
in (v1,v3) : worker e2 dq
| otherwise = worker ears (nextQ queue)
where
x = peekQ queue
data PolyQueue a = PolyQueue a [a] [a] [a]
mkQueue :: [a] -> PolyQueue a
mkQueue (x:xs) = PolyQueue x xs [] (reverse (x:xs))
mkQueue [] = error "mkQueue: empty"
toList :: PolyQueue a -> [a]
toList (PolyQueue e a b _) = e : a ++ b
isSimpleQ :: PolyQueue a -> Bool
isSimpleQ (PolyQueue _ xs ys _) =
case xs ++ ys of
[_,_] -> True
_ -> False
peekQ :: PolyQueue a -> a
peekQ (PolyQueue e _ _ _) = e
nextQ :: PolyQueue a -> PolyQueue a
nextQ (PolyQueue x [] ys p) =
let (y:xs) = reverse (x:ys)
in PolyQueue y xs [] (x:p)
nextQ (PolyQueue x (y:xs) ys p) = PolyQueue y xs (x:ys) (x:p)
dropQ :: PolyQueue a -> PolyQueue a
dropQ (PolyQueue _ [] ys p) =
let (x:xs) = reverse ys
in PolyQueue x xs [] p
dropQ (PolyQueue _ (x:xs) ys p) = PolyQueue x xs ys p
prevQ :: Int -> PolyQueue a -> a
prevQ nth (PolyQueue _ _ _ p) = p!!nth
isEarCorner :: (Fractional a, Ord a) => Ring a -> [Int] -> Int -> Int -> Int -> Bool
isEarCorner p polygon a b c =
isLeftTurn aP bP cP &&
and [ not (isInside aP bP cP (ringAccess p k))
| k <- polygon, k /= a && k /= b && k /= c
]
where
aP = ringAccess p a
bP = ringAccess p b
cP = ringAccess p c