{-
   PolyOff.hs (adapted from polyoff.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>

   This program demonstrates polygon offset to draw a shaded
   polygon and its wireframe counterpart without ugly visual
   artifacts ("stitching").
-}

import Control.Monad ( when, liftM )
import Data.IORef    ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

-- display draws two spheres, one with a gray, diffuse material,
-- the other sphere with a magenta material with a specular highlight.
-- SUP: magenta???
display :: DisplayList -> IORef GLint -> IORef GLint ->
           IORef GLfloat -> IORef GLfloat -> IORef GLfloat -> DisplayCallback
display list spinX spinY tDist polyFactor polyUnits = do
   clear [ColorBufferBit, DepthBufferBit]
   pushMatrix
   z  <- readIORef tDist
   translate (Vector3 0 0 z)
   sx <- readIORef spinX
   rotate (fromIntegral sx :: GLfloat) (Vector3 1 0 0)
   sy <- readIORef spinY
   rotate (fromIntegral sy :: GLfloat) (Vector3 0 1 0)

   mapM_ (material Front) [
      MaterialColor AmbientAndDiffuse (Color4 0.8 0.8 0.8 1.0),
      MaterialColor Specular          (Color4 0.0 0.0 0.0 1.0),
      Shininess 0 ]
   enable Lighting
   enable (Light 0)
   enable PolygonOffsetFill
   factor <- readIORef polyFactor
   units  <- readIORef polyUnits
   polygonOffset factor units
   callList list

   disable PolygonOffsetFill
   disable Lighting
   disable (Light 0)
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   polygonMode FrontAndBack GL.Line
   callList list
   polygonMode FrontAndBack GL.Fill

   popMatrix
   flush

-- specify initial properties
-- create display list with sphere  
-- initialize lighting and depth buffer
gfxInit :: IO DisplayList
gfxInit = do
   clearColor (Color4 0.0 0.0 0.0 1.0)

   [list] <- genLists 1
   newEndList list Compile $
      renderObject Solid (Graphics.UI.GLUT.Sphere 1.0 20 12)

   enable DepthTest

   mapM_ (light (Light 0)) [
      LightColor Ambient  (Color4 0.0 0.0 0.0 1.0),
      LightColor Diffuse  (Color4 1.0 1.0 1.0 1.0),
      LightColor Specular (Color4 1.0 1.0 1.0 1.0),
      Position (Vertex4 1.0 1.0 1.0 0.0) ]

   lightModel (LightModelAmbient (Color4 0.2 0.2 0.2 1.0))
   return list

-- call when window is resized
reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   perspective 45 (fromIntegral w / fromIntegral h) 1 10
   matrixMode Modelview
   loadIdentity
   lookAt (0, 0, 5) (0, 0, 0) (0, 1, 0)

keyboard :: IORef GLfloat -> IORef GLfloat -> IORef GLfloat -> IORef GLint -> IORef GLint -> KeyboardMouseCallback
keyboard tDist _          _         _     _     (Char 't')                 Down _ _ = updateTDist tDist (<  4.0)   0.5
keyboard tDist _          _         _     _     (Char 'T')                 Down _ _ = updateTDist tDist (> -5.0) (-0.5)
keyboard _     polyFactor _         _     _     (Char 'F')                 Down _ _ = updatePoly "factor" polyFactor   0.1
keyboard _     polyFactor _         _     _     (Char 'f')                 Down _ _ = updatePoly "factor" polyFactor (-0.1)
keyboard _     _          polyUnits _     _     (Char 'U')                 Down _ _ = updatePoly "units"  polyUnits    1.0
keyboard _     _          polyUnits _     _     (Char 'u')                 Down _ _ = updatePoly "untis"  polyUnits  (-1.0)
keyboard _     _          _         spinX _     (MouseButton LeftButton)   Down _ _ = updateSpin spinX
keyboard _     _          _         _     spinY (MouseButton MiddleButton) Down _ _ = updateSpin spinY
keyboard _     _          _         _     _     (MouseButton RightButton)  Up   _ _ = exitWith ExitSuccess
keyboard _     _          _         _     _     _                          _    _ _ = return ()

updateTDist :: IORef GLfloat -> (GLfloat -> Bool) -> GLfloat -> IO ()
updateTDist tDist test inc = do
   t <- readIORef tDist
   when (test t) (do writeIORef tDist (t+inc); postRedisplay)

updatePoly :: String -> IORef GLfloat -> GLfloat -> IO ()
updatePoly msg p inc = do
   newP <- liftM (+inc) (readIORef p)
   writeIORef p newP
   putStrLn ("poly" ++ msg ++ " is " ++ show newP)
   postRedisplay

updateSpin :: IORef GLint -> IO ()
updateSpin spin = do
   modifyIORef spin (\s -> (s+5) `mod` 360)
   postRedisplay

-- Main Loop
-- Open window with initial window size, title bar, 
-- RGBA display mode, and handle input events.
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Depth ]
   createWindow progName
   setReshapeCallback (Just reshape)
   list <- gfxInit
   spinX <- newIORef 0
   spinY <- newIORef 0
   tDist <- newIORef 0.0
   polyFactor <- newIORef 1.0
   polyUnits <- newIORef 1.0
   setDisplayCallback (display list spinX spinY tDist polyFactor polyUnits)
   setKeyboardMouseCallback (Just (keyboard tDist polyFactor polyUnits spinX spinY))
   mainLoop
