hypercubes but actually

3 files changed, 132 insertions, 91 deletions

diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs
index e606505..3556df0 100644
--- a/src/Game/Internal.hs
+++ b/src/Game/Internal.hs
@@ -46,13 +46,9 @@ initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program)
 initResources arrays = do
   objects <-
     listIOsToIOlist
-      [createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays]
+      [createObject arr 4 GL.Triangles (GL.AttribLocation 0) | arr <- arrays]
       []
-  program <-
-    loadShaders
-      [ ShaderInfo GL.VertexShader (StringSource vertShader),
-        ShaderInfo GL.FragmentShader (StringSource fragShader)
-      ]
+  program <- loadColorShader
   GL.currentProgram $= Just program
   return (objects, program)
 
@@ -67,39 +63,69 @@ listIOsToIOlist (io : ios) out = do
 -- u_ uniform
 -- o_ fragment shader output
 
--- | vertex shader
+loadBlackShader :: IO GL.Program
+loadBlackShader =
+  loadShaders
+    [ ShaderInfo GL.VertexShader (StringSource vertShader),
+      ShaderInfo GL.FragmentShader (StringSource blackFragShader)
+    ]
+
+loadColorShader :: IO GL.Program
+loadColorShader =
+  loadShaders
+    [ ShaderInfo GL.VertexShader (StringSource vertShader),
+      ShaderInfo GL.FragmentShader (StringSource colorFragShader)
+    ]
+
 vertShader :: String
 vertShader =
-  "#version 330 core\n"
-    ++ "layout (location = 0) in vec4 a_vPos;\n"
-    ++ "uniform mat4 u_view;\n"
-    ++ "uniform mat4 u_projection;\n"
-    ++ "out vec3 v_pos;\n"
-    ++ glslProjectTo3d
-    ++ "void main()\n"
-    ++ "{\n"
-    ++ "  gl_Position = u_projection * u_view * vec4(projectTo3d(a_vPos), 1.0);\n"
-    ++ "  v_pos = a_vPos.xyz;\n"
-    ++ "}\n"
+  unlines
+    [ "#version 330 core",
+      "layout (location = 0) in vec4 a_vPos;",
+      "uniform mat4 u_view;",
+      "uniform mat4 u_projection;",
+      "out vec3 v_pos;",
+      glslProjectTo3d,
+      "void main()",
+      "{",
+      "  vec3 vPos = projectTo3d(a_vPos);",
+      "  gl_Position = u_projection * u_view * vec4(vPos, 1.0);",
+      "  v_pos = vPos;",
+      "}"
+    ]
+
+colorFragShader :: String
+colorFragShader =
+  unlines
+    [ "#version 330 core",
+      "out vec4 o_vColor;",
+      "in vec3 v_pos;",
+      "void main()",
+      "{",
+      "  o_vColor = vec4((0.5 + 0.5 * normalize(v_pos)) / 2, 1.0);",
+      "}"
+    ]
 
--- | fragment shader
-fragShader :: String
-fragShader =
-  "#version 330 core\n"
-    ++ "out vec4 o_vColor;\n"
-    ++ "in vec3 v_pos;\n"
-    ++ "void main()\n"
-    ++ "{\n"
-    ++ "  o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
-    ++ "}\n"
+blackFragShader :: String
+blackFragShader =
+  unlines
+    [ "#version 330 core",
+      "out vec4 o_vColor;",
+      "void main()",
+      "{",
+      "  o_vColor = vec4(0.0, 0.0, 0.0, 1.0);",
+      "}"
+    ]
 
 glslProjectTo3d :: String
 glslProjectTo3d =
-  "vec3 projectTo3d(vec4 point)\n"
-    ++ "{\n"
-    ++ "  float perspective = 1.0 / (1.0 + point.w);\n"
-    ++ "  return perspective * point.xyz;\n"
-    ++ "}\n"
+  unlines
+    [ "vec3 projectTo3d(vec4 point)",
+      "{",
+      "  float perspective = 1.0 / (1.0 + point.w);",
+      "  return perspective * point.xyz;",
+      "}"
+    ]
 
 --------------------------------------------------------------------------------
 -- Objects
diff --git a/src/Game/Internal/Types.hs b/src/Game/Internal/Types.hs
index b8e7229..61173db 100644
--- a/src/Game/Internal/Types.hs
+++ b/src/Game/Internal/Types.hs
@@ -11,7 +11,7 @@
 module Game.Internal.Types
   ( Object (..),
     toGLMatrix,
-    Model (camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop),
+    Model (camera, objects, cursorDeltaPos, cursorPos, keys, program, wprop),
     mkModel,
     Camera (camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime),
     mkCamera,
@@ -70,7 +70,6 @@ data Model = Model
     keys :: [GLFW.Key],
     -- | draw calls
     objects :: [Object],
-    -- | shader program
     program :: GL.Program,
     wprop :: WorldProperties
   }
diff --git a/src/Main.hs b/src/Main.hs
index 2786f86..16029b4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,7 +22,7 @@ import Game.Internal.Types
 import Graphics.Rendering.OpenGL (($=))
 import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.UI.GLFW as GLFW
-import Linear (V3 (..), V4 (..), _y)
+import Linear (V3 (..), V4 (..), (*^), _y)
 import qualified Linear as L
 
 -- | Main function runs game
@@ -48,8 +48,9 @@ main = do
   GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)
   (objects, program) <-
     initResources $
-      -- [map (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [0, 2 ..]]
-      [hCube]
+      [map (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [4, 6 ..]]
+        ++ [hCube]
+        ++ [map (\v -> rotate4 0 3 (g90 / 3) (v + V4 0 3 0 0)) hCube]
 
   let model =
         mkModel
@@ -75,34 +76,13 @@ main = do
 --------------------------------------------------------------------------------
 -- Arrays
 --------------------------------------------------------------------------------
-top :: [V3 GL.GLfloat]
-top =
-  [ V3 p 0 p,
-    V3 p 0 m,
-    V3 m 0 p,
-    V3 m 0 m
-  ]
-
-side :: [V3 GL.GLfloat]
-side =
-  [ V3 0 p p,
-    V3 0 p m,
-    V3 0 m p,
-    V3 0 m m
-  ]
-
-front :: [V3 GL.GLfloat]
-front =
-  [ V3 p p 0,
-    V3 p m 0,
-    V3 m p 0,
-    V3 m m 0
-  ]
 
 m = (0 - p)
 
 p = 0.5
 
+g90 = pi / 2
+
 v3tov4 :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
 v3tov4 w (V3 x y z) = V4 x y z w
 
@@ -115,41 +95,77 @@ v3tov4'' w (V3 x y z) = V4 x w y z
 v3tov4''' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
 v3tov4''' w (V3 x y z) = V4 w x y z
 
--- | TODO optimise cube
+rotate :: V3 GL.GLfloat -> GL.GLfloat -> V3 GL.GLfloat -> V3 GL.GLfloat
+rotate axis angle point = L.fromQuaternion (L.axisAngle axis angle) L.!* point
+
+rotate4 :: Int -> Int -> GL.GLfloat -> V4 GL.GLfloat -> V4 GL.GLfloat
+rotate4 i0 i1 angle (V4 x y z w) =
+  let coords = [x, y, z, w]
+      cos' = cos angle
+      sin' = sin angle
+      xi = coords !! i0
+      xj = coords !! i1
+      coords' =
+        [ if k == i0
+            then cos' * xi - sin' * xj
+            else
+              if k == i1
+                then sin' * xi + cos' * xj
+                else coords !! k
+        | k <- [0 .. 3]
+        ]
+   in V4 (coords' !! 0) (coords' !! 1) (coords' !! 2) (coords' !! 3)
+
+cycle3r :: V3 GL.GLfloat -> V3 GL.GLfloat
+cycle3r (V3 a b c) = V3 c a b
+
+cycle3l :: V3 GL.GLfloat -> V3 GL.GLfloat
+cycle3l (V3 a b c) = V3 b c a
+
+face :: [V3 GL.GLfloat]
+face =
+  [ V3 m m 0,
+    V3 p m 0,
+    V3 m p 0,
+    V3 m p 0,
+    V3 p m 0,
+    V3 p p 0
+  ]
+
+-- | cube, side length 1, centered on 0 0 0
 cube :: [V3 GL.GLfloat]
 cube =
-  [ V3 p p p, -- front
-    V3 p m p,
-    V3 m p p,
-    V3 m m p, -- down
-    V3 m m m,
-    V3 p m p,
-    V3 p m m, -- right
-    V3 p p m,
-    V3 p m p,
-    V3 p p p, -- up
-    V3 m p p,
-    V3 p p m,
-    V3 m p m, -- back
-    V3 p m m,
-    V3 p p m,
-    V3 m m m, -- left
-    V3 m p m,
-    V3 m m p,
-    V3 m p p
-  ]
+  concatMap
+    ( \faceSpec ->
+        map
+          (\v -> (rotate (fst faceSpec) g90 v) L.^+^ (rotate (fst faceSpec) g90 (snd faceSpec)))
+          face
+    )
+    [ (V3 0 0 1, V3 0 0 p),
+      (V3 0 1 0, V3 0 0 p),
+      (V3 1 0 0, V3 0 0 p),
+      (V3 0 0 (-1), V3 0 0 m), -- no clue
+      (V3 0 (-1) 0, V3 0 0 p),
+      (V3 (-1) 0 0, V3 0 0 p)
+    ]
 
--- | TODO optimise hCube
 hCube :: [V4 GL.GLfloat]
 hCube =
-  (map (v3tov4 m) cube)
-    ++ (map (v3tov4 p) cube)
-    ++ (map (v3tov4' m) cube)
-    ++ (map (v3tov4' p) cube)
-    ++ (map (v3tov4'' m) cube)
-    ++ (map (v3tov4'' p) cube)
-    ++ (map (v3tov4''' m) cube)
-    ++ (map (v3tov4''' p) cube)
+  concatMap
+    ( \(w, i0, i1) ->
+        map
+          (rotate4 i0 i1 g90 . v3tov4 w)
+          cube
+    )
+    [ (p, 3, 0),
+      (p, 0, 3),
+      (p, 1, 3),
+      (p, 2, 3),
+      (m, 3, 0),
+      (m, 0, 3),
+      (m, 1, 3),
+      (m, 2, 3)
+    ]
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures