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