{-
   Teapots.hs (adapted from teapots.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 lots of material properties.
   A single light source illuminates the objects.
-}

import Control.Monad ( liftM )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

-- Initialize depth buffer, projection matrix, light source, and lighting
-- model.  Do not specify a material property here.
myInit :: IO DisplayList
myInit = do
   mapM_ (light (Light 0)) [
      LightColor Ambient (Color4 0.0 0.0 0.0 1.0),
      LightColor Diffuse (Color4 1.0 1.0 1.0 1.0),
      Position (Vertex4 0.0 3.0 3.0 0.0) ]
   mapM_ lightModel [
      LightModelAmbient (Color4 0.2 0.2 0.2 1.0),
      LightModelLocalViewer False ]

   frontFace Cw
   enable Lighting
   enable (Light 0)
   enable AutoNormal
   enable Normalize
   enable DepthTest
   -- be efficient--make teapot display list
   teapotList <- liftM head (genLists 1)
   newEndList teapotList Compile (renderObject Solid (Teapot 1.0))
   return teapotList

-- Move object into position.  Use 3rd through 6th 
-- parameters to specify the material property.  Draw a teapot.
renderTeapot :: DisplayList -> Vector2 GLfloat -> Color3 GLfloat
             -> Color3 GLfloat -> Color3 GLfloat -> GLfloat -> IO ()
renderTeapot teapotList (Vector2 x y) amb dif spec shine = do
   pushMatrix
   translate (Vector3 x y 0)
   let c34 (Color3 r g b) = Color4 r g b 1
   mapM_ (material Front) [
      MaterialColor Ambient  (c34 amb ),
      MaterialColor Diffuse  (c34 dif ),
      MaterialColor Specular (c34 spec),
      Shininess (shine * 128) ]
   callList teapotList
   popMatrix

-- First column:  emerald, jade, obsidian, pearl, ruby, turquoise
-- 2nd column:  brass, bronze, chrome, copper, gold, silver
-- 3rd column:  black, cyan, green, red, white, yellow plastic
-- 4th column:  black, cyan, green, red, white, yellow rubber
display :: DisplayList -> DisplayCallback
display teapotList = do
   clear [ ColorBufferBit, DepthBufferBit ]

   let rp = renderTeapot teapotList
   rp (Vector2  2.0 17.0)
      (Color3 0.0215     0.1745     0.0215    )
      (Color3 0.07568    0.61424    0.07568   )
      (Color3 0.633      0.727811   0.633     ) 0.6
   rp (Vector2  2.0 14.0)
      (Color3 0.135      0.2225     0.1575    )
      (Color3 0.54       0.89       0.63      )
      (Color3 0.316228   0.316228   0.316228  ) 0.1
   rp (Vector2  2.0 11.0)
      (Color3 0.05375    0.05       0.06625   )
      (Color3 0.18275    0.17       0.22525   )
      (Color3 0.332741   0.328634   0.346435  ) 0.3
   rp (Vector2  2.0  8.0)
      (Color3 0.25       0.20725    0.20725   )
      (Color3 1          0.829      0.829     )
      (Color3 0.296648   0.296648   0.296648  ) 0.088
   rp (Vector2  2.0  5.0)
      (Color3 0.1745     0.01175    0.01175   )
      (Color3 0.61424    0.04136    0.04136   )
      (Color3 0.727811   0.626959   0.626959  ) 0.6
   rp (Vector2  2.0  2.0)
      (Color3 0.1        0.18725    0.1745    )
      (Color3 0.396      0.74151    0.69102   )
      (Color3 0.297254   0.30829    0.306678  ) 0.1
   rp (Vector2  6.0 17.0)
      (Color3 0.329412   0.223529   0.027451  )
      (Color3 0.780392   0.568627   0.113725  )
      (Color3 0.992157   0.941176   0.807843  ) 0.21794872
   rp (Vector2  6.0 14.0)
      (Color3 0.2125     0.1275     0.054     )
      (Color3 0.714      0.4284     0.18144   )
      (Color3 0.393548   0.271906   0.166721  ) 0.2
   rp (Vector2  6.0 11.0)
      (Color3 0.25       0.25       0.25      )
      (Color3 0.4        0.4        0.4       )
      (Color3 0.774597   0.774597   0.774597  ) 0.6
   rp (Vector2  6.0  8.0)
      (Color3 0.19125    0.0735     0.0225    )
      (Color3 0.7038     0.27048    0.0828    )
      (Color3 0.256777   0.137622   0.086014  ) 0.1
   rp (Vector2  6.0  5.0)
      (Color3 0.24725    0.1995     0.0745    )
      (Color3 0.75164    0.60648    0.22648   )
      (Color3 0.628281   0.555802   0.366065  ) 0.4
   rp (Vector2  6.0  2.0)
      (Color3 0.19225    0.19225    0.19225   )
      (Color3 0.50754    0.50754    0.50754   )
      (Color3 0.508273   0.508273   0.508273  ) 0.4
   rp (Vector2 10.0 17.0)
      (Color3 0.0        0.0        0.0       )
      (Color3 0.01       0.01       0.01      )
      (Color3 0.50       0.50       0.50      ) 0.25
   rp (Vector2 10.0 14.0)
      (Color3 0.0        0.1        0.06      )
      (Color3 0.0        0.50980392 0.50980392)
      (Color3 0.50196078 0.50196078 0.50196078) 0.25
   rp (Vector2 10.0 11.0)
      (Color3 0.0        0.0        0.0       )
      (Color3 0.1        0.35       0.1       )
      (Color3 0.45       0.55       0.45      ) 0.25
   rp (Vector2 10.0  8.0)
      (Color3 0.0        0.0        0.0       )
      (Color3 0.5        0.0        0.0       )
      (Color3 0.7        0.6        0.6       ) 0.25
   rp (Vector2 10.0  5.0)
      (Color3 0.0        0.0        0.0       )
      (Color3 0.55       0.55       0.55      )
      (Color3 0.70       0.70       0.70      ) 0.25
   rp (Vector2 10.0  2.0)
      (Color3 0.0        0.0        0.0       )
      (Color3 0.5        0.5        0.0       )
      (Color3 0.60       0.60       0.50      ) 0.25
   rp (Vector2 14.0 17.0)
      (Color3 0.02       0.02       0.02      )
      (Color3 0.01       0.01       0.01      )
      (Color3 0.4        0.4        0.4       ) 0.078125
   rp (Vector2 14.0 14.0)
      (Color3 0.0        0.05       0.05      )
      (Color3 0.4        0.5        0.5       )
      (Color3 0.04       0.7        0.7       ) 0.078125
   rp (Vector2 14.0 11.0)
      (Color3 0.0        0.05       0.0       )
      (Color3 0.4        0.5        0.4       )
      (Color3 0.04       0.7        0.04      ) 0.078125
   rp (Vector2 14.0  8.0)
      (Color3 0.05       0.0        0.0       )
      (Color3 0.5        0.4        0.4       )
      (Color3 0.7        0.04       0.04      ) 0.078125
   rp (Vector2 14.0  5.0)
      (Color3 0.05       0.05       0.05      )
      (Color3 0.5        0.5        0.5       )
      (Color3 0.7        0.7        0.7       ) 0.078125
   rp (Vector2 14.0  2.0)
      (Color3 0.05       0.05       0.0       )
      (Color3 0.5        0.5        0.4       )
      (Color3 0.7        0.7        0.04      ) 0.078125
   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 0.0 16.0 0.0 (16.0*hf/wf) (-10.0) 10.0
      else ortho 0.0 (16.0*wf/hf) 0.0 16.0 (-10.0) 10.0
   matrixMode Modelview

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

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