{-
   ColorMat.hs (adapted from colormat.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>

   After initialization, the program will be in
   ColorMaterial mode.  Interaction:  pressing the 
   mouse buttons will change the diffuse reflection values.
-}

import Data.IORef  ( IORef, newIORef, readIORef, writeIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

--  Initialize material property, light source, lighting model,
--  and depth buffer.

myInit :: IORef (Color4 GLfloat) -> IO ()
myInit diffuseMaterial = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   shadeModel Smooth
   enable DepthTest
   d <- readIORef diffuseMaterial
   mapM_ (material Front) [ MaterialColor Diffuse d,
                            MaterialColor Specular (Color4 1.0 1.0 1.0 1.0),
                            Shininess 25.0 ]
   light (Light 0) (Position (Vertex4 1.0 1.0 1.0 0.0))
   enable Lighting
   enable (Light 0)

   colorMaterial Front Diffuse
   enable ColorMaterial

display :: DisplayCallback
display = do
   clear [ColorBufferBit, DepthBufferBit]
   renderObject Solid (Sphere 1.0 20 16)
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   let wf = fromIntegral w
       hf = fromIntegral h
   if (w <= h)
      then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10.0) 10.0
      else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10.0) 10.0
   matrixMode Modelview
   loadIdentity

keyboardMouse :: IORef (Color4 GLfloat) -> KeyboardMouseCallback
keyboardMouse diffuseMaterial (MouseButton LeftButton  ) Down _ _ = updateColor 0.1 0.0 0.0 diffuseMaterial
keyboardMouse diffuseMaterial (MouseButton MiddleButton) Down _ _ = updateColor 0.0 0.1 0.0 diffuseMaterial
keyboardMouse diffuseMaterial (MouseButton RightButton ) Down _ _ = updateColor 0.0 0.0 0.1 diffuseMaterial
keyboardMouse _               (Char '\27')               _    _ _ = exitWith ExitSuccess
keyboardMouse _               _                          _    _ _ = return ()

updateColor :: GLfloat -> GLfloat -> GLfloat -> IORef (Color4 GLfloat) -> IO ()
updateColor ri gi bi diffuseMaterial = do
   Color4 r g b a <- readIORef diffuseMaterial
   let c = Color4 (inc r ri) (inc g gi) (inc b bi) a
   writeIORef diffuseMaterial c
   color c
   postRedisplay

inc :: GLfloat -> GLfloat -> GLfloat
inc x y = if z > 1.0 then 0.0 else z
   where z = x + y

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 500 500)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   diffuseMaterial <- newIORef (Color4 0.5 0.5 0.5 1.0)
   myInit diffuseMaterial
   setDisplayCallback display
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just (keyboardMouse diffuseMaterial))
   mainLoop
