content: -- This is an attempt to create a modern, consize OpenGL template in 
  -- haskell.  It's mainly meant for experimenting with OpenGL.
  --   
  -- This works well with OpenGL 4.4.0 NVIDIA 361.18
  -- Lenovo E431 (2014) laptop, running nVidia GeForce GT 740M/PCIe/SSE2
  
  module Main where
  
  import Graphics.Rendering.OpenGL as GL
  import Graphics.UI.GLFW as GLFW
  import Graphics.GLUtil (setUniform)
  import Graphics.UI.GLUT.Debugging
  import Control.Monad (forever)
  import System.Exit (exitSuccess)
  import Foreign.Marshal.Array (withArray)
  import Foreign.Ptr (plusPtr, nullPtr, Ptr)
  import Foreign.Storable (sizeOf)
  import NGL.LoadShaders
  data Descriptor = Descriptor VertexArrayObject ArrayIndex NumArrayIndices
  data Projection = Planar                
                  deriving Show 
  data Shape = Square    Point   Side
             deriving Show     
       
  type Drawable   = ([Vertex4 Float],[TexCoord2 Float])
  type UV         = [TexCoord2 Float] 
  type Point      = (Float, Float)
  type Points     = [Point]     
  type Side       = Float
  
  square :: Point -> Float -> [Point]
  square pos side = [p1, p2, p3,
                     p1, p3, p4]
      where          
          x = fst pos
          y = snd pos
          r = side/2 
          p1 = (x + r, y + r)
          p2 = (x - r, y + r)
          p3 = (x - r, y - r)
          p4 = (x + r, y - r)
  
  toPoints :: Shape -> [Point]
  toPoints (Square   pos side)     =  square pos side
  
  toUV :: Projection -> UV
  toUV Planar = projectPlanar ps
                    where ps = [(1.0, 1.0),( 0.0, 1.0),( 0.0, 0.0)
                               ,(1.0, 1.0),( 0.0, 0.0),( 1.0, 0.0)]::Points
                                                                     
  toDrawable :: Shape -> Drawable
  toDrawable x = (vs, uv)
             where
                 vs'   = toPoints x               
                 uv    = map toTexCoord2 vs'
                 vs    = map toVertex4 vs'
  
  toVertex4 :: Point -> Vertex4 Float
  toVertex4 (k, l) = Vertex4 k l 0 1
  
  toTexCoord2 :: (a, a) -> TexCoord2 a
  toTexCoord2 (k, l) = TexCoord2 k l
  
  projectPlanar :: [Point] -> UV
  projectPlanar = map $ uncurry TexCoord2                                                                   
  
  keyPressed :: GLFW.KeyCallback 
  keyPressed win GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdown win
  keyPressed _   _               _ _                     _ = return ()
                                                                    
  shutdown :: GLFW.WindowCloseCallback
  shutdown win = do
    GLFW.destroyWindow win
    GLFW.terminate
    _ <- exitSuccess
    return ()                                                                  
     
  resizeWindow :: GLFW.WindowSizeCallback
  resizeWindow win w h =
      do
        GL.viewport   $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
        GL.matrixMode $= GL.Projection
        GL.loadIdentity
        GL.ortho2D 0 (realToFrac w) (realToFrac h) 0   
  
  openWindow :: String -> (Int, Int) -> IO GLFW.Window
  openWindow title (sizex,sizey) = do
      GLFW.init
      GLFW.defaultWindowHints
      GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 4)
      GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 5)
      GLFW.windowHint (GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core)
      GLFW.windowHint (GLFW.WindowHint'Resizable False)
      Just win <- GLFW.createWindow sizex sizey title Nothing Nothing
      GLFW.makeContextCurrent (Just win)
      GLFW.setWindowSizeCallback win (Just resizeWindow)
      GLFW.setKeyCallback win (Just keyPressed)
      GLFW.setWindowCloseCallback win (Just shutdown)
      return win
  
  closeWindow :: GLFW.Window -> IO ()
  closeWindow win = do
      GLFW.destroyWindow win
      GLFW.terminate
  
  display :: Drawable -> IO ()
  display drawable = do
       inWindow <- openWindow "NGL is Not GLoss" (512,512)
       draw inWindow drawable
       closeWindow inWindow
                   
  draw :: GLFW.Window -> Drawable -> IO ()
  draw win xs = do
      descriptor <- initResources xs
      onDisplay win descriptor                 
      
  initResources :: (Drawable) -> IO Descriptor
  initResources (vs, uv) = do
      triangles <- genObjectName
      bindVertexArrayObject $= Just triangles
  
      --
      -- Declaring VBO: vertices
      --
      let vertices = vs
          numVertices = length vertices
  
      vertexBuffer <- genObjectName
      bindBuffer ArrayBuffer $= Just vertexBuffer
      withArray vs $ \ptr -> do
          let size = fromIntegral (numVertices * sizeOf (head vs))
          bufferData ArrayBuffer $= (size, ptr, StaticDraw)
  
      let firstIndex = 0
          vPosition = AttribLocation 0
      vertexAttribPointer vPosition $=
          (ToFloat, VertexArrayDescriptor 4 Float 0 (bufferOffset firstIndex))
      vertexAttribArray vPosition $= Enabled
      
      --
      -- Declaring VBO: UVs
      --
      let uv = toUV Planar
  
      textureBuffer <- genObjectName
      bindBuffer ArrayBuffer $= Just textureBuffer
      withArray uv $ \ptr -> do
          let size = fromIntegral (numVertices * sizeOf (head uv))
          bufferData ArrayBuffer $= (size, ptr, StaticDraw)
          
      let firstIndex = 0
          uvCoords = AttribLocation 1
      vertexAttribPointer uvCoords $=
          (ToFloat, VertexArrayDescriptor 2 Float 0 (bufferOffset firstIndex))
      vertexAttribArray uvCoords $= Enabled
    
      program <- loadShaders [
          ShaderInfo VertexShader (FileSource "Shaders/shader.vert"),
          ShaderInfo FragmentShader (FileSource "Shaders/shader.frag")]
      currentProgram $= Just program
  
  -- Set Uniforms
      
      let setUniform var val = do
                location <- get (uniformLocation program var)
                reportErrors
                uniform location $= val
                
      setUniform "fTime" (20.0 :: GLfloat)
  
      return $ Descriptor triangles firstIndex (fromIntegral numVertices)    
  
  onDisplay :: GLFW.Window -> Descriptor -> IO ()
  onDisplay win descriptor@(Descriptor triangles firstIndex numVertices) = do
    GL.clearColor $= Color4 0 0 0 1
    GL.clear [ColorBuffer]
    bindVertexArrayObject $= Just triangles
    drawArrays Triangles firstIndex numVertices
    GLFW.swapBuffers win
  
    forever $ do
       GLFW.pollEvents
       onDisplay win descriptor
                 
  bufferOffset :: Integral a => a -> Ptr b
  bufferOffset = plusPtr nullPtr . fromIntegral
  
  main :: IO ()
  main = do
       let drawable = toDrawable $ Square (-0.0, -0.0) 2.0
       display drawable
  