{-
   Demonstration of Quake-like movement and translucency.
   Use the following keys:   (my favourite FPS key binding :-)
      * Translation: s/f, a/SPACE, d/e
      * Rotation: cursor keys
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}

module Main(main) where

import Array
import Data.IORef ( IORef, newIORef, readIORef )

import GL
import GLU
import Graphics.UI.GLUT

import Geometry as G
import Player

---------------------------------------------------------------------------

drawAxes :: GLfloat -> IO ()
drawAxes len = do
  let c r g b = Color3 r g b :: Color3 GLfloat
  beginEnd Lines $ do
    color (c 0.8 0.0 0.0);   vertex (Vertex3 (-len) 0 0)
    color (c 1.0 0.8 0.8);   vertex (Vertex3   len  0 0)
	    
    color (c 0.0 0.8 0.0);   vertex (Vertex3 0 (-len) 0)
    color (c 0.8 1.0 0.8);   vertex (Vertex3 0   len  0)
	    
    color (c 0.0 0.0 0.8);   vertex (Vertex3 0 0 (-len))
    color (c 0.8 0.8 1.0);   vertex (Vertex3 0 0   len)

---------------------------------------------------------------------------

vertices :: Array Int (Vertex3 GLfloat)
vertices = listArray (0,7) [
   (Vertex3 (-5) (-5) (-5)), (Vertex3   5 (-5) (-5)),
   (Vertex3   5    5  (-5)), (Vertex3 (-5)  5  (-5)),
   (Vertex3 (-5) (-5)   5 ), (Vertex3   5 (-5)   5 ),
   (Vertex3   5    5    5 ), (Vertex3 (-5)  5    5) ]

normals :: Array Int (Normal3 GLfloat)
normals = listArray (0, 7) [
   (Normal3 (-1) (-1) (-1)), (Normal3   1  (-1) (-1)),
   (Normal3   1    1  (-1)), (Normal3 (-1)   1  (-1)),
   (Normal3 (-1) (-1)   1 ), (Normal3   1  (-1)   1 ),
   (Normal3   1    1    1 ), (Normal3 (-1)   1    1 ) ]

colors :: Array Int (Color3 GLfloat)
colors = listArray (0, 7) [
   (Color3 0 0 0), (Color3 1 0 0),
   (Color3 1 1 0), (Color3 0 1 0), 
   (Color3 0 0 1), (Color3 1 0 1),
   (Color3 1 1 1), (Color3 0 1 1) ]

polygon :: (Int, Int, Int, Int) -> IO ()
polygon (a, b, c, d) = do
  beginEnd Polygon $
     mapM_ (\i -> do color  (colors   ! i)
                     normal (normals  ! i)
                     vertex (vertices ! i))
           [a, b, c, d]

colorCube :: IO ()
colorCube = mapM_ polygon [(0,3,2,1), (2,3,7,6), (0,4,7,3),
                           (1,2,6,5), (4,5,6,7), (0,1,5,4)]

---------------------------------------------------------------------------

transparentFace :: GLfloat -> GLfloat -> IO ()
transparentFace s z = do
   enable Blend'
   depthMask False
   blendFunc SrcAlpha OneMinusSrcAlpha
   color (Color4 1 0 0 0.4 :: Color4 GLfloat)
   translate (Vector3 1.5 0 0 :: Vector3 GLfloat)
   beginEnd Polygon $ do
      vertex (Vertex3   s    s  z)
      vertex (Vertex3 (-s)   s  z)
      vertex (Vertex3 (-s) (-s) z)
      vertex (Vertex3   s  (-s) z)
   depthMask True
   disable Blend'

---------------------------------------------------------------------------

display :: IORef PlayerState -> DisplayCallback
display playerState = do
   clear [ColorBufferBit, DepthBufferBit]
   readIORef playerState >>= positionCamera
   colorCube
   drawAxes 10
   transparentFace 2.5 12
   swapBuffers
   
reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   let zNear = 1
       zFar  = 500
       wf    = fromIntegral w
       hf    = fromIntegral h
   perspective 80 (wf/hf) zNear zFar
   matrixMode Modelview
   loadIdentity

initGraphics :: IO ()
initGraphics = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   enable DepthTest

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Graphics.UI.GLUT.Double, RGB, Graphics.UI.GLUT.Depth ]
   createWindow progName
   playerState <- newIORef (makePlayerState (G.Point 0 0 20) 0 0)
   setDisplayCallback (display playerState)
   initGraphics
   setReshapeCallback (Just reshape)
   (_bindKey, stillDown) <- quakeBindings 3 5 playerState
   setIdleCallback (Just (do stillDown; postRedisplay))
   mainLoop
