GL.hs

{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
module SimpleH.GL (
  module SimpleH.Reactive,module SimpleH,module SimpleH.GL.Base,
  
  -- * Creating windows & Handling events
  EventHandler,Position,Title,
  spawnWindow,
  Button(..),GLFW.KeyButtonState(..),
  Size(..),

  -- * Examining and modifying the window
  GettableStateVar,SettableStateVar,
    
  -- * Drawing the scene
  Scene,
  Widget(..),Transform(..),
  Shape(..),ShapeProp(..),
  Vertex(..),VertexProp(..),
  drawScene,
  
  -- ** Basic types
  Coord,
  
  -- * Utilities

  -- ** Basic colors
  white,black,grey,gray,
  red,green,blue,yellow,magenta,cyan,

  -- ** Vertices
  vert,cvert
  ) where

import SimpleH
import SimpleH.Reactive 
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL 
import Graphics.Rendering.OpenGL hiding (
  Color,Position,Vertex,Polygon,Texture,
  preservingMatrix,withMatrix)
import Control.Concurrent
import SimpleH.GL.Texture
import SimpleH.GL.Base

type EventHandler = Event Seconds Position -> Event Seconds (Button,GLFW.KeyButtonState) -> IO (Event Seconds (IO ()))
type Title = String

-- |Create an OpenGL window and sinks all events into the given handler. 
spawnWindow :: Title -> EventHandler -> IO ()
spawnWindow title sink = do
  -- This code was partially stolen from http://www.haskell.org/haskellwiki/GLFW
  sizes <- newChan
  
  GLFW.initialize
  -- open window
  GLFW.openWindow (Size 400 400) [GLFW.DisplayAlphaBits 8] GLFW.Window
  GLFW.windowTitle $= title
  
  -- enable 2D texturing
  texture Texture2D $= Enabled 
  generateMipmap Texture2D $= Enabled
  
  shadeModel $= Smooth
  -- enable antialiasing
  lineSmooth $= Enabled
  blend      $= Enabled
  blendFunc  $= (SrcAlpha, OneMinusSrcAlpha)
  lineWidth  $= 1.5
  -- set the color to clear background
  clearColor $= Color4 0 0 0 0

  -- 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)
    matrixMode $= Projection
    loadIdentity
    let w' = realToFrac w ; h' = realToFrac h
        w'' = max 1 (w'/h') ; h'' = max 1 (h'/w')
    ortho2D (-w'') w'' (-h'') h''

  -- 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)
  let _button = (_1%~fromK<$>_keyboard) + (_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' = realToFrac x ; y' = realToFrac y
              w' = realToFrac w ; h' = realToFrac h
              xc = w'/2 ; yc = h'/2 ; m = min w' h'/2
  ev <- sink (relative<$>Reactive (Size 1 1) _size<|*>_mousePos) _button
  -- 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 10ms polling period because it was both reactive
  -- enough for keyboard and mouse events and not too heavy on
  -- the CPU. 
  let period = ms 10
  for_ ((ev+(const<$>Reactive unit ev<|*>_size))^.._mapping _future._event)
    $ \(t,x) -> fix $ \poll -> do
    c <- GLFW.pollEvents >> currentTime 
    if t <= pure (c+period) then when (t > pure (c-period)) x
      else waitTill (c+period) >> poll

  GLFW.closeWindow
  GLFW.terminate

ms = (/1000)

clearScreen = GL.clear [GL.ColorBuffer,GL.DepthBuffer]

data Button = CharKey Char
            | SpecialKey GLFW.SpecialKey
            | MouseButton GLFW.MouseButton
            deriving (Eq,Show)

type Scene t = [Widget t]
data Widget t = Shape [ShapeProp] (Shape t)
               | SubScene [Transform t] (Scene t)
data Shape t = Polygon [Vertex t]
data Vertex t = Vertex [VertexProp t] !t !t !t
data VertexProp t = Color (V4 t)
                  | TexCoord (V2 t)
data ShapeProp = Texture Texture
data Transform t = Translate !t !t !t
                 | Rotate !t (V3 t)
                 | Zoom !t !t !t

type Coord = GLfloat
instance Semigroup Coord
instance Monoid Coord
instance Ring Coord
type Position = V2 Coord

instance Graphics (Widget Coord) where 
  draw (Shape ps s) = traverse_ draw ps >> draw s
  draw (SubScene trs s) = preservingMatrix $ (traverse_ draw 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
instance Graphics (Shape Coord) where
  draw (Polygon p) = renderPrimitive GL.Polygon $ traverse_ draw p
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 :: GL.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)

vert = Vertex []
cvert c = Vertex [c]

rgb r g b = V4 r g b 1
white = rgb 1 1 1
black = rgb 0 0 0
grey g = rgb g g g
gray = grey

red = rgb 1 0 0
green = rgb 0 1 0
blue = rgb 0 0 1
yellow = green+red
magenta = red+blue
cyan = green+blue