SimpleGL.hs

{-# OPTIONS -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  FRP.Reactive.GLUT.SimpleGL
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Simplified GL/GLUT interface
-- 
-- With much help from Andy Gill and David Sankel.
----------------------------------------------------------------------

module FRP.Reactive.GLUT.SimpleGL (initGfx, glwrap, windowPoint) where


import Graphics.UI.GLUT


-- Not sure about this, seems to work?  (andy)
resizeScene :: Size -> IO ()
resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero
resizeScene s@(Size width height) = do
  -- putStrLn "resizeScene"
  viewport   $= (Position 0 0, s)
  matrixMode $= Projection
  loadIdentity
  perspective 75 (w2/h2) 0.001 100
  matrixMode $= Modelview 0
  flush
 where
   w2 = half width
   h2 = half height
   half z = realToFrac z / 2

-- Initialize GL graphics
initGfx :: String -> IO ()
initGfx title = do
  do getArgsAndInitialize

     initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer, WithAlphaComponent ] 
     initialWindowSize $= Size 800 600
     createWindow title

     get windowSize >>= resizeScene

     -- ReverseBlend, Modulate, Blend, LessEqual, Decal, or Replace?
     textureFunction          $= Modulate
     texture Texture2D        $= Enabled
     textureFilter  Texture2D $= ((Nearest, Nothing), Nearest)

     blend     $= Enabled
     blendFunc $= (SrcAlpha, OneMinusSrcAlpha)

     lineSmooth      $= Enabled
     hint LineSmooth $= Nicest
     shadeModel      $= Smooth -- enables smooth color shading

     clearColor $= Color4 0 0 0 0
     clearDepth $= 1 -- enables clearing of the depth buffer
     depthFunc  $= Just Less -- type of depth test

     polygonMode $= (Fill,Fill) -- or Fill,Line

     -- Enable the following if non-uniform scaling will occur
     normalize $= Enabled
     -- Enable the following if only uniform scaling will occur
     -- rescaleNormal $= Enabled

     --  lightModel undefined
     -- Set the light up at an infinite distance behind the camera
     lighting           $= Enabled
     position (Light 0) $= Vertex4 1 1 0 1 
     light    (Light 0) $= Enabled 

     position (Light 0) $= Vertex4 0.0 0.0 1.0 0.0
     ambient  (Light 0) $= Color4  0.0 0.0 0.0 1.0
     diffuse  (Light 0) $= Color4  1.0 1.0 1.0 1.0
     specular (Light 0) $= Color4  1.0 1.0 1.0 1.0

     -- Material properties
     materialSpecular  Front $= Color4 1.0 1.0 1.0 1.0
     materialEmission  Front $= Color4 0.0 0.0 0.0 1.0
     materialShininess Front $= 70.0
     -- "If colorMaterial is defined, the normal calls to change the
     -- material colors don't work and glColor must be used in its place."
     -- (camio).
     -- 
     -- colorMaterial $= Just (FrontAndBack,AmbientAndDiffuse)
     -- colorMaterial $= Just (FrontAndBack,Specular)

     reshapeCallback $= Just resizeScene

     -- loadIdentity


-- | Convert a window position to a logical X,Y.  Logical zero is at the
-- origin, and [size??].
-- 
-- TODO: this def is completely broken.  What do I even want?  Probably to
-- go backward through the viewing transform to the XY plane.
windowPoint :: Position -> IO (Double, Double)
windowPoint (Position x y) = do Size w h <- get windowSize
                                return (f w x, f h y)
 where
  -- Scale and translate coordinate.  Put zero at the center, and give one
  -- unit to 100 pixels.
  f _ z = realToFrac z
  -- f z maxZ = realToFrac (z - maxZ) / (100 * realToFrac maxZ)


-- | Wrap an OpenGL rendering action, to clear the frame-buffer before
-- swap buffers afterward.
glwrap :: IO () -> IO ()
glwrap act = do clear [ColorBuffer, DepthBuffer]
                -- putStrLn "glwrap"
                -- loadIdentity
                -- translate (Vector3 0 0 (-3 :: Float))
                act
                swapBuffers