module Waterfall.Graphics where

import           Control.Monad             (forever)
import qualified Data.ByteString.Char8     as BS
import           Foreign.Marshal.Array     (withArray)
import           Foreign.Ptr               (Ptr, nullPtr, plusPtr)
import           Foreign.Storable          (sizeOf)
import qualified Graphics.GLUtil           as GLU
import           Graphics.Rendering.OpenGL as GL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW          as GLFW
import           System.Exit               (exitSuccess)
import           Waterfall.Prelude

data Descriptor = Descriptor GL.VertexArrayObject GL.ArrayIndex GL.NumArrayIndices
data Shape = Square    (Float, Float)   Float
           deriving Show

square :: (Float, Float) -> Float -> [(Float, Float)]
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)

vertexShader :: BS.ByteString
vertexShader = BS.pack $ unlines
  ["#version 410"
  , ""
  , "in vec2 position;"
  , ""
  , "void main()"
  , "{"
  , "    gl_Position = vec4(position, 0.0, 1.0);"
  , "}"]

fragmentShader :: BS.ByteString
fragmentShader = BS.pack $ unlines
  [ "#version 410"
  , ""
  , "out vec4 frag_color;"
  , ""
  , "void main()"
  , "{"
  , ""
  , "    frag_color = vec4(0.2, 0.8, 0.6, 1.0);"
  , "}" ]

toPoints :: Shape -> [(Float, Float)]
toPoints (Square pos side)     =  square pos side

toVertex4 :: (Float, Float) -> GL.Vertex2 Float
toVertex4 (k,l) = GL.Vertex2 k l

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 _ 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.windowHint $ GLFW.WindowHint'RefreshRate 100
    GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 4
    GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 1
    GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True
    GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
    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 :: [GL.Vertex2 Float] -> IO ()
display xs = do
     inWindow <- openWindow "NGL is Not GLoss" (512,512)
     descriptor <- initResources xs
     onDisplay inWindow descriptor
     closeWindow inWindow

onDisplay :: GLFW.Window -> Descriptor -> IO ()
onDisplay win descriptor@(Descriptor triangles firstIndex numVertices) = do
  GL.clearColor $= GL.Color4 0 0 0 1
  GL.clear [GL.ColorBuffer]
  GL.bindVertexArrayObject $= Just triangles
  GL.drawArrays GL.Triangles firstIndex numVertices
  GLFW.swapBuffers win

  forever $ do
     GLFW.pollEvents
     onDisplay win descriptor

initResources :: [GL.Vertex2 Float] -> IO Descriptor
initResources vs = do
    triangles <- GL.genObjectName
    GL.bindVertexArrayObject $= Just triangles

    let vertices = vs
        numVertices = length vertices

    vertexBuffer <- GL.genObjectName
    GL.bindBuffer GL.ArrayBuffer $= Just vertexBuffer
    withArray vs $ \ptr -> do
        let size = fromIntegral (numVertices * sizeOf (head vs))
        GL.bufferData GL.ArrayBuffer $= (size, ptr, GL.StaticDraw)

    let firstIndex = 0
        vPosition = GL.AttribLocation 0
    GL.vertexAttribPointer vPosition $=
        (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 (bufferOffset firstIndex))
    GL.vertexAttribArray vPosition $= GL.Enabled

    -- Shaders
    vs <- GLU.loadShaderBS "vertex" GL.VertexShader vertexShader
    fs <- GLU.loadShaderBS "fragment" GL.FragmentShader fragmentShader
    p <- GLU.linkShaderProgram [vs,fs]
    GL.currentProgram $= Just p

    return $ Descriptor triangles firstIndex (fromIntegral numVertices)

bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral

render :: IO ()
render = do
     let drawable = map toVertex4 $ toPoints $ Square (-0.0, -0.0) 1.0
     display drawable
