{-
   Quadric.hs (adapted from quadric.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 the use of some of the quadric* routines.
   Quadric objects are created with some quadric properties and the callback
   routine to handle errors. Note that the cylinder has no top or bottom and
   the circle has a hole in it.
-}

import System.Exit ( exitWith, ExitCode(ExitSuccess), exitFailure )

import GL
import GLU
import Graphics.UI.GLUT

checkForError :: IO (Maybe Error) -> IO ()
checkForError action = do
   maybeError <- action
   case maybeError of
      Nothing ->  return ()
      Just (Error _category description) -> do putStrLn description
                                               exitFailure

myInit :: IO (DisplayList, DisplayList, DisplayList, DisplayList)
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)

   mapM_ (material Front) [ MaterialColor Ambient  (Color4 0.5 0.5 0.5 1.0),
                            MaterialColor Specular (Color4 1.0 1.0 1.0 1.0),
                            Shininess 50.0 ]
   light (Light 0) (Position (Vertex4 1.0 1.0 1.0 0.0))
   lightModel (LightModelAmbient (Color4 0.5 0.5 0.5 1.0))

   enable Lighting
   enable (Light 0)
   enable DepthTest

   -- Create 4 display lists, each with a different quadric object. Different
   -- drawing styles and surface normal specifications are demonstrated.

   [ dlSmooth, dlFlat, dlWire, dlSilh ] <- genLists 4

   -- smooth shaded
   newEndList dlSmooth Compile $ checkForError $
      renderQuadric (QuadricStyle GLU.Smooth NoTextureCoordinates Outside GLU.Fill)
                    (GLU.Sphere 0.75 15 10)

   -- flat shaded
   newEndList dlFlat Compile $ checkForError $
      renderQuadric (QuadricStyle GLU.Flat NoTextureCoordinates Outside GLU.Fill)
                    (Cylinder 0.5 0.3 1.0 15 5)

   -- all polygons wireframe
   newEndList dlWire Compile $ checkForError $
      renderQuadric (QuadricStyle GLU.None NoTextureCoordinates Outside GLU.Line)
                    (Disk 0.25 1.0 20 4)

   -- boundary only
   newEndList dlSilh Compile $ checkForError $
      renderQuadric (QuadricStyle GLU.None NoTextureCoordinates Outside Silhouette)
                    (PartialDisk 0.0 1.0 20 4 0.0 225.0)

   return (dlSmooth, dlFlat, dlWire, dlSilh)

display :: (DisplayList, DisplayList, DisplayList, DisplayList) -> DisplayCallback
display (dlSmooth, dlFlat, dlWire, dlSilh) = do
   clear [ColorBufferBit, DepthBufferBit]
   pushMatrix

   enable Lighting
   shadeModel GL.Smooth
   translate (Vector3 (-1) (-1) 0 :: Vector3 GLfloat)
   callList dlSmooth

   shadeModel GL.Flat
   translate (Vector3 0 2 0 :: Vector3 GLfloat)
   pushMatrix
   rotate (300 :: GLfloat) (Vector3 1 0 0)
   callList dlFlat
   popMatrix

   disable Lighting
   color (Color3 0.0 1.0 1.0 :: Color3 GLfloat)
   translate (Vector3 2 (-2) 0 :: Vector3 GLfloat)
   callList dlWire

   color (Color3 1.0 1.0 0.0 :: Color3 GLfloat)
   translate (Vector3 0 2 0 :: Vector3 GLfloat)
   callList dlSilh

   popMatrix
   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 (-2.5) 2.5 (-2.5*hf/wf) (2.5*hf/wf) (-10.0) 10.0
      else ortho (-2.5*wf/hf) (2.5*wf/hf) (-2.5) 2.5 (-10.0) 10.0
   matrixMode Modelview
   loadIdentity

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

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