From: Luke Lau <luke_lau@icloud.com>
Date: Tue, 2 Oct 2018 11:02:15 +0000 (+0100)
Subject: Initial commit
X-Git-Url: https://git.lukelau.me/?p=opengl-haskell.git;a=commitdiff_plain;h=7816decfd2e770e9f0f90d1c27bef59d79d80706

Initial commit
---

7816decfd2e770e9f0f90d1c27bef59d79d80706
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c1b59f6
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,5 @@
+*.o
+*.hi
+Main
+*.swp
+.DS_Store
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..ce545a8
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,140 @@
+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]
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..53f1e72
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,4 @@
+all: Main
+
+Main: Main.hs
+	ghc -framework GLUT $<
diff --git a/fragment.glsl b/fragment.glsl
new file mode 100644
index 0000000..edc4f63
--- /dev/null
+++ b/fragment.glsl
@@ -0,0 +1,7 @@
+#version 330
+in vec4 color;
+out vec4 FragColor;
+
+void main() {
+	FragColor = color;
+}
diff --git a/vertex.glsl b/vertex.glsl
new file mode 100644
index 0000000..3bf0a48
--- /dev/null
+++ b/vertex.glsl
@@ -0,0 +1,12 @@
+#version 330
+in vec3 vPosition;
+in vec4 vColor;
+uniform mat4 model;
+uniform mat4 view;
+uniform mat4 projection;
+out vec4 color;
+
+void main() {
+	gl_Position = projection * view * model * vec4(vPosition, 1.f);
+	color = vColor;
+}