{-
   Alpha3D.hs (adapted from alpha3D.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 how to intermix opaque and
   alpha blended polygons in the same scene, by using 
   glDepthMask.  Press the 'a' key to animate moving the 
   transparent object through the opaque object.  Press 
   the 'r' key to reset the scene.
-}

import Data.Char   ( toLower )
import Data.IORef  ( IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

maxZ, minZ, zInc :: GLfloat
maxZ =  8.0
minZ = -8.0
zInc =  0.4

myInit :: IO (DisplayList, DisplayList)
myInit = do
   mapM_ (material Front) [ MaterialColor Specular (Color4 1.0 1.0 1.0 0.15),
                            Shininess 100 ]
   light (Light 0) (Position (Vertex4 0.5 0.5 1.0 0.0))

   enable Lighting
   enable (Light 0)
   enable DepthTest

   [sphereList] <- genLists 1
   newEndList sphereList Compile $ renderObject Solid (Sphere 0.4 16 16)

   [cubeList] <- genLists 1
   newEndList cubeList Compile $ renderObject Solid (Cube 0.6)

   return (sphereList, cubeList)

display :: IORef GLfloat -> DisplayList
        -> IORef GLfloat -> DisplayList -> DisplayCallback
display solidZ sphereList transparentZ cubeList = do
   clear [ ColorBufferBit, DepthBufferBit ]

   pushMatrix
   sz <- readIORef solidZ
   translate (Vector3 (-0.15) (-0.15) sz)
   mapM_ (material Front) [ MaterialColor Emission (Color4 0.0  0.0  0.0 1.0),
                            MaterialColor Diffuse  (Color4 0.75 0.75 0.0 1.0) ]
   callList sphereList
   popMatrix

   pushMatrix
   tz <- readIORef transparentZ
   translate (Vector3 0.15 0.15 tz)
   rotate (15 :: GLfloat) (Vector3 1 1 0)
   rotate (30 :: GLfloat) (Vector3 0 1 0)
   mapM_ (material Front) [ MaterialColor Emission (Color4 0.0 0.3 0.3 0.6),
                            MaterialColor Diffuse  (Color4 0.0 0.8 0.8 0.6) ]
   enable Blend'
   depthMask False
   blendFunc SrcAlpha One
   callList cubeList
   depthMask True
   disable Blend'
   popMatrix

   swapBuffers

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 (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10) 10
      else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10) 10
   matrixMode Modelview
   loadIdentity

animate :: IORef GLfloat -> IORef GLfloat -> IdleCallback
animate solidZ transparentZ = do
   sz <- readIORef solidZ
   tz <- readIORef transparentZ
   if sz <= minZ || tz >= maxZ
      then setIdleCallback Nothing
      else do modifyIORef solidZ (\z -> z - zInc)
              modifyIORef transparentZ (+zInc)
              postRedisplay

keyboard :: IORef GLfloat -> IORef GLfloat -> KeyboardMouseCallback
keyboard solidZ transparentZ (Char c) Down _ _ = case toLower c of
   'a'   -> do writeIORef solidZ maxZ
               writeIORef transparentZ minZ
               setIdleCallback (Just (animate solidZ transparentZ))
   'r'   -> do writeIORef solidZ maxZ
               writeIORef transparentZ minZ
               postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ _ _ = return ()

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 500 500)
   createWindow progName
   solidZ <- newIORef maxZ
   transparentZ <- newIORef minZ
   (sphereList, cubeList) <- myInit
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just (keyboard solidZ transparentZ))
   setDisplayCallback (display solidZ sphereList transparentZ cubeList)
   mainLoop
