{-
   Surface.hs (adapted from surface.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 draws a NURBS surface in the shape of a 
   symmetrical hill.  The 'c' keyboard key allows you to 
   toggle the visibility of the control points themselves.  
   Note that some of the control points are hidden by the  
   surface itself.
-}

import Char(toLower)
import IOExts(IORef, newIORef, readIORef, writeIORef)
import Monad(when)
import GL
import GLU
import Graphics.UI.GLUT

-- Initializes the control points of the surface to a small hill.
-- The control points range from -3 to +3 in x, y, and z
ctlPoints :: [Vertex3 GLfloat]
ctlPoints = [ Vertex3 (2 * (u - 1.5))
                      (2 * (v - 1.5))
                      (if (u == 1 || u == 2) && (v == 1 || v == 2) then 3 else -3)
            | u <- [ 0 .. 3 ],
              v <- [ 0 .. 3 ] ]

nurbsError :: Error -> IO ()
nurbsError e = do
   message <- errorString e
   ioError (userError ("Nurbs Error " ++ message))

-- Initialize material property and depth buffer.
myInit :: IO NurbsObj
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   mapM_ (material Front) [
      MaterialColor Diffuse  (Color4 0.7 0.7 0.7 1.0),
      MaterialColor Specular (Color4 1.0 1.0 1.0 1.0),
      Shininess 100 ]

   enable Lighting
   enable (Light 0)
   enable DepthTest
   enable AutoNormal
   enable Normalize

   theNurb <- newNurbsRenderer
   mapM_ (nurbsProperty theNurb) [
      SamplingMethod (PathLength 25),
      DisplayMode Fill' ]
   nurbsCallback theNurb (Just nurbsError)
   return theNurb

display :: IORef Bool -> NurbsObj -> DisplayCallback
display showPoints theNurb = do
   let knots = [ 0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 :: GLfloat ]

   clear [ ColorBufferBit, DepthBufferBit ]
   pushMatrix
   rotate (330 :: GLfloat) (Vector3 1 0 0)
   scale (0.5 :: GLfloat) 0.5 0.5

   -- This marshaling can be lifted out of this function for better efficiency.
   inParamWith marshalList snd (\ (_numCtlPts, ctlPointsBuf) ->
      inParamWith marshalList snd (\ (numKnots, knotsBuf) ->
         beginEndSurface theNurb $
            nurbsSurface theNurb
                         (fromIntegral numKnots) (castPtr knotsBuf)
                         (fromIntegral numKnots) (castPtr knotsBuf)
                         (4 * 3) 3 (castPtr ctlPointsBuf) 4 4 Map2Vertex3)  -- 4 and 3 are hacks...
         knots)
      ctlPoints

   sp <- readIORef showPoints
   when sp $ do
      pointSize 5.0
      disable Lighting
      color (Color3 (1.0 :: GLfloat) 1.0 0.0)
      beginEnd Points $ do
         mapM_ vertex ctlPoints
      enable Lighting

   popMatrix
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   perspective 45.0 (fromIntegral w / fromIntegral h) 3.0 8.0
   matrixMode Modelview
   loadIdentity
   translate (Vector3 0 0 (-5 :: GLfloat))

keyboard :: IORef Bool -> KeyboardMouseCallback
keyboard showPoints c _ = case toLower c of
   'c'   -> do modifyIORef showPoints not; postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   -- Note: The display callback is set *after* initialization
   createWindow progName (return ()) [ Single, RGB, GLUT.Depth ]
                (Just (WindowPosition 100 100))
                (Just (WindowSize     500 500))
   showPoints <- newIORef False
   theNurb <- myInit
   setDisplayCallback (display showPoints theNurb)
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just (keyboard showPoints))
   mainLoop
