{-
   Fog.hs (adapted from fog.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 5 red spheres, each at a different 
   z distance from the eye, in different types of fog.  
   Pressing the f key chooses between 3 types of 
   fog:  exponential, exponential squared, and linear.  
   In this program, there is a fixed density value, as well 
   as fixed start and end values for the linear fog.
-}

import Data.Char   ( toLower )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

myInit :: IO ()
myInit = do
   enable DepthTest
   light (Light 0) (Position (Vertex4 0.5 0.5 3.0 0.0))
   enable Lighting
   enable (Light 0)
   mapM_ (material Front) [
      -- NOTE: The alpha values are missing from fog.c!
      MaterialColor Ambient  (Color4 0.1745   0.01175  0.01175  1.0),
      MaterialColor Diffuse  (Color4 0.61424  0.04136  0.04136  1.0),
      MaterialColor Specular (Color4 0.727811 0.626959 0.626959 1.0),
      Shininess (0.6*128) ]
   enable Fog
   let fogColor = Color4 0.5 0.5 0.5 1.0
   mapM_ fog [ FogDensity (FogExp 0.35), FogColor fogColor ]
   hint FogHint DontCare
   clearColor fogColor

renderSpehere :: Vector3 GLfloat -> IO ()
renderSpehere xyz = do
   pushMatrix
   translate xyz
   renderObject Solid (Sphere 0.4 16 16)
   popMatrix

-- display draws 5 spheres at different z positions.
display :: DisplayCallback
display = do
   clear [ColorBufferBit, DepthBufferBit]
   mapM_ renderSpehere [ Vector3 x (-0.5) (-3-x) | x <- [-2..2] ]
   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 c) Down _ _ = case toLower c of
   'f'   -> do oldDensity <- get VarFogDensity
               let (newDensity, message) = case oldDensity of
                      FogExp  _     -> (FogExp2   0.35,  "Exp2"  )
                      FogExp2 _     -> (FogLinear 1 5,   "Linear")
                      FogLinear _ _ -> (FogExp    0.35,  "Exp"   )
               fog (FogDensity newDensity)
               putStrLn ("Fog mode is " ++ message)
               postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ = return ()

-- Main Loop
-- Open window with initial window size, title bar, 
-- RGBA display mode, depth buffer, and handle input events.
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 500 500)
   createWindow progName
   myInit
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just keyboard)
   setDisplayCallback display
   mainLoop
