--- /dev/null
+import qualified Data.ByteString as B
+import Graphics.Rendering.OpenGL
+import qualified Graphics.GL.Functions as GL
+import Graphics.UI.GLUT
+import qualified Linear.Projection as L
+import Linear.V3
+import Linear.Matrix
+import Linear.Quaternion
+import Foreign
+import Foreign.C.Types
+import Control.Monad
+
+main :: IO ()
+main = do
+ (_progName, _args) <- getArgsAndInitialize
+
+ initialDisplayMode $= [WithDepthBuffer, DoubleBuffered, Borderless]
+ win <- createWindow "Hello world"
+
+ (program, triangles) <- setup
+
+ let projection = transpose $ L.perspective 0.785 1.33 0.001 100
+ 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)
+
+ displayCallback $= do
+ clear [ColorBuffer, DepthBuffer]
+
+ (UniformLocation projLoc) <- uniformLocation program "projection"
+ with projection $ \ptr ->
+ GL.glUniformMatrix4fv projLoc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+
+ (UniformLocation viewLoc) <- uniformLocation program "view"
+ with view $ \ptr ->
+ GL.glUniformMatrix4fv viewLoc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+
+ time <- fromIntegral <$> get elapsedTime
+ let model = transpose $ m33_to_m44 $ fromQuaternion $ axisAngle (V3 0 1 0) (time * 0.001)
+ (UniformLocation modelLoc) <- uniformLocation program "model"
+ with model $ \ptr ->
+ GL.glUniformMatrix4fv modelLoc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+
+ bindVertexArrayObject $= Just triangles
+ drawArrays Triangles 0 12
+
+ get errors >>= \es -> unless (null es) (fail $ show es)
+ swapBuffers
+ let draw = addTimerCallback 16 (postRedisplay (Just win) >> draw) in draw
+
+ mainLoop
+
+setup :: IO (Program, VertexArrayObject)
+setup = do
+ depthFunc $= Just Lequal
+
+ triangles <- genObjectName
+ bindVertexArrayObject $= Just triangles
+ let vertices = [
+ Vertex3 (-1) (-1) (-1),
+ Vertex3 ( 1) (-1) (-1),
+ Vertex3 ( 0) ( 1) ( 0),
+
+ Vertex3 (-1) (-1) ( 1),
+ Vertex3 ( 1) (-1) ( 1),
+ Vertex3 ( 0) ( 1) ( 0),
+
+ Vertex3 (-1) (-1) (-1),
+ Vertex3 (-1) (-1) ( 1),
+ Vertex3 ( 0) ( 1) ( 0),
+
+ Vertex3 ( 1) (-1) (-1),
+ Vertex3 ( 1) (-1) ( 1),
+ Vertex3 ( 0) ( 1) ( 0)] :: [Vertex3 Float]
+ verticesSize = fromIntegral $ length vertices * sizeOf (head vertices)
+
+ colors = take 12 $ cycle [
+ Vertex4 0 1 0 1,
+ Vertex4 1 0 0 1,
+ Vertex4 0 0 1 1 ] :: [Vertex4 Float]
+ colorsSize = fromIntegral $ length colors * sizeOf (head colors)
+
+ buffer <- genObjectName
+ bindBuffer ArrayBuffer $= Just buffer
+
+ bufferData ArrayBuffer $= (verticesSize + colorsSize, nullPtr, StaticDraw)
+
+ withArray vertices $ \ptr ->
+ bufferSubData ArrayBuffer WriteToBuffer 0 verticesSize ptr
+
+ withArray colors $ \ptr ->
+ bufferSubData ArrayBuffer WriteToBuffer verticesSize colorsSize ptr
+
+ program <- createProgram
+ loadShader program VertexShader "vertex.glsl"
+ loadShader program FragmentShader "fragment.glsl"
+
+ linkProgram program
+
+ status <- linkStatus program
+ unless status $
+ get (programInfoLog program) >>= fail
+
+ currentProgram $= Just program
+
+ verticesLoc <- get (attribLocation program "vPosition")
+ vertexAttribPointer verticesLoc $=
+ (ToFloat, VertexArrayDescriptor 3 Float 0 (ptrOffset 0))
+ vertexAttribArray verticesLoc $= Enabled
+
+ colorsLoc <- get (attribLocation program "vColor")
+ vertexAttribPointer colorsLoc $=
+ (ToFloat, VertexArrayDescriptor 4 Float 0 (ptrOffset verticesSize))
+ vertexAttribArray colorsLoc $= Enabled
+
+ validateProgram program
+ status' <- validateStatus program
+ unless status' $
+ get (programInfoLog program) >>= fail
+
+ return (program, triangles)
+ where ptrOffset = plusPtr nullPtr . fromIntegral
+
+loadShader :: Program -> ShaderType -> String -> IO ()
+loadShader program shaderType file = do
+ shader <- createShader shaderType
+ src <- B.readFile file
+ shaderSourceBS shader $= src
+ compileShader shader
+ status <- compileStatus shader
+ unless status $
+ get (shaderInfoLog shader) >>= fail . ("shader failed " ++)
+ attachShader program shader
+
+perspective' :: Float -> Float -> Float -> Float -> IO (GLmatrix Float)
+perspective' fov aspect zNear zFar =
+ let f = 1.0 / tan(fov)
+ in newMatrix RowMajor
+ [f / aspect, 0, 0, 0,
+ 0, f, 0, 0,
+ 0, 0, (zNear + zFar) / (zNear - zFar), -1,
+ 0, 0, (2 * zFar * zNear) / (zNear - zFar), 0]