minitypeset-opengl-0.1.0.0: example/GL.hs

-- | Initialize an OpenGL window using the GLFW-b library

module GL where

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

import Data.Char hiding ( Space )

import Control.Monad
import Control.Concurrent
import Data.IORef

import System.Exit
import System.IO.Unsafe as Unsafe

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

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

theWindowSize :: IORef (Int,Int)
theWindowSize = Unsafe.unsafePerformIO $ newIORef $ error "window size not set"

setWindowCoordSystem :: IO ()
setWindowCoordSystem = do
  matrixMode $=! Projection
  loadIdentity
  (w,h) <- readIORef theWindowSize
  GL.ortho 0 (fromIntegral w) (fromIntegral h) 0 (-1) (1::Double)
  matrixMode $=! Modelview 0
  loadIdentity

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

myErrorCallback :: GLFW.Error -> String -> IO ()
myErrorCallback err msg = do
  putStrLn $ msg ++ "(" ++ show err ++ ")"
  myExit

myKeyCallback :: Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()
myKeyCallback _ key nrepeat keyState modif = 
  case key of
    Key'Escape -> myExit
    _          -> return ()

myCharCallback :: Window -> Char -> IO ()
myCharCallback _ char = do
  return ()

myWinCloseCallback :: Window -> IO ()
myWinCloseCallback window = myExit

myFrBufSizeCallback :: Window -> Int -> Int -> IO ()
myFrBufSizeCallback window xsiz ysiz = do
  writeIORef theWindowSize (xsiz,ysiz)
  putStrLn $ "framebuffer resized to " ++ show (xsiz,ysiz)

myRefreshCallback :: Window -> IO ()
myRefreshCallback window = do
  return ()

myExit :: IO ()
myExit = do
  -- terminate         
  exitWith ExitSuccess

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

{-
frac :: Double -> Double 
frac x   = x - fromIntegral (floor x :: Int)

fmod :: Double -> Double -> Double
fmod x s = frac (x/s) * s
-}

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

renderLoop :: (Window -> Double -> IO ()) -> Window -> IO ()
renderLoop display window = loop  where
  loop = do
    Just time <- getTime 
    -- print time
    display window time
    swapBuffers window
    threadDelay 50
    loop

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

initGL :: IO precalc -> (precalc -> Window -> Double -> IO ()) -> IO ()
initGL userPrecalc userDisplay = do

  setErrorCallback (Just myErrorCallback)
  GLFW.init

  Just window <- createWindow 800 500 "window title" Nothing Nothing

  (xsiz,ysiz) <- getFramebufferSize window
  putStrLn $ "initial framebuffer size = " ++ show (xsiz,ysiz)
  writeIORef theWindowSize (xsiz,ysiz)

  major <- getWindowContextVersionMajor    window
  minor <- getWindowContextVersionMinor    window
  rev   <- getWindowContextVersionRevision window
  putStrLn $ "OpenGL context version = " ++ show major ++ "." ++ show minor ++ "." ++ show rev

  setWindowCloseCallback     window (Just myWinCloseCallback )
  setKeyCallback             window (Just myKeyCallback      )
  setCharCallback            window (Just myCharCallback     )
  setFramebufferSizeCallback window (Just myFrBufSizeCallback)
  setWindowRefreshCallback   window (Just myRefreshCallback  )  

  forkOS $ do 
    makeContextCurrent (Just window) 
    swapInterval 1                   
    precalc <- userPrecalc
    renderLoop (userDisplay precalc) window

  forever waitEvents

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