{-
   Nurbs.hs (adapted from nurbs.c which is (c) Mark J. Kilgard)
   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 shows a NURBS (Non-uniform rational B-splines)
   surface, shaped like a heart.
-}

import GL
import GLU
import Graphics.UI.GLUT

sOrder, tOrder, tNumPoints :: GLint
sOrder     = 3
tOrder     = 3
tNumPoints = 3

-- initialized local data
sKnots, tKnots :: [GLfloat]
sKnots = [-1.0, -1.0, -1.0, 0.0, 1.0, 2.0, 3.0, 4.0,
           4.0,  5.0,  6.0, 7.0, 8.0, 9.0, 9.0, 9.0 ]
tKnots = [ 1.0,  1.0,  1.0, 2.0, 2.0, 2.0 ]

ctlPoints :: [Vertex4 GLfloat]
ctlPoints = [
   Vertex4 4.0 2.0 2.0 1.0, Vertex4 4.0 1.6 2.5 1.0, Vertex4 4.0 2.0 3.0 1.0,
   Vertex4 5.0 4.0 2.0 1.0, Vertex4 5.0 4.0 2.5 1.0, Vertex4 5.0 4.0 3.0 1.0,
   Vertex4 6.0 5.0 2.0 1.0, Vertex4 6.0 5.0 2.5 1.0, Vertex4 6.0 5.0 3.0 1.0,
   Vertex4 (sqrt 2 * 6.0) (sqrt 2 * 6.0) (sqrt 2 * 2.0) (sqrt 2),
   Vertex4 (sqrt 2 * 6.0) (sqrt 2 * 6.0) (sqrt 2 * 2.5) (sqrt 2),
   Vertex4 (sqrt 2 * 6.0) (sqrt 2 * 6.0) (sqrt 2 * 3.0) (sqrt 2),
   Vertex4 5.2 6.7 2.0 1.0, Vertex4 5.2 6.7 2.5 1.0, Vertex4 5.2 6.7 3.0 1.0,
   Vertex4 (sqrt 2 * 4.0) (sqrt 2 * 6.0) (sqrt 2 * 2.0) (sqrt 2),
   Vertex4 (sqrt 2 * 4.0) (sqrt 2 * 6.0) (sqrt 2 * 2.5) (sqrt 2),
   Vertex4 (sqrt 2 * 4.0) (sqrt 2 * 6.0) (sqrt 2 * 3.0) (sqrt 2),
   Vertex4 4.0 5.2 2.0 1.0, Vertex4 4.0 4.6 2.5 1.0, Vertex4 4.0 5.2 3.0 1.0,
   Vertex4 (sqrt 2 * 4.0) (sqrt 2 * 6.0) (sqrt 2 * 2.0) (sqrt 2),
   Vertex4 (sqrt 2 * 4.0) (sqrt 2 * 6.0) (sqrt 2 * 2.5) (sqrt 2),
   Vertex4 (sqrt 2 * 4.0) (sqrt 2 * 6.0) (sqrt 2 * 3.0) (sqrt 2),
   Vertex4 2.8 6.7 2.0 1.0, Vertex4 2.8 6.7 2.5 1.0, Vertex4 2.8 6.7 3.0 1.0,
   Vertex4 (sqrt 2 * 2.0) (sqrt 2 * 6.0) (sqrt 2 * 2.0) (sqrt 2),
   Vertex4 (sqrt 2 * 2.0) (sqrt 2 * 6.0) (sqrt 2 * 2.5) (sqrt 2),
   Vertex4 (sqrt 2 * 2.0) (sqrt 2 * 6.0) (sqrt 2 * 3.0) (sqrt 2),
   Vertex4 2.0 5.0 2.0 1.0, Vertex4 2.0 5.0 2.5 1.0, Vertex4 2.0 5.0 3.0 1.0,
   Vertex4 3.0 4.0 2.0 1.0, Vertex4 3.0 4.0 2.5 1.0, Vertex4 3.0 4.0 3.0 1.0,
   Vertex4 4.0 2.0 2.0 1.0, Vertex4 4.0 1.6 2.5 1.0, Vertex4 4.0 2.0 3.0 1.0 ]

-- Initialize material property, light source, lighting model,
-- and depth buffer.
myInit :: IO NurbsObj
myInit = do
   mapM_ (material Front) [
      MaterialColor Ambient  (Color4 1.0 1.0 1.0 1.0),
      MaterialColor Diffuse  (Color4 1.0 0.2 1.0 1.0),
      MaterialColor Specular (Color4 1.0 1.0 1.0 1.0),
      Shininess 50 ]
   light (Light 0) (Position (Vertex4   1.0  0.1 1.0 0.0))
   light (Light 1) (Position (Vertex4 (-1.0) 0.1 1.0 0.0))
   lightModel (LightModelAmbient (Color4 0.3 0.3 0.3 1.0))

   enable Lighting
   enable (Light 0)
   enable (Light 1)
   depthFunc GL.Less
   enable DepthTest
   enable AutoNormal

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

display :: NurbsObj -> DisplayCallback
display theNurb = do
   clear [ ColorBufferBit, DepthBufferBit ]

   pushMatrix
   translate (Vector3 4.0 4.5 (2.5 :: GLfloat))
   rotate (220 :: GLfloat) (Vector3 1 0 0)
   rotate (115 :: GLfloat) (Vector3 0 1 0)
   translate (Vector3 (-4.0) (-4.5) (-2.5 :: GLfloat))

   -- Uh, oh, we really need some nicer marshaling stuff here
   -- This marshaling can be lifted out of this function for better efficiency.
   inParamWith marshalList snd (\ (sNumKnots, sKnotsBuf) ->
      inParamWith marshalList snd (\ (tNumKnots, tKnotsBuf) ->
         inParamWith marshalList snd (\ (_numCtlPoints, ctlPointsBuf) ->
            beginEndSurface theNurb $
               nurbsSurface theNurb
                            (fromIntegral sNumKnots) (castPtr sKnotsBuf)
                            (fromIntegral tNumKnots) (castPtr tKnotsBuf)
	                    (4 * tNumPoints) 4 (castPtr ctlPointsBuf) sOrder tOrder Map2Vertex4)
            ctlPoints)
         tKnots)
      sKnots

   popMatrix
   flush

myReshape :: ReshapeCallback
myReshape screenSize = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   frustum (-1.0) 1.0 (-1.5) 0.5 0.8 10.0

   matrixMode Modelview
   loadIdentity
   lookAt (7.0, 4.5, 4.0) (4.5, 4.5, 2.0) (6.0, -3.0, 2.0)

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

-- Main Loop
-- Open window with initial window size, title bar,
-- RGBA display mode, and handle input events.
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   -- Note: The display callback is set *after* initialization
   createWindow progName (return ()) [ Single, RGB, GLUT.Depth ]
                Nothing Nothing
   theNurb <- myInit
   setDisplayCallback (display theNurb)
   setReshapeCallback (Just myReshape)
   setKeyboardMouseCallback (Just key)
   mainLoop
