--
-- This code was created by Jeff Molofee '99 (ported to Haskell GHC 2005)
--

module Main where

import Graphics.UI.GLUT 
import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( openFile, IOMode(..), hGetContents )
import Data.IORef ( IORef, newIORef, writeIORef, readIORef, modifyIORef )
import Util ( Image(..), bitmapLoad )
import Monad ( when )

type Sector = [Tri]

data Tri = Tri Vert Vert Vert
           deriving (Eq, Ord, Show)

data Vert = Vert { vertPoint :: Vertex3 GLfloat, 
                   vertTx, vertTy :: GLfloat }
            deriving (Eq, Ord, Show)

piover180 :: GLfloat
piover180 = 0.0174532925

data Global = Global { xrot, yrot, xspeed, yspeed, walkbias, walkbiasangle,
                       lookupdown, xpos, zpos, camx, camy, camz,
                       therotate, heading, zdepth :: IORef GLfloat,
                       filterSelector :: IORef Int }
mkGlobal :: IO Global
mkGlobal = do xr <- newIORef 0  -- please someone find a nicer way...
              yr <- newIORef 0
              xs <- newIORef 0
              ys <- newIORef 0
              wb <- newIORef 0
              wba <- newIORef 0
              lud <- newIORef 0
              xp <- newIORef 0
              zp <- newIORef 0
              cx <- newIORef 0
              cy <- newIORef 0
              cz <- newIORef 0
              tr <- newIORef 0
              h <- newIORef 0
              zd <- newIORef 0
              fs <- newIORef 0
              return Global { xrot = xr, yrot = yr, xspeed = xs, yspeed = ys,
                              walkbias = wb, walkbiasangle = wba, lookupdown =
                              lud, xpos = xp, zpos = zp, camx = cx, camy = cy,
                              camz = cz, therotate = tr, heading = h,
                              zdepth = zd, filterSelector = fs }

lightAmbient, lightDiffuse :: Color4 GLfloat
lightAmbient = Color4 0.5 0.5 0.5 1
lightDiffuse = Color4 1 1 1 1

lightPosition :: Vertex4 GLfloat
lightPosition = Vertex4 0 0 2 1

readRef :: IO (IORef a) -> IO a
readRef r = r >>= readIORef

setupWorld :: IO Sector
setupWorld = do h <- openFile "Data/world.txt" ReadMode
                ls <- (fmap (filter ignorable) ((fmap lines . hGetContents) h))
                let numtris = read ((head . tail . words . head) ls)
                let tris = readTris (tail ls)
                when (length tris /= numtris) $ putStrLn "error reading world.txt" >> exitWith (ExitFailure 1)
                return tris
  where
  readTris (l1:l2:l3:ls) = Tri (readVert (words l1)) (readVert (words l2))
                               (readVert (words l3)) : readTris ls
  readTris [] = []
  readTris _  = undefined
  readVert (x:y:z:u:v:[]) = Vert (readVertex (x,y,z)) (read u) (read v)
  readVert _              = undefined
  readVertex (x,y,z) = Vertex3 (read x) (read y) (read z)
  ignorable ('/':'/':_) = False
  ignorable []          = False
  ignorable _           = True
                
initGL :: IO [TextureObject]
initGL = do
  tex <- loadGLTextures
  texture Texture2D $= Enabled
  clearColor $= Color4 0 0 0 0.5 -- Clear the background color to black
  clearDepth $= 1 -- enables clearing of the depth buffer
  depthFunc  $= Just Less -- type of depth test
  shadeModel $= Smooth -- enables smooth color shading
  matrixMode $= Projection
  hint PerspectiveCorrection $= Nicest
  ambient (Light 1) $= lightAmbient
  diffuse (Light 1) $= lightDiffuse
  position (Light 1) $= lightPosition
  light (Light 1) $= Enabled
  lighting $= Enabled
  loadIdentity  -- reset projection matrix
  Size width height <- get windowSize
  perspective 45 (fromIntegral width/fromIntegral height) 0.1 100 -- calculate the aspect ratio of the window
  matrixMode $= Modelview 0
  color (Color4 1 1 1 (0.5::GLfloat))
  blendFunc $= (SrcAlpha, One)

  flush -- finally, we tell opengl to do it.
  return tex

loadGLTextures :: IO [TextureObject]
loadGLTextures = do
  (Image (Size w h) pd) <- bitmapLoad "Data/mud.bmp"
  texNames <- (genObjectNames 3)
  -- create nearest filtered texture
  textureBinding Texture2D $= Just (texNames !! 0)
  textureFilter  Texture2D $= ((Nearest, Nothing), Nearest)
  texImage2D Nothing NoProxy 0 RGB' (TextureSize2D w h) 0 pd
  -- create linear filtered texture
  textureBinding Texture2D $= Just (texNames !! 1)
  textureFilter  Texture2D $= ((Linear', Nothing), Linear')
  texImage2D Nothing NoProxy 0 RGB' (TextureSize2D w h) 0 pd
  -- create mipmap filtered texture
  textureBinding Texture2D $= Just (texNames !! 2)
  textureFilter  Texture2D $= ((Linear', Just Nearest), Linear')
  texImage2D Nothing NoProxy 0 RGB' (TextureSize2D w h) 0 pd
  build2DMipmaps Texture2D RGB' w h pd
  return texNames

resizeScene :: Size -> IO ()
resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero
resizeScene s@(Size width height) = do
  viewport   $= (Position 0 0, s)
  matrixMode $= Projection
  loadIdentity
  perspective 45 (fromIntegral width/fromIntegral height) 0.1 100
  matrixMode $= Modelview 0
  flush

drawScene :: [TextureObject] -> Sector -> Global -> IO ()
drawScene texs sector globals = do
  clear [ColorBuffer, DepthBuffer] -- clear the screen and the depth bufer
  loadIdentity  -- reset view
  xtrans <- fmap negate (readIORef (xpos globals))
  ytrans <- fmap (\y -> -y-0.25) (readIORef (walkbias globals))
  ztrans <- fmap negate (readIORef (zpos globals))
  sceneroty <- fmap (\y -> 360 - y) (readIORef (yrot globals))
  --print sceneroty
  look <- readIORef (lookupdown globals)
  filt <- readIORef (filterSelector globals)
  rotate look (Vector3 1 0 0)
  rotate sceneroty (Vector3 0 1 0)
  
  translate (Vector3 xtrans ytrans ztrans)
  textureBinding Texture2D $= Just (texs!!filt)
  mapM_ (\t -> renderPrimitive Triangles $
    do normal (Normal3 0 0 (1::GLfloat))
       case t of Tri (Vert (Vertex3 x1 y1 z1) u1 v1) 
                     (Vert (Vertex3 x2 y2 z2) u2 v2) 
                     (Vert (Vertex3 x3 y3 z3) u3 v3) -> do texCoord (TexCoord2 u1 v1)
                                                           vertex (Vertex3 x1 y1 z1)
                                                           texCoord (TexCoord2 u2 v2)
                                                           vertex (Vertex3 x2 y2 z2)
                                                           texCoord (TexCoord2 u3 v3)
                                                           vertex (Vertex3 x3 y3 z3)) sector
  
  -- since this is double buffered, swap the buffers to display what was just
  -- drawn
  flush
  swapBuffers

updateIORef :: Show a => IO (IORef a) -> (a -> a) -> IO ()
updateIORef ioref f = do ref <- ioref
                         r <- readIORef ref
                         print r
                         writeIORef ref (f r)

keyPressed :: Global -> KeyboardMouseCallback
-- 27 is ESCAPE
keyPressed _ (Char '\27') Down _ _ = exitWith ExitSuccess
keyPressed g (Char 'B') Down x y = keyPressed g (Char 'b') Down x y
keyPressed _ (Char 'b') Down _ _  = do
  r <- get blend
  if r == Enabled
     then blend $= Disabled >> depthFunc $= (Just Less)
     else blend $= Enabled >> depthFunc $= Nothing
keyPressed g (Char 'f') Down _ _ = modifyIORef (filterSelector g) (\x -> x+1 `mod` 3)
keyPressed g (Char 'F') Down x y = keyPressed g (Char 'f') Down x y
keyPressed g (Char 'L') Down x y = keyPressed g (Char 'l') Down x y
keyPressed _ (Char 'l') Down _ _ = do
  l <- get lighting
  if l == Enabled
     then lighting $= Disabled
     else lighting $= Enabled  
keyPressed g (SpecialKey KeyRight) Down _ _ = modifyIORef (yrot g) (subtract 1.5)
keyPressed g (SpecialKey KeyLeft) Down _ _ = modifyIORef (yrot g) (+ 1.5)
keyPressed g (SpecialKey KeyUp) Down _ _ = do
  h <- readIORef (yrot g)
  modifyIORef (xpos g) (subtract ((sin (h * piover180))*0.05))
  modifyIORef (zpos g) (subtract ((cos (h * piover180))*0.05))
  modifyIORef (walkbiasangle g) (\w -> (w+10) `fmod` 360)
  wba <- readIORef (walkbiasangle g)
  modifyIORef (walkbias g) (\_ -> ((sin (wba * piover180))/20))
keyPressed g (SpecialKey KeyDown) Down _  _ = do
  h <- readIORef (yrot g)
  modifyIORef (xpos g) (+ (sin (h * piover180))*0.05)
  modifyIORef (zpos g) (+ (cos (h * piover180))*0.05)
  modifyIORef (walkbiasangle g) (\w -> (w-10) `fmod` 360)
  wba <- readIORef (walkbiasangle g)
  modifyIORef (walkbias g) (\_ -> ((sin (wba * piover180))/20))
keyPressed g (SpecialKey KeyPageUp) Down _ _ = do
  modifyIORef (zdepth g) (subtract 0.2)
  modifyIORef (lookupdown g) (subtract 0.2)
keyPressed g (SpecialKey KeyPageDown) Down _ _ = do
  modifyIORef (zdepth g) (+ 0.2)
  modifyIORef (lookupdown g) (+ 0.2)

keyPressed _ _           _    _ _ = return ()

fmod :: RealFrac a => a -> Int -> a
fmod x m = (fromIntegral ((floor x :: Int) `mod` m)) + 
           (x - (fromIntegral (floor x :: Int)))

main :: IO ()
main = do
     -- Initialize GLUT state - glut will take any command line arguments
     -- that pertain to it or X windows -- look at its documentation at
     -- http://reality.sgi.com/mjk/spec3/spec3.html
     sector <- setupWorld

     getArgsAndInitialize 
     -- select type of display mode:
     -- Double buffer
     -- RGBA color
     -- Alpha components supported
     -- Depth buffer
     initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer, 
                             WithAlphaComponent ]
     -- get an 800 x 600 window
     initialWindowSize $= Size 800 600
     -- window starts at upper left corner of the screen
     initialWindowPosition $= Position 0 0
     -- open a window
     createWindow "Jeff Molofee's GL Code Tutorial ... NeHe '99"
     -- register the function to do all our OpenGL drawing
     -- initialize our window.
     texs <- initGL
     global <- mkGlobal
     displayCallback $= (drawScene texs sector global)
     -- go fullscreen. This is as soon as possible.
     fullScreen
     -- even if there are no events, redraw our gl scene
     idleCallback $= Just (drawScene texs sector global)
     -- register the funciton called when our window is resized
     reshapeCallback $= Just resizeScene
     -- register the function called when the keyboard is pressed.
     keyboardMouseCallback $= Just (keyPressed global)
     -- start event processing engine
     mainLoop