{-# LANGUAGE FlexibleInstances, ViewPatterns, ImplicitParams, RankNTypes #-}
module IO.Graphics (
  module Data.Reactive,module Definitive,module Data.Vertex,module Data.Scene,module Data.Input.Button,
  
  -- * Creating windows & Handling events
  EventHandler,Coord,Position,Title,Size(..),
  spawnWindow,
  
  -- * Examining and modifying the window
  GettableStateVar,SettableStateVar,
    
  -- * Drawing the scene
  drawScene,
  ) where

import Definitive
import Data.Reactive 
import Data.Scene
import Data.Input.Button
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL.GL.Texturing.Application as GL (texture)
import qualified Graphics.Rendering.OpenGL.GL.CoordTrans as GL (Position(..))
import qualified Graphics.Rendering.OpenGL.GL.BeginEnd as GL (PrimitiveMode(..))
import qualified Graphics.Rendering.OpenGL.GL.StateVar as GL (get)
import Graphics.Rendering.OpenGL.Raw.Core31.Types (GLdouble,GLfloat)
import Graphics.Rendering.OpenGL.GL.StateVar (($=),GettableStateVar,SettableStateVar)
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget2D(Texture2D))
import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability(Enabled))
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (generateMipmap)
import Graphics.Rendering.OpenGL.GL.Colors (shadeModel,ShadingModel(Smooth))
import Graphics.Rendering.OpenGL.GL.LineSegments (lineSmooth)
import Graphics.Rendering.OpenGL.GL.PerFragment (blend,blendFunc,BlendingFactor(..),depthFunc,ComparisonFunction(..))
import Graphics.Rendering.OpenGL.GL.LineSegments (lineWidth)
import Graphics.Rendering.OpenGL.GL.Framebuffer (clearColor,clear,ClearBuffer(..))
import Graphics.Rendering.OpenGL.GL.VertexSpec (Color4(..),TexCoord2(..),texCoord,vertex,color)
import Graphics.Rendering.OpenGL.GL.CoordTrans (Size(..),viewport,matrix,matrixMode,MatrixMode(Modelview,Projection),GLmatrix,loadIdentity,translate,rotate,scale)
import Graphics.Rendering.OpenGL.GLU.Matrix (perspective)
import Graphics.Rendering.OpenGL.GL.Tensor (Vector3(..),Vertex3(..))
import Graphics.Rendering.OpenGL.GL.BeginEnd (renderPrimitive)
import Control.Concurrent
import Data.Vertex

type Coord = GLfloat
type Position = V2 Coord

instance Semigroup GLdouble
instance Monoid GLdouble
instance Negative GLdouble
instance Disjonctive GLdouble
instance Semiring GLdouble
instance Ring GLdouble

instance Semigroup Coord
instance Monoid Coord
instance Negative Coord
instance Disjonctive Coord
instance Semiring Coord
instance Ring Coord

-- |A function from the a window's inputs to a frame event
type EventHandler = ( ?mousePosition :: Event Seconds Position
                    , ?buttonChanges :: Event Seconds (Button,ButtonState) ) => IO (Event Seconds (IO ()))
type Title = String

-- |Create an OpenGL window and sinks all events into the given handler. 
spawnWindow :: ( ?birthTime :: Seconds ) => Title -> EventHandler -> IO ()
spawnWindow title sink = between GLFW.initialize GLFW.terminate $ between openWindow GLFW.closeWindow $ do
  -- This code was partially stolen from http://www.haskell.org/haskellwiki/GLFW
  sizes <- newChan
  refreshes <- newChan
  
  -- open window
  GLFW.windowTitle $= title

  -- enable 2D texturing
  GL.texture Texture2D $= Enabled 
  generateMipmap Texture2D $= Enabled
  
  shadeModel $= Smooth
  -- enable antialiasing
  lineSmooth $= Enabled
  blend      $= Enabled
  blendFunc  $= (SrcAlpha, OneMinusSrcAlpha)
  lineWidth  $= 1.5
  -- The clear color is black
  clearColor $= Color4 0 0 0 0
  -- enable the depth buffer for correct 3D rendering
  depthFunc $= Just Less

  -- set 2D orthogonal view inside windowSizeCallback because
  -- any change to the Window size should result in different
  -- OpenGL Viewport.
  GLFW.windowSizeCallback $= \ size@(Size w h) -> do
    writeChan sizes size
    viewport $= (GL.Position 0 0, size)
    between (matrixMode $= Projection) (matrixMode $= Modelview 0) $ do
      loadIdentity
      let aov = 45 -- the angle of view
          ratio = fromIntegral w/fromIntegral h
      perspective aov ratio 0.1 100
      translate (Vector3 0 (0::GLdouble) (-max (1/ratio) 1/tan (aov*pi/360)))

  GLFW.windowRefreshCallback $= writeChan refreshes ()
    
  -- Now we define our own little stuff
  -- It doesn't seem very logical to poll events when swapping buffers. 
  GLFW.disableSpecial GLFW.AutoPollEvent
  let callbackE c f = do
        ch <- newChan
        c $= f (writeChan ch)
        event (readChan ch)
  _keyboard <- callbackE GLFW.keyCallback curry
  _mousePos <- callbackE GLFW.mousePosCallback (promap (\(GL.Position x y) -> V2 x y))
  _mouseButton <- callbackE GLFW.mouseButtonCallback curry
  _size <- event (readChan sizes)
  t'refresh <- event (readChan refreshes)
  let _button = (l'1%~fromK<$>_keyboard) + (l'1%~MouseButton<$>_mouseButton)
      fromK (GLFW.CharKey c) = CharKey c
      fromK (GLFW.SpecialKey k) = SpecialKey k
      relative (Size w h) (V2 x y) = V2 ((x'-xc)/m) ((yc-y')/m)
        where [x',y',w',h'] = realToFrac<$>[x,y,w,h]
              xc = w'/2 ; yc = h'/2 ; m = min w' h'/2
  
  ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos
            ?buttonChanges = _button
        in sink

  -- GLFW doesn't handle multithreading nicely, so we have to
  -- manually interleave polling events and rendering within
  -- the main thread. And since waiting for events may block
  -- while the rendering might occur, we have to poll regularly.
  -- I chose a 15ms polling period because it was both reactive
  -- enough for keyboard and mouse events and not too heavy on
  -- the CPU. 
  let period = ms 15
      poll = GLFW.pollEvents <$ atTimes [?birthTime,?birthTime+period..]
  try unit $ realize $ realtime (ev + (const<$>Reactive unit ev<|*>(void _size+t'refresh))) + poll
  where openWindow = GLFW.openWindow (Size 400 400) [GLFW.DisplayDepthBits 16,GLFW.DisplayAlphaBits 8] GLFW.Window

clearScreen = clear [ColorBuffer,DepthBuffer]

instance Graphics (Widget Coord) where 
  draw (Shape ps s) = traverse_ draw ps >> draw s
  draw (SubScene trs s) = preservingMatrix $ (traverse_ draw (reverse trs) >> drawScene s)
    where draw (Translate dx dy dz) = translate (Vector3 dx dy dz)
          draw (Rotate a (V3 ax ay az)) = rotate a (Vector3 ax ay az)
          draw (Zoom zx zy zz) = scale zx zy zz
  draw (Cached c) = c
instance Graphics (Shape Coord) where
  draw (Polygon p) = renderPrimitive GL.Polygon $ traverse_ draw p
  draw (Quads sqs) = renderPrimitive GL.Quads $ traverse_ draw (Compose sqs)
  draw (Triangles trs) = renderPrimitive GL.Triangles $ traverse_ draw (Compose trs)
  draw (TriangleStrip s) = renderPrimitive GL.TriangleStrip $ traverse_ draw s
instance Graphics (Vertex Coord) where
  draw (Vertex ps x y z) = traverse_ draw ps >> vertex (Vertex3 x y z)
instance Graphics (VertexProp Coord) where
  draw (Color (V4 r g b a)) = color (Color4 r g b a)
  draw (TexCoord (V2 x y)) = texCoord (TexCoord2 x y)
instance Graphics ShapeProp where
  draw (Texture t) = draw t

withMatrix f = GL.get (matrix Nothing) >>= f
preservingMatrix ma = withMatrix $ \old ->
  ma <* (matrix Nothing $= (old :: GLmatrix Coord))

drawScene :: Scene Coord -> IO ()
drawScene = between clearScreen GLFW.swapBuffers . traverse_ draw

instance Functor Vector3 where
  map f (Vector3 x y z) = Vector3 (f x) (f y) (f z)
instance Unit Vector3 where pure = join (join Vector3)
instance Applicative Vector3 where
  Vector3 fx fy fz <*> Vector3 x y z = Vector3 (fx x) (fy y) (fz z)

instance Functor Vertex3 where
  map f (Vertex3 x y z) = Vertex3 (f x) (f y) (f z)
instance Unit Vertex3 where pure = join (join Vertex3)
instance Applicative Vertex3 where
  Vertex3 fx fy fz <*> Vertex3 x y z = Vertex3 (fx x) (fy y) (fz z)
instance Traversable Vertex3 where
  sequence (Vertex3 a b c) = liftA3 Vertex3 a b c