--------------------------------------------------------------------------------
-- Copyright (C) 1997, 1998, 2008 Joern Dinkla, www.dinkla.net
--------------------------------------------------------------------------------
--
-- see
--     Joern Dinkla, Geometrische Algorithmen in Haskell, Diploma Thesis,
--     University of Bonn, Germany, 1998. 
--
--  triangulation of simple polygons after Kong, Everett, Toussaint 91
--  with some changes by T.Vogt: return indices instead of coordinates of triangles

module Graphics.SVGFonts.KETTriangulation (ketTri,cycle_n) where
import List      ( (\\) )
import Debug.Trace

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,_) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)

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

-- make vertices of polygon counterclockwise and add an index
vertices :: [(Float,Float)] -> [XYI]
vertices qs | polygon_direction ps = ps
            | otherwise            = reverse ps
  where ps = zipWith (\(x,y) z -> (x,y,z) ) qs [0..]

-- the direction (clockwise or counterclockwise) of a polygon can be obtained by looking at a maximal point
-- polygon_direction :: [XYI] -> Bool
-- polygon_direction poly = isLeftTurn (p (l-1) 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
--               -- the index of the right-/upmost point
--               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
										   
polygon_direction :: [XYI] -> Bool
polygon_direction poly = trace (show (sum (zipWith crossp l1 l2))) (sum (zipWith crossp l1 l2) > 0)
  where l1 = map (\(a,b) -> b `sub` a) ((tail c) ++ [head c])
        l2 = map (\(a,b) -> a `sub` b) c
        c = map to_tuple (cycle_neighbours poly) -- [(p0,p1,0),(p1,p2,1),(p2,p3,2),..
        to_tuple (a:b:[]) = (a,b)
        sub (x0,y0,_) (x1,y1,_) = (x0-x1, y0-y1, 0)
        crossp (v0,v1,_) (w0,w1,_) = v0*w1-v1*w0

-- return a list containing lists of every element with its neighbour
-- i.e. [e1,e2,e3] -> [ [e1,e2], [e2,e3], [e3, e1] ]
cycle_neighbours :: [a] -> [[a]]
cycle_neighbours [] = []
cycle_neighbours xs = cycle_n (head xs) xs

cycle_n :: a -> [a] -> [[a]]
cycle_n f (x:y:xs) = [x,y] : (cycle_n f (y:xs))
cycle_n f e = [[head e, f ]] -- if the upper doesn't match close cycle