merge development into master

3 files changed, 169 insertions, 248 deletions

diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs
index 3461d27..39f3fd4 100644
--- a/src/Game/Internal.hs
+++ b/src/Game/Internal.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
  - Module      : Game.Internal
  - Description : internal functions
@@ -18,91 +19,89 @@ module Game.Internal
   , updateCursorPos
   , updateKeyPressed
   , updateKeyReleased
-  )
-  where
+  ) where
 
 import Game.Internal.LoadShaders
 import Game.Internal.Types
 
-import Control.Concurrent    (threadDelay)
-import Control.Monad         (when)
-import Data.IORef            (IORef, modifyIORef', readIORef)
-import Data.List             (delete)
+import Control.Concurrent (threadDelay)
+import Control.Monad (when)
+import Data.IORef (IORef, modifyIORef', readIORef)
+import Data.List (delete)
 import Foreign.Marshal.Array (withArray)
-import Foreign.Ptr           (nullPtr, plusPtr)
-import Foreign.Storable      (sizeOf, Storable)
-import GHC.Float             (double2Float)
+import Foreign.Ptr (nullPtr, plusPtr)
+import Foreign.Storable (Storable, sizeOf)
+import GHC.Float (double2Float)
 
-import qualified Graphics.UI.GLFW          as GLFW
 import qualified Graphics.Rendering.OpenGL as GL
-import           Graphics.Rendering.OpenGL as GL (($=))
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.UI.GLFW as GLFW
 
 import Linear (V3(..))
 
 --------------------------------------------------------------------------------
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
-
 -- | loads models, shaders
-initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program)
-initResources array = do
+initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
+initResources arrays = do
   -- create objects
-  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip
-  testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
-  testObject2 <- createObject array 3 GL.TriangleStrip
-  let objects = [testObject0, testObject1, testObject2]
-
+  objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
   -- load shaders
-  program <- loadShaders
-    [ ShaderInfo GL.VertexShader (StringSource vertShader)
-    , ShaderInfo GL.FragmentShader (StringSource fragShader)
-    ]
+  program <-
+    loadShaders
+      [ ShaderInfo GL.VertexShader (StringSource vertShader)
+      , ShaderInfo GL.FragmentShader (StringSource fragShader)
+      ]
   GL.currentProgram $= Just program
-
   return (objects, program)
 
+listIOsToIOlist :: [IO a] -> [a] -> IO [a]
+listIOsToIOlist [] out = return out
+listIOsToIOlist (io:ios) out = do
+  ioVal <- io
+  listIOsToIOlist ios (ioVal:out)
+
 -- a_ vertex shader input
 -- v_ varying
 -- u_ uniform
 -- o_ fragment shader output
-
 -- | vertex shader
 vertShader :: String
 vertShader =
-  "#version 330 core\n" ++
-  "layout (location = 0) in vec3 a_vPos;\n" ++
-  "uniform mat4 u_view;\n" ++
-  "uniform mat4 u_projection;\n" ++
-  "out vec3 v_pos;\n" ++
-  "void main()\n" ++
-  "{\n" ++
-  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
-  "  v_pos = a_vPos;\n" ++
-  "}"
-  
+  "#version 330 core\n"
+    ++ "layout (location = 0) in vec3 a_vPos;\n"
+    ++ "uniform mat4 u_view;\n"
+    ++ "uniform mat4 u_projection;\n"
+    ++ "out vec3 v_pos;\n"
+    ++ "void main()\n"
+    ++ "{\n"
+    ++ "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
+    ++ "  v_pos = a_vPos;\n"
+    ++ "}"
+
 -- | 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 * v_pos, 1);\n" ++
-  "}"
+  "#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"
+    ++ "}"
 
 --------------------------------------------------------------------------------
 -- Objects
 --------------------------------------------------------------------------------
-
 -- | calculates the size in memory of an array
 sizeOfArray :: (Storable a, Num b) => [a] -> b
 sizeOfArray [] = 0
 sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x
 
 -- | loads a given array into a given attribute index
-createVBO
-  :: Storable (a GL.GLfloat)
+createVBO ::
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.AttribLocation
@@ -111,29 +110,19 @@ createVBO array numComponents attribLocation = do
   -- vbo for buffer
   buffer <- GL.genObjectName
   GL.bindBuffer GL.ArrayBuffer $= Just buffer
-
   -- populate buffer
-  withArray
-    array
-    $ \ptr ->
-        GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
-
+  withArray array $ \ptr ->
+    GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
   -- create attribute pointer to buffer
-  GL.vertexAttribPointer attribLocation $=
-    ( GL.ToFloat
-    , GL.VertexArrayDescriptor
-        numComponents
-        GL.Float
-        0
-        (plusPtr nullPtr 0)
-    )
+  GL.vertexAttribPointer attribLocation
+    $= ( GL.ToFloat
+       , GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0))
   GL.vertexAttribArray attribLocation $= GL.Enabled
-
   return buffer
 
 -- | creates an object from a given array; deals with vbos and everything
-createObject
-  :: Storable (a GL.GLfloat)
+createObject ::
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.PrimitiveMode
@@ -142,25 +131,16 @@ createObject array numComponents primitiveMode = do
   -- vao for object
   vao <- GL.genObjectName
   GL.bindVertexArrayObject $= Just vao
-
   -- vbo for vertices
   _ <- createVBO array numComponents $ GL.AttribLocation 0
-
-  return
-    (Object
-      vao
-      (fromIntegral $ length array)
-      numComponents
-      primitiveMode
-    )
+  return (Object vao (fromIntegral $ length array) numComponents primitiveMode)
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
-
 -- | gameloop
-loop
-  :: GLFW.Window -- ^ window to display on
+loop ::
+     GLFW.Window -- ^ window to display on
   -> Float -- ^ dt
   -> (Float -> Model -> Model) -- ^ update function
   -> (GLFW.Window -> Model -> IO ()) -- ^ view function
@@ -169,62 +149,50 @@ loop
 loop window dt update view modelRef = do
   -- start frame timer
   Just frameStart <- GLFW.getTime
-
   -- tick model
   modifyIORef' modelRef $ update dt
   model' <- readIORef modelRef
-
   -- view new model
   view window model'
-
   -- end frame timer, wait the difference between expected and actual
   Just frameEnd <- GLFW.getTime
-  let
-    drawTime = double2Float $ frameEnd - frameStart
-    target = 1 / 60 :: Float
+  let drawTime = double2Float $ frameEnd - frameStart
+      target = 1 / 60 :: Float
   when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
   Just frameEnd' <- GLFW.getTime
-  let
-    dt' = double2Float $ frameEnd' - frameStart
-
+  let dt' = double2Float $ frameEnd' - frameStart
   loop window dt' update view modelRef
 
 -- | updates given a keypress. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyPressed :: GLFW.Key -> Model -> Model
-updateKeyPressed key model =
-  model { keys = key:model.keys }
+updateKeyPressed key model = model {keys = key : model.keys}
 
 -- | updates given a keyrelease. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyReleased :: GLFW.Key -> Model -> Model
-updateKeyReleased key model =
-  model { keys = (delete key model.keys) }
+updateKeyReleased key model = model {keys = (delete key model.keys)}
 
 applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
 applyToTuples f (x, y) (a, b) = (f x a, f y b)
 
 -- | updates cursor
-updateCursorPos :: Double -> Double -> Model ->  Model
+updateCursorPos :: Double -> Double -> Model -> Model
 updateCursorPos x y model =
-  let
-    pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2) ** 0.5
-  in
-  if pyth < 16 then
-    model
-      { cursorPos = (x, y)
-      , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
-      }
-  else 
-    model
-      { cursorPos = (x, y)
-      }
+  let pyth =
+        (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
+          ** 0.5
+   in if pyth < 16
+        then model
+               { cursorPos = (x, y)
+               , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
+               }
+        else model {cursorPos = (x, y)}
 
 -- | draws objects
 drawObjects :: [Object] -> IO ([Object])
 drawObjects [] = return []
-drawObjects
-  ((Object vao numVertices _ primitiveMode):objects) = do
+drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
   GL.bindVertexArrayObject $= Just vao
   GL.drawArrays primitiveMode 0 numVertices
   drawObjects objects
@@ -232,7 +200,6 @@ drawObjects
 --------------------------------------------------------------------------------
 -- interrupts
 --------------------------------------------------------------------------------
-
 -- | shuts down GLFW
 shutdownWindow :: GLFW.WindowCloseCallback
 shutdownWindow window = do
diff --git a/src/Game/Internal/LoadShaders.hs b/src/Game/Internal/LoadShaders.hs
index ded2da9..86b549f 100644
--- a/src/Game/Internal/LoadShaders.hs
+++ b/src/Game/Internal/LoadShaders.hs
@@ -12,10 +12,11 @@
 -- Red Book Authors.
 --
 --------------------------------------------------------------------------------
-
-module Game.Internal.LoadShaders (
-   ShaderSource(..), ShaderInfo(..), loadShaders
-) where
+module Game.Internal.LoadShaders
+  ( ShaderSource(..)
+  , ShaderInfo(..)
+  , loadShaders
+  ) where
 
 import Control.Exception
 import Control.Monad
@@ -23,17 +24,15 @@ import qualified Data.ByteString as B
 import Graphics.Rendering.OpenGL
 
 --------------------------------------------------------------------------------
-
 -- | The source of the shader source code.
-
-data ShaderSource =
-     ByteStringSource B.ByteString
+data ShaderSource
+  = ByteStringSource B.ByteString
      -- ^ The shader source code is directly given as a 'B.ByteString'.
-   | StringSource String
+  | StringSource String
      -- ^ The shader source code is directly given as a 'String'.
-   | FileSource FilePath
+  | FileSource FilePath
      -- ^ The shader source code is located in the file at the given 'FilePath'.
-   deriving ( Eq, Ord, Show )
+  deriving (Eq, Ord, Show)
 
 getSource :: ShaderSource -> IO B.ByteString
 getSource (ByteStringSource bs) = return bs
@@ -41,49 +40,47 @@ getSource (StringSource str) = return $ packUtf8 str
 getSource (FileSource path) = B.readFile path
 
 --------------------------------------------------------------------------------
-
 -- | A description of a shader: The type of the shader plus its source code.
-
-data ShaderInfo = ShaderInfo ShaderType ShaderSource
-   deriving ( Eq, Ord, Show )
+data ShaderInfo =
+  ShaderInfo ShaderType ShaderSource
+  deriving (Eq, Ord, Show)
 
 --------------------------------------------------------------------------------
-
 -- | Create a new program object from the given shaders, throwing an
 -- 'IOException' if something goes wrong.
-
 loadShaders :: [ShaderInfo] -> IO Program
 loadShaders infos =
-   createProgram `bracketOnError` deleteObjectName $ \program -> do
-      loadCompileAttach program infos
-      linkAndCheck program
-      return program
+  createProgram `bracketOnError` deleteObjectName $ \program -> do
+    loadCompileAttach program infos
+    linkAndCheck program
+    return program
 
 linkAndCheck :: Program -> IO ()
 linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
 
 loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
 loadCompileAttach _ [] = return ()
-loadCompileAttach program (ShaderInfo shType source : infos) =
-   createShader shType `bracketOnError` deleteObjectName $ \shader -> do
-      src <- getSource source
-      shaderSourceBS shader $= src
-      compileAndCheck shader
-      attachShader program shader
-      loadCompileAttach program infos
+loadCompileAttach program (ShaderInfo shType source:infos) =
+  createShader shType `bracketOnError` deleteObjectName $ \shader -> do
+    src <- getSource source
+    shaderSourceBS shader $= src
+    compileAndCheck shader
+    attachShader program shader
+    loadCompileAttach program infos
 
 compileAndCheck :: Shader -> IO ()
 compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
 
-checked :: (t -> IO ())
-        -> (t -> GettableStateVar Bool)
-        -> (t -> GettableStateVar String)
-        -> String
-        -> t
-        -> IO ()
+checked ::
+     (t -> IO ())
+  -> (t -> GettableStateVar Bool)
+  -> (t -> GettableStateVar String)
+  -> String
+  -> t
+  -> IO ()
 checked action getStatus getInfoLog message object = do
-   action object
-   ok <- get (getStatus object)
-   unless ok $ do
-      infoLog <- get (getInfoLog object)
-      fail (message ++ " log: " ++ infoLog)
+  action object
+  ok <- get (getStatus object)
+  unless ok $ do
+    infoLog <- get (getInfoLog object)
+    fail (message ++ " log: " ++ infoLog)
diff --git a/src/Game/Internal/Types.hs b/src/Game/Internal/Types.hs
index ad220e4..8095cfb 100644
--- a/src/Game/Internal/Types.hs
+++ b/src/Game/Internal/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
  - Module      : Game.Internal.Types
  - Description : 
@@ -9,116 +10,83 @@
  -}
 module Game.Internal.Types
   ( Object(..)
-
   , toGLMatrix
-
-  , Model ( camera
-          , objects
-          , cursorDeltaPos
-          , cursorPos
-          , program
-          , keys
-          , wprop
-          )
+  , Model(camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop)
   , mkModel
-
-  , Camera ( camPos
-           , camPitch
-           , camYaw
-           , camReference
-           , mouseSensitivity
-           , camVel
-           , strafeStrength
-           , jumpStrength
-           , hasJumped
-           , airTime
-           )
+  , Camera(camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime)
   , mkCamera
-
-  , WorldProperties (g, friction, up)
+  , WorldProperties(g, friction, up)
   , mkWorldProperties
-
   ) where
 
-import qualified Graphics.UI.GLFW          as GLFW
 import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.UI.GLFW as GLFW
 
 import qualified Linear as L
-import           Linear      (V3, V3(..), V4(..))
+import Linear (V3, V3(..), V4(..))
 
 -- | represents a single draw call
-data Object =
-  Object
-    { vao :: GL.VertexArrayObject       -- ^ vao of vertex buffer
-    , numIndicies :: GL.NumArrayIndices -- ^ number of vertices
-    , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
-    , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
-    }
-    deriving Show
+data Object = Object
+  { vao :: GL.VertexArrayObject -- ^ vao of vertex buffer
+  , numIndicies :: GL.NumArrayIndices -- ^ number of vertices
+  , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
+  , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
+  } deriving (Show)
 
 -- | converts M44 to a 16array for OpenGL
 toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
-toGLMatrix
-  (V4
-    (V4 c00 c01 c02 c03)
-    (V4 c10 c11 c12 c13)
-    (V4 c20 c21 c22 c23)
-    (V4 c30 c31 c32 c33)) =
-  [ c00, c01, c02, c03
-  , c10, c11, c12, c13
-  , c20, c21, c22, c23
-  , c30, c31, c32, c33
+toGLMatrix (V4 (V4 c00 c01 c02 c03) (V4 c10 c11 c12 c13) (V4 c20 c21 c22 c23) (V4 c30 c31 c32 c33)) =
+  [ c00
+  , c01
+  , c02
+  , c03
+  , c10
+  , c11
+  , c12
+  , c13
+  , c20
+  , c21
+  , c22
+  , c23
+  , c30
+  , c31
+  , c32
+  , c33
   ]
 
 -- | gamestate
-data Model =
-  Model
-    { camera :: Camera
-    , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
-    , cursorPos :: (Double, Double)      -- ^ current mouse position
-    , keys :: [GLFW.Key]                 -- ^ currently pressed keys
-    , objects :: [Object]                -- ^ draw calls
-    , program :: GL.Program              -- ^ shader program
-    , wprop :: WorldProperties
-    }
-    deriving Show
+data Model = Model
+  { camera :: Camera
+  , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
+  , cursorPos :: (Double, Double) -- ^ current mouse position
+  , keys :: [GLFW.Key] -- ^ currently pressed keys
+  , objects :: [Object] -- ^ draw calls
+  , program :: GL.Program -- ^ shader program
+  , wprop :: WorldProperties
+  } deriving (Show)
 
 -- | smart constructor for Model
-mkModel
-  :: Camera
-  -> [Object]
-  -> GL.Program
-  -> WorldProperties
-  -> Model
+mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
 mkModel camera objects program wprop =
-  Model
-    camera
-    (0,0)
-    (0,0)
-    []
-    objects
-    program
-    wprop
+  Model camera (0, 0) (0, 0) [] objects program wprop
 
 -- | camera
-data Camera =
-  Camera
-    { camPos :: V3 Float        -- ^ position in world space
-    , camPitch :: Float         -- ^ pitch in radians, up positive
-    , camYaw :: Float           -- ^ yaw in radians, right positive
-    , camReference :: V3 Float  -- ^ reference direction; orientation applied to
-    , camVel :: V3 Float        -- ^ velocity in world space
-    , mouseSensitivity :: Float -- ^ scale factor for mouse movement
-    , strafeStrength :: Float   -- ^ scale factor for strafe
-    , jumpStrength :: Float     -- ^ scale factor for jump initial velocity
-    , hasJumped :: Bool         -- ^ whether the camera still has jumping state
-    , airTime :: Float          -- ^ time since jumping state entered in seconds
-    }
-    deriving Show
+data Camera = Camera
+  { camPos :: V3 Float -- ^ position in world space
+  , camPitch :: Float -- ^ pitch in radians, up positive
+  , camYaw :: Float -- ^ yaw in radians, right positive
+  , camReference :: V3 Float -- ^ reference direction; orientation applied to
+  , camVel :: V3 Float -- ^ velocity in world space
+  , mouseSensitivity :: Float -- ^ scale factor for mouse movement
+  , strafeStrength :: Float -- ^ scale factor for strafe
+  , jumpStrength :: Float -- ^ scale factor for jump initial velocity
+  , hasJumped :: Bool -- ^ whether the camera still has jumping state
+  , airTime :: Float -- ^ time since jumping state entered in seconds
+  } deriving (Show)
 
 -- | smart constructor for Camera
-mkCamera
-  :: V3 Float
+mkCamera ::
+     V3 Float
   -> Float
   -> Float
   -> V3 Float
@@ -127,15 +95,7 @@ mkCamera
   -> Float
   -> Float
   -> Camera
-mkCamera
-  camPos
-  camPitch
-  camYaw
-  camReference
-  camVel
-  mouseSensitivity
-  strafeStrength
-  jumpStrength =
+mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
   Camera
     camPos
     camPitch
@@ -149,15 +109,12 @@ mkCamera
     0
 
 -- | physical properties of the world
-data WorldProperties =
-  WorldProperties
-    { g :: Float        -- ^ gravity `g`
-    , friction :: Float -- ^ scale factor for floor friction
-    , up :: V3 Float    -- ^ global up vector
-    }
-    deriving Show
+data WorldProperties = WorldProperties
+  { g :: Float -- ^ gravity `g`
+  , friction :: Float -- ^ scale factor for floor friction
+  , up :: V3 Float -- ^ global up vector
+  } deriving (Show)
 
 -- | smart constructor for WorldProperties
-mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties
-mkWorldProperties g friction up =
-  WorldProperties g friction (L.normalize up)
+mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
+mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)