module Graphics.SVGFonts.KETTriangulation (ketTri) where
import List ( (\\) )
type XYI = (Float,Float,Int)
ketTri :: [(Float,Float)] -> [(Int,Int,Int)]
ketTri poly = scan vs stack rs
where ps@(p1:p2:p3:qs) = vertices poly
vs = qs ++ [p1]
stack = [p3, p2, p1, last ps]
rs = reflexVertices ps
scan :: [XYI] -> [XYI] -> [XYI] -> [(Int,Int,Int)]
scan [] _ _ = []
scan [v] [x_p, x_i, _, _] rs = [(sel3_3 x_i, sel3_3 x_p, sel3_3 v)]
scan (v:vs) ss@[_,_,_] rs = scan vs (v:ss) rs
scan vs@(v:vs') ss@(x_p:x_i:ss'@(x_m:x_mm:xs)) rs
| isEar rs x_m x_i x_p = (sel3_3 x_m, sel3_3 x_i, sel3_3 x_p) : scan vs (x_p:ss') rs'
| otherwise = scan vs' (v:ss) rs
where rs' = rs \\ (isConvex x_m x_p v ++ isConvex x_mm x_m x_p)
isConvex im i ip = if isLeftTurn im i ip then [i] else []
isEar :: [XYI] -> XYI -> XYI -> XYI -> Bool
isEar [] _ _ _ = True
isEar rs m x p = isLeftTurn m x p && not (any ( (m,x,p) `containsBNV`) rs)
reflexVertices :: [XYI] -> [XYI]
reflexVertices xs = [ x | (m,x,p) <- angles xs, isRightTurnOrOn m x p ]
isRightTurnOrOn m x p = (area2 m x p) <= 0
isLeftTurn m x p = (area2 m x p) > 0
area2 (x2,y2,_) (x0,y0,_) (x1,y1,_) = (x1x0)*(y2y0)(x2x0)*(y1y0)
containsBNV (s,t,v) p = (a==b && b==c)
where a = isLeftTurn s t p
b = isLeftTurn t v p
c = isLeftTurn v s p
angles :: [a] -> [(a,a,a)]
angles xs = zip3 (rotateR xs) xs (rotateL xs)
rotateL xs = tail xs ++ [head xs]
rotateR xs = [last xs] ++ init xs
sel3_1 (x,y,z) = x
sel3_2 (x,y,z) = y
sel3_3 (x,y,z) = z
vertices :: [(Float,Float)] -> [XYI]
vertices qs | polygon_direction ps = ps
| otherwise = reverse ps
where ps = zipWith (\(x,y) z -> (x,y,z) ) qs [0..]
polygon_direction :: [XYI] -> Bool
polygon_direction poly = isLeftTurn (p (l1) poly) (p l poly) (p (l+1) poly)
where p l poly = head (drop (l `mod` lp) poly)
l = maxim poly 0 0 0 0
lp = length poly
maxim [] l ml mx my = ml
maxim (x:xs) l ml mx my | ((sel3_1 x) > mx) && ((sel3_2 x) >= my) = maxim xs (l+1) l (sel3_1 x) (sel3_2 x)
| otherwise = maxim xs (l+1) ml mx my