import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Data.IORef

data CurrentKey = KeyL | KeyR | KeyU | KeyD | KeyN deriving Show

type Pov = (Float,Float,Float,Float)

myMap :: [[Int]]
myMap = [[1,1,1,0,0,1,1],
         [1,0,0,0,0,1,1],
         [1,0,2,2,0,0,0],
         [1,0,2,2,0,1,0],
         [1,0,0,0,0,0,0],
         [1,1,0,3,3,3,1],
         [1,1,0,0,0,3,1]]

mapToDrawInfo :: [[Int]]->[(Int,Float,Float)]
mapToDrawInfo xs = rowsToDrawInfo $ zip xs [(0.0::Float)..]
 
rowsToDrawInfo :: [([Int],Float)] -> [(Int,Float,Float)]
rowsToDrawInfo (row:xs) = [(i,x,y)|(i,y)<-zip is [0.0 ..]]++(rowsToDrawInfo xs)
  where
    (is,x) = row
rowsToDrawInfo [] = []


main = do 
  (progname, _) <- getArgsAndInitialize

  initialDisplayMode $= [WithDepthBuffer,DoubleBuffered,RGBAMode]
  createWindow "Hello World"

  depthFunc $= Just Less
  matrixMode $= Projection
  loadIdentity
  let near = 1
      far = 40
      right = 1
      top = 1
  frustum (-right) right (-top) top near far
  matrixMode $= Modelview 0

  currentKey <- newIORef KeyN
  pov <- newIORef ((-3,-2.0,-6.0,0)::Pov)

  keyboardMouseCallback $= Just (keyboard currentKey) 

  tme <- get elapsedTime
  lasttime <- newIORef(tme)
  idleCallback $= Just (idle lasttime currentKey pov)  
    
  windowSize $= Size 800 500
  
  lighting $= Enabled
  position (Light 0) $= (Vertex4 0 0 (-3::GLfloat) 1)
  ambient (Light 0) $= Color4 1 1 1 1
  diffuse (Light 0) $= Color4 1 1 1 1
  specular (Light 0) $= Color4 1 1 1 1
  light (Light 0) $= Enabled

  displayCallback $= (display (mapToDrawInfo myMap) pov)
  
  mainLoop

keyboard :: IORef(CurrentKey)->Key -> KeyState -> Modifiers -> Position -> IO ()
keyboard p (SpecialKey KeyLeft) Down _ _ = writeIORef p KeyL  
keyboard p (SpecialKey KeyRight) Down _ _ = writeIORef p KeyR
keyboard p (SpecialKey KeyUp) Down _ _ = writeIORef p KeyU
keyboard p (SpecialKey KeyDown) Down _ _ = writeIORef p KeyD
keyboard p _ _ _ _ = do writeIORef p KeyN

updatePov :: CurrentKey->Pov->Pov
updatePov KeyL (x,y,z,a) = (x-0.1,y,z,a)
updatePov KeyR (x,y,z,a) = (x+0.1,y,z,a)
updatePov KeyU (x,y,z,a) = (x,y,z-0.1,a)
updatePov KeyD (x,y,z,a) = (x,y,z+0.1,a)
updatePov _ pov = pov


idle :: IORef(Int) -> IORef(CurrentKey) -> IORef(Pov)->IO()
idle lasttime currentKey povMem
  = do lTime <- readIORef lasttime
       currenttime <- get elapsedTime
       case (currenttime - lTime >= 16) of
         True -> do
           pov <- readIORef povMem
           key <- readIORef currentKey
           writeIORef povMem $ updatePov key pov
           writeIORef lasttime currenttime
           postRedisplay Nothing
           return ()
         _ -> return ()

display :: [(Int,Float,Float)]->IORef(Pov)->IO()
display mapData povMem = do
  clear [ColorBuffer,DepthBuffer]
  loadIdentity
  (x,y,z,_)<- readIORef povMem

  translate (Vector3 x (y) (z::GLfloat)) 
  drawMap mapData
  flush

  swapBuffers

drawMap :: [(Int,Float,Float)]->IO()
drawMap ((0,_,_):xs) = drawMap xs
drawMap ((i,x,y):xs) = do preservingMatrix $ do let rd = 1.0
                                                    gd = 0.0
                                                    bd = 0.6
                                                    rs = 0.5
                                                    gs = 0.5
                                                    bs = 0.0
                                                materialDiffuse Front $= Color4 rd gd bd 1.0
                                                materialAmbient Front $= Color4 0.0 0.7 0.8 0.2
                                                materialSpecular Front $= Color4 rs gs bs 1.0
                                                translate (Vector3 x 0 (y::GLfloat))
                                                cube 1
  
                          drawMap xs 
                 
drawMap [] = return ()

makeVertices ((x,y,z):[]) = do (vertex (Vertex3 x y z))
makeVertices ((x,y,z):xs) = do (vertex (Vertex3 (x::GLfloat) y z))
                               makeVertices xs

cube l = do renderPrimitive Quads (makeVertices corners)
  where 
   corners =
    [(l,0,l),(0,0,l),(0,l,l),(l,l,l)
    ,(l,l,l),(l,l,0),(l,0,0),(l,0,l)
    ,(0,0,0),(l,0,0),(l,0,l),(0,0,l)
    ,(l,l,0),(0,l,0),(0,0,0),(l,0,0)
    ,(0,l,l),(l,l,l),(l,l,0),(0,l,0)
    ,(0,l,l),(0,l,0),(0,0,0),(0,0,l)
    ]