module Main where

--------------------------------------------------------------------------------
import Control.Monad.State
import Control.Wire hiding (unless)

import Data.Array.IO
import Data.Array.Storable
import qualified Data.ByteString.Char8 as BS
import Data.List
import Data.Word

import FRP.Netwire.Input
import FRP.Netwire.Input.GLFW

import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL

import Foreign.Storable
import Foreign.Ptr

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

--------------------------------------------------------------------------------
--
-- Boilerplate

data Shape = Shape GL.NumArrayIndices GL.BufferObject GL.BufferObject

mkCircle :: IO (Shape)
mkCircle = let
  slices = 50
  vptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: GL.Vertex2 Float))
  iptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: Int))
  winding = [0,(2*pi/(fromIntegral slices))..] :: [Float]
  in do
    vbuf <- GL.genObjectName
    GL.bindBuffer GL.ArrayBuffer GL.$= (Just vbuf)
    let vl = (GL.Vertex2 0 0) : (zipWith GL.Vertex2 (map cos winding) (map sin winding))
    verts <- newListArray (0, slices + 1) vl
    withStorableArray verts
      (\ptr -> GL.bufferData GL.ArrayBuffer GL.$= (vptrsize, ptr, GL.StaticDraw))

    ibuf <- GL.genObjectName
    GL.bindBuffer GL.ElementArrayBuffer GL.$= (Just ibuf)
    idxs <- newListArray (0, slices + 1) ([0,1..] :: [Word16])
    withStorableArray idxs
      (\ptr -> GL.bufferData GL.ElementArrayBuffer GL.$= (iptrsize, ptr, GL.StaticDraw))

    return $ Shape (toEnum $ slices + 2) vbuf ibuf

vertShader :: BS.ByteString
vertShader = BS.pack $ intercalate ['\n'] [
  "attribute vec2 position;",
  "uniform vec2 offset;",
  "void main() {",
  "  gl_Position = vec4(offset + 0.1*position, 1.0, 1.0);",
  "}"]

fragShader :: BS.ByteString
fragShader = BS.pack $ intercalate ['\n'] [
  "uniform vec3 color;",
  "void main() {",
  "  gl_FragColor = vec4(color, 1.0);",
  "}"]

compileShader :: GL.ShaderType -> BS.ByteString -> IO (GL.Shader)
compileShader shdrTy src = do
  shdr <- GL.createShader shdrTy
  GL.shaderSourceBS shdr GL.$= src
  GL.compileShader shdr
  shaderLog <- GL.get $ GL.shaderInfoLog shdr
  unless (shaderLog == []) $ putStrLn shaderLog
  return shdr

mkRenderFunc :: IO (Shape -> GL.Vertex2 Float -> GL.Color3 Float -> IO ())
mkRenderFunc = do
  -- Compile shaders
  vshdr <- compileShader GL.VertexShader vertShader
  fshdr <- compileShader GL.FragmentShader fragShader

  -- Create program
  prg <- GL.createProgram
  mapM_ (GL.attachShader prg) [vshdr, fshdr]
  GL.linkProgram prg

  -- Find variable locations
  colorLoc <- GL.get $ GL.uniformLocation prg "color"
  offsetLoc <- GL.get $ GL.uniformLocation prg "offset"
  positionLoc <- GL.get $ GL.attribLocation prg "position"

  GL.currentProgram GL.$= Just prg

  -- Define function
  return $ \(Shape numIdxs vbo ibo) pos color -> do

    -- Enable buffers
    GL.vertexAttribArray positionLoc GL.$= GL.Enabled

    -- Set uniforms
    GL.uniform colorLoc GL.$= ((fmap realToFrac color) :: GL.Color3 GL.GLfloat)
    GL.uniform offsetLoc GL.$= ((fmap realToFrac pos) :: GL.Vertex2 GL.GLfloat)

    -- Bind buffers
    GL.bindBuffer GL.ArrayBuffer GL.$= Just vbo
    GL.vertexAttribPointer positionLoc GL.$=
      (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 (nullPtr :: Ptr Float))

    GL.bindBuffer GL.ElementArrayBuffer GL.$= Just ibo

    -- Render
    GL.drawElements GL.TriangleFan numIdxs GL.UnsignedShort nullPtr

    -- Disable buffers
    GL.vertexAttribArray positionLoc GL.$= GL.Disabled    

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

-- Some type synonyms to keep our code clean
type RenderFn = GL.Vertex2 Float -> GL.Color3 Float -> IO ()
type GameMonad = GLFWInputT IO
type GameSession = Session IO (Timed Float ())

-- This wire produces the position of the circle. It simply follows the mouse cursor
-- but negates the y-value. The origin of the mouse coordinates are in the top left
-- corner of the screen with the y-axis pointing down while the y-axis for rendering
-- points up.
posWire :: Wire s e GameMonad a (GL.Vertex2 Float)
posWire = mouseCursor >>> (second $ arr negate) >>> (arr $ uncurry GL.Vertex2)

-- This wire produces color for the circle. If the R, G, or B keys are pressed,
-- then the circle will turn red, green, or blue, respectively. Otherwise,
-- the red and green channels of the circle pulsate
colorWire :: (HasTime t s, Monoid e) => Wire s e GameMonad a (GL.Color3 Float)
colorWire =
  -- Key debounced means that it will only flash blue for one frame
  (keyDebounced GLFW.Key'B >>> (pure $ GL.Color3 0 0 1)) <|>

  -- Key pressed means that it will remain this color
  (keyPressed GLFW.Key'R >>> (pure $ GL.Color3 1 0 0)) <|>
  (keyPressed GLFW.Key'G >>> (pure $ GL.Color3 0 1 0)) <|>

  -- Otherwise, pulsate based on the amount of time passed
  (timeF >>> (arr (cos &&& sin)) >>> (arr $ \(x, y) -> GL.Color3 x y 1))

-- This wire takes a vertex position and color and renders according to the
-- passed in renderFn. In reality, this wire doesn't need to be a wire, and
-- could be a monad to render, but this way we can render what we need without
-- having to go through the plumbing of our main game loop
renderWire :: RenderFn -> Wire s e GameMonad (GL.Vertex2 Float, GL.Color3 Float) ()
renderWire rfn = mkGen_ $ \(pos, color) -> lift $ rfn pos color >> (return $ Right ())

-- Wire that behaves like the identity wire until Q is pressed, then inhibits
-- forever. We can compose our main gameWire with this wire to quit the program
-- when q is pressed
quitWire :: Monoid e => Wire s e GameMonad a a
quitWire = (mkId &&& eventWire) >>> (rSwitch mkId)
  where
    eventWire :: Monoid e => Wire s e GameMonad a (Event (Wire s e m a a))
    eventWire = (keyPressed GLFW.Key'Q >>> pure mkEmpty >>> now) <|> never

-- This is our main game wire, it feeds the position and color into the rendering loop
-- and finally quits if q is pressed.
gameWire :: (HasTime t s, Monoid e) => RenderFn -> Wire s e GameMonad a ()
gameWire rfn = posWire &&& colorWire >>> (renderWire rfn) >>> quitWire

run :: GLFW.Window -> GLFWInputControl -> IO ()
run win ictl = do
  -- initialize the input
  ipt <- getInput ictl

  -- load vertex arrays and whatnot for the circle
  circle <- mkCircle

  -- load the render function for getting rendering ready
  renderFn <- mkRenderFunc

  -- run the game loop
  runGame ipt (countSession_ (0.02 :: Double)) (gameWire $ renderFn circle)

  where

    -- The game loop takes the current input state, the time session and
    -- our main game wire, and simply steps the wire until it inhibits.
    runGame ipt sess w = do

      -- Before rendering clear the framebuffer
      GL.clearColor GL.$= GL.Color4 0.0 0.0 0.0 1
      GL.clear [GL.ColorBuffer]

      -- Poll the current input
      ipt' <- pollGLFW ipt ictl

      -- Figure out our next timestep
      (timeState, sess') <- stepSession sess

      -- Since the GameMonad is a 'StateT GLFWInputState m', in order to
      -- step the wires, we have to extract the value from our wire. That means
      -- that when we runStateT, we will get the results of our wire and a new
      -- state (for example if the wire debounced any keys). This is what we pass
      -- back to GLFW.
      --  renderPrg :: IO ((Either e (), Wire s e GameMonad a ()), GLFWInputState)
      let renderPrg = runGLFWInputT (stepWire w timeState (Right undefined)) ipt'

      -- Now run the actual IO program to extract the values from it.
      ((result, w'), ipt'') <- renderPrg

      -- End of frame cleanup
      GL.flush
      GLFW.swapBuffers win

      -- Our quit condition is if the OS asked us to quit, or the wire inhibits
      -- (i.e. someone hit the Q key)
      case result of
        Left () -> return ()
        Right () -> do
          q <- GLFW.windowShouldClose win
          unless q $ runGame ipt'' sess' w'

main :: IO ()
main = do
  -- Setup GLFW
  _ <- GLFW.init
  (Just m) <- GLFW.createWindow 400 400 "Netwire Input Demo" Nothing Nothing
  GLFW.makeContextCurrent (Just m)

  -- Hack for retina displays
  (szx, szy) <- GLFW.getFramebufferSize m
  GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral szx) (fromIntegral szy))

  -- Run the scene
  mkInputControl m >>= run m