module Graphics.Triangulation.KETTriangulation (ketTri) where
import Graphics.Triangulation.Triangulation (polygonDirection, isLeftTurn, isRightTurnOrOn)
import List ( (\\) )
import Data.Array (Array(..), (!), bounds)
type F2 = (Float,Float)
type Points = Array Int (Float,Float)
ketTri :: Points -> [Int] -> [(Int,Int,Int)]
ketTri points poly | (length vertices) > 3 = scan points vs stack rs
| otherwise = []
where (p1:p2:p3:qs) = vertices
vs = qs ++ [p1]
stack = [p3, p2, p1, last vertices]
rs = reflexVertices points vertices
vertices | polygonDirection (map (points!) poly) = poly
| otherwise = reverse poly
scan :: Points -> [Int] -> [Int] -> [Int] -> [(Int,Int,Int)]
scan points [] _ _ = []
scan points [v] [x_p, x_i, _, _] rs = [(x_i, x_p, v)]
scan points (v:vs) ss@[_,_,_] rs = scan points vs (v:ss) rs
scan points vs@(v:vs') ss@(x_p:x_i:ss'@(x_m:x_mm:xs)) rs
| isEar (map (points!) rs) (points!x_m) (points!x_i) (points!x_p) = (x_p, x_i, x_m) : scan points vs (x_p:ss') rs'
| otherwise = scan points 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 (points!im) (points!i) (points!ip) then [i] else []
isEar :: [F2] -> F2 -> F2 -> F2 -> Bool
isEar [] _ _ _ = True
isEar rs m x p = isLeftTurn m x p && not (any ( (m,x,p) `containsBNV`) rs)
reflexVertices :: Points -> [Int] -> [Int]
reflexVertices points ps = [ x | (m,x,p) <- angles ps, isRightTurnOrOn (points!m) (points!x) (points!p) ]
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