{-
   Tess.hs (adapted from tess.c which is (c) Silicon Graphics, Inc)
   This file is part of HOpenGL - a binding of OpenGL and GLUT for Haskell.
   Copyright (C) 2000  Sven Panne <Sven.Panne@informatik.uni-muenchen.de>

   NOTE: This is an adapted version for the GLU 1.0 tesselator.

   COMMENTS FROM GLU 1.2 VERSION:
   This program demonstrates polygon tessellation. Two tesselated objects
   are drawn.  The first is a rectangle with a triangular hole.  The second
   is a smooth shaded, self-intersecting star.

   Note the exterior rectangle is drawn with its vertices in counter-clockwise
   order, but its interior clockwise. Note the combineCallback is needed for
   the self-intersecting star.  Also note that removing the TessProperty for
   the star will make the interior unshaded (TessWindingOdd).
-}

import Data.Either   ( Either(..) )
import System.Exit   ( exitWith, ExitCode(ExitSuccess), exitFailure )
import Control.Monad ( when )

import GL
import GLU
import Graphics.UI.GLUT

display :: [DisplayList] -> DisplayCallback
display displayLists = do
   clear [ColorBufferBit]
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   mapM callList displayLists
   flush

-- 'Float' is a dummy, any marshalable type would do
type DontCare = Float

rectangle :: ComplexContour DontCare
rectangle = ComplexContour [
   AnnotatedVertex (Vertex3  50  50 0) 0,
   AnnotatedVertex (Vertex3 200  50 0) 0,
   AnnotatedVertex (Vertex3 200 200 0) 0,
   AnnotatedVertex (Vertex3  50 200 0) 0 ]

tri :: ComplexContour DontCare
tri = ComplexContour [
   AnnotatedVertex (Vertex3  75  75 0) 0,
   AnnotatedVertex (Vertex3 125 175 0) 0,
   AnnotatedVertex (Vertex3 175  75 0) 0 ]

rectAndTri :: ComplexPolygon DontCare
rectAndTri = ComplexPolygon [ rectangle, tri ]

noOpCombiner :: Combiner DontCare
noOpCombiner _newVertex _weightedProperties = 0

star :: ComplexPolygon (Color3 GLclampf)
star = ComplexPolygon [
   ComplexContour [
      AnnotatedVertex (Vertex3 250  50 0) (Color3 1 0 1),
      AnnotatedVertex (Vertex3 325 200 0) (Color3 1 1 0),
      AnnotatedVertex (Vertex3 400  50 0) (Color3 0 1 1),
      AnnotatedVertex (Vertex3 250 150 0) (Color3 1 0 0),
      AnnotatedVertex (Vertex3 400 150 0) (Color3 0 1 0) ] ]

combineColors :: Combiner (Color3 GLclampf)
combineColors
   _newVertex
   (WeightedProperties
      (w0, Color3 r0 g0 b0)
      (w1, Color3 r1 g1 b1)
      (w2, Color3 r2 g2 b2)
      (w3, Color3 r3 g3 b3)) =
         Color3 (w0*r0 + w1*r1 + w2*r2 + w3*r3)
                (w0*g0 + w1*g1 + w2*g2 + w3*g3)
                (w0*b0 + w1*b1 + w2*b2 + w3*b3)

myInit :: IO [DisplayList]
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)

   displayLists@[ rectAndTriList, starList ] <- genLists 2

   newEndList rectAndTriList Compile $
      drawSimplePolygon (\_ -> return ()) =<<
         simpleTesselator TessWindingOdd noOpCombiner rectAndTri

   newEndList starList Compile $
      drawSimplePolygon color =<<
         simpleTesselator TessWindingPositive combineColors star

   return displayLists

simpleTesselator ::
   Storable v =>
   TessWinding -> Combiner v -> ComplexPolygon v -> IO (SimplePolygon v)
simpleTesselator windingRule combiner complexPolygon =
   checkForError $
      tesselate windingRule 0 (Normal3 0 0 0) combiner complexPolygon

checkForError :: IO (Either Error (SimplePolygon v)) -> IO (SimplePolygon v)
checkForError action = do
   errorOrContours <- action
   case errorOrContours of
      Data.Either.Left (Error _category description) -> do
         putStrLn description
         exitFailure
      Data.Either.Right contours ->
         return contours

drawSimplePolygon :: (v -> IO ()) -> SimplePolygon v -> IO ()
drawSimplePolygon colorHandler (SimplePolygon primitives) =
   flip mapM_ primitives $ \(Primitive vertexMode vertices) ->
      beginEnd vertexMode $
         flip mapM_ vertices $ \(AnnotatedVertex plainVertex col) -> do
            colorHandler col
            vertex plainVertex

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)

keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _            _    _ _ = return ()

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB ]
   setInitialWindowSize (WindowSize 500 500)
   createWindow progName   
   displayLists <- myInit
   setDisplayCallback (display displayLists)
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just keyboard)
   mainLoop
