Main.hs

   1 import qualified Data.ByteString as B
   2 import Graphics.Rendering.OpenGL
   3 import qualified Graphics.GL.Functions as GL
   4 import Graphics.UI.GLUT
   5 import qualified Linear.Projection as L
   6 import Linear.V3
   7 import Linear.Matrix
   8 import Linear.Quaternion
   9 import Foreign
  10 import Foreign.C.Types
  11 import Control.Monad
  12
  13 main :: IO ()
  14 main = do
  15   (_progName, _args) <- getArgsAndInitialize
  16
  17   initialDisplayMode $= [WithDepthBuffer, DoubleBuffered, Borderless]
  18   win <- createWindow "Hello world"
  19
  20   (program, triangles) <- setup
  21
  22   let projection = transpose $ L.perspective 0.785 1.33 0.001 100
  23       view = transpose $ L.lookAt (V3 0.0 0.0 (-5.0)) (V3 0.0 0.0 (-4.0)) (V3 0.0 1.0 0.0)
  24
  25   displayCallback $= do
  26     clear [ColorBuffer, DepthBuffer]
  27
  28     (UniformLocation projLoc) <- uniformLocation program "projection"
  29     with projection $ \ptr ->
  30       GL.glUniformMatrix4fv projLoc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
  31
  32     (UniformLocation viewLoc) <- uniformLocation program "view"
  33     with view $ \ptr ->
  34       GL.glUniformMatrix4fv viewLoc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
  35
  36     time <- fromIntegral <$> get elapsedTime
  37     let model = transpose $ m33_to_m44 $ fromQuaternion $ axisAngle (V3 0 1 0) (time * 0.001)
  38     (UniformLocation modelLoc) <- uniformLocation program "model"
  39     with model $ \ptr ->
  40       GL.glUniformMatrix4fv modelLoc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
  41
  42     bindVertexArrayObject $= Just triangles
  43     drawArrays Triangles 0 12
  44
  45     get errors >>= \es -> unless (null es) (fail $ show es)
  46     swapBuffers
  47   let draw = addTimerCallback 16 (postRedisplay (Just win) >> draw) in draw
  48
  49   mainLoop
  50
  51 setup :: IO (Program, VertexArrayObject)
  52 setup = do
  53   depthFunc $= Just Lequal
  54
  55   triangles <- genObjectName
  56   bindVertexArrayObject $= Just triangles
  57   let vertices = [
  58         Vertex3 (-1) (-1) (-1),
  59         Vertex3 ( 1) (-1) (-1),
  60         Vertex3 ( 0) ( 1) ( 0),
  61
  62         Vertex3 (-1) (-1) ( 1),
  63         Vertex3 ( 1) (-1) ( 1),
  64         Vertex3 ( 0) ( 1) ( 0),
  65
  66         Vertex3 (-1) (-1) (-1),
  67         Vertex3 (-1) (-1) ( 1),
  68         Vertex3 ( 0) ( 1) ( 0),
  69
  70         Vertex3 ( 1) (-1) (-1),
  71         Vertex3 ( 1) (-1) ( 1),
  72         Vertex3 ( 0) ( 1) ( 0)] :: [Vertex3 Float]
  73       verticesSize = fromIntegral $ length vertices * sizeOf (head vertices)
  74
  75       colors = take 12 $ cycle [
  76         Vertex4 0 1 0 1,
  77         Vertex4 1 0 0 1,
  78         Vertex4 0 0 1 1 ] :: [Vertex4 Float]
  79       colorsSize = fromIntegral $ length colors * sizeOf (head colors)
  80
  81   buffer <- genObjectName
  82   bindBuffer ArrayBuffer $= Just buffer
  83
  84   bufferData ArrayBuffer $= (verticesSize + colorsSize, nullPtr, StaticDraw)
  85
  86   withArray vertices $ \ptr ->
  87     bufferSubData ArrayBuffer WriteToBuffer 0 verticesSize ptr
  88
  89   withArray colors $ \ptr ->
  90     bufferSubData ArrayBuffer WriteToBuffer verticesSize colorsSize ptr
  91
  92   program <- createProgram
  93   loadShader program VertexShader "vertex.glsl"
  94   loadShader program FragmentShader "fragment.glsl"
  95
  96   linkProgram program
  97
  98   status <- linkStatus program
  99   unless status $
 100     get (programInfoLog program) >>= fail
 101
 102   currentProgram $= Just program
 103
 104   verticesLoc <- get (attribLocation program "vPosition")
 105   vertexAttribPointer verticesLoc $=
 106     (ToFloat, VertexArrayDescriptor 3 Float 0 (ptrOffset 0))
 107   vertexAttribArray verticesLoc $= Enabled
 108
 109   colorsLoc <- get (attribLocation program "vColor")
 110   vertexAttribPointer colorsLoc $=
 111     (ToFloat, VertexArrayDescriptor 4 Float 0 (ptrOffset verticesSize))
 112   vertexAttribArray colorsLoc $= Enabled
 113
 114   validateProgram program
 115   status' <- validateStatus program
 116   unless status' $
 117     get (programInfoLog program) >>= fail
 118
 119   return (program, triangles)
 120   where ptrOffset = plusPtr nullPtr . fromIntegral
 121
 122 loadShader :: Program -> ShaderType -> String -> IO ()
 123 loadShader program shaderType file = do
 124   shader <- createShader shaderType
 125   src <- B.readFile file
 126   shaderSourceBS shader $= src
 127   compileShader shader
 128   status <- compileStatus shader
 129   unless status $
 130     get (shaderInfoLog shader) >>= fail . ("shader failed " ++)
 131   attachShader program shader
 132
 133 perspective' :: Float -> Float -> Float -> Float -> IO (GLmatrix Float)
 134 perspective' fov aspect zNear zFar =
 135   let f = 1.0 / tan(fov)
 136   in newMatrix RowMajor
 137                 [f / aspect, 0, 0, 0,
 138                  0, f, 0, 0,
 139                  0, 0, (zNear + zFar) / (zNear - zFar), -1,
 140                  0, 0, (2 * zFar * zNear) / (zNear - zFar), 0]