{-
   Trim.hs (adapted from trim.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, using both a NURBS curve and pwl
   (piecewise linear) curve to trim part of the surface.
-}

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 :: NurbsObj -> DisplayCallback
display theNurb = do
   let knots      = [ 0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 :: GLfloat ]
       edgePt     = [ Vertex2 0.0   0.0,  Vertex2 1.0   0.0, Vertex2 1.0 1.0,
                      Vertex2 0.0   1.0,  Vertex2 0.0  (0.0 :: GLfloat) ] -- counter clockwise
       curvePt    = [ Vertex2 0.25  0.5,  Vertex2 0.25  0.75,
                      Vertex2 0.75  0.75, Vertex2 0.75 (0.5 :: GLfloat) ] -- clockwise
       curveKnots = [ 0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 :: GLfloat ]
       pwlPt      = [ Vertex2 0.75  0.5,  Vertex2 0.5   0.25,
                      Vertex2 0.25 (0.5 :: GLfloat) ] -- clockwise

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

   -- 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 (\ (_numCtlPts, ctlPointsBuf) ->
      inParamWith marshalList snd (\ (numKnots, knotsBuf) ->
         inParamWith marshalList snd (\ (numEdges, edgePtBuf) ->
            inParamWith marshalList snd (\ (_numCurvePts, curvePtBuf) ->
               inParamWith marshalList snd (\ (numCurveKnots, curveKnotsBuf) ->
                  inParamWith marshalList snd (\ (numPts, pwlPtBuf) ->
                     beginEndSurface theNurb $ do
                        nurbsSurface theNurb
                                     (fromIntegral numKnots) (castPtr knotsBuf)
                                     (fromIntegral numKnots) (castPtr knotsBuf)
                                     (4 * 3) 3 (castPtr ctlPointsBuf) 4 4 Map2Vertex3  -- 4 and 3 are hacks...
                        beginEndTrim theNurb $
                           pwlCurve theNurb (fromIntegral numEdges) (castPtr edgePtBuf) 2 Map1Trim2
                        beginEndTrim theNurb $ do
                           nurbsCurve theNurb (fromIntegral numCurveKnots)
                                      curveKnotsBuf 2 (castPtr curvePtBuf) 4 Map1Trim2
                           pwlCurve theNurb (fromIntegral numPts) (castPtr pwlPtBuf) 2 Map1Trim2)
                     pwlPt)
                  curveKnots)
               curvePt)
            edgePt)
         knots)
      ctlPoints

   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 :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _            _    _ _ = 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))
   theNurb <- myInit
   setDisplayCallback (display theNurb)
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just keyboard)
   mainLoop
