Rumpus

.gitignore

@@ -0,0 +1 @@
+.stack-work

LICENSE

@@ -0,0 +1,30 @@
+Copyright Luke Iannini (c) 2015
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Luke Iannini nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,186 @@
+{-# LANGUAGE FlexibleContexts, LambdaCase, RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+import Graphics.UI.GLFW.Pal
+import Graphics.GL.Pal
+import Graphics.VR.Pal
+
+import Control.Monad
+import Control.Monad.State
+import Control.Lens.Extra
+import Data.Map (Map)
+import qualified Data.Map as Map
+import System.Random
+
+import Physics.Bullet
+
+
+type ObjectID = Int
+
+data Cube = Cube
+  { _cubColor :: !(V4 GLfloat)
+  , _cubBody  :: !RigidBody
+  , _cubSize  :: !(V3 GLfloat)
+  }
+makeLenses ''Cube
+
+
+data Uniforms = Uniforms
+    { uModelViewProjection :: UniformLocation (M44 GLfloat)
+    , uInverseModel        :: UniformLocation (M44 GLfloat)
+    , uModel               :: UniformLocation (M44 GLfloat)
+    , uCamera              :: UniformLocation (V3  GLfloat)
+    , uDiffuse             :: UniformLocation (V4  GLfloat)
+    , uCubeHit             :: UniformLocation (V3  GLfloat)
+    } deriving (Data)
+
+data World = World
+    { _wldPlayer    :: !(Pose GLfloat)
+    , _wldCubes     :: !(Map ObjectID Cube)
+    , _wldCubeHits  :: !(Map ObjectID (V3 GLfloat))
+    }
+makeLenses ''World
+
+spatulaID = 99999
+
+newWorld :: World
+newWorld = World
+    (Pose (V3 0 20 60) (axisAngle (V3 0 1 0) 0))
+    mempty
+    mempty
+
+createSpatula :: (MonadIO m, MonadState World m) => DynamicsWorld -> m RigidBody
+createSpatula dynamicsWorld = do
+    let spatulaSize = V3 2 1 1
+    rigidBody <- addCube dynamicsWorld (RigidBodyID spatulaID) 
+        mempty { pcPosition = V3 0 0.5 0
+               , pcRotation = axisAngle (V3 0 1 0) 0 
+               , pcScale = spatulaSize
+               }
+    setRigidBodyKinematic rigidBody
+    -- Create a spatula to stir them up
+    wldCubes . at (fromIntegral spatulaID) ?= Cube
+        { _cubBody  = rigidBody
+        , _cubColor = V4 0 1 1 1
+        , _cubSize  = spatulaSize
+        }
+    return rigidBody
+
+
+
+main :: IO ()
+main = do
+
+    let fov = 45
+
+    VRPal{..} <- initVRPal "Bullet" []
+
+    cubeProg  <- createShaderProgram "shaders/cube.vert" "shaders/cube.frag"
+    cubeGeo   <- cubeGeometry (V3 1 1 1) 1
+    cubeShape <- makeShape cubeGeo cubeProg
+
+    useProgram (sProgram cubeShape)
+
+    dynamicsWorld  <- createDynamicsWorld mempty
+    _              <- addGroundPlane dynamicsWorld (RigidBodyID 0) 0
+
+    glEnable GL_DEPTH_TEST
+
+    glClearColor 0 0 0.1 1
+
+
+    void . flip runStateT newWorld $ do 
+        -- Create a mess of planes
+        let planeSize = V3 1 1 0.1
+        forM_ [1..1000] $ \i -> do
+            rigidBody <- addCube dynamicsWorld (RigidBodyID i) mempty 
+                { pcPosition = V3 0 20 0
+                , pcRotation = axisAngle (V3 0 1 0) 0
+                , pcScale = planeSize
+                }
+            [r,g,b] <- liftIO (replicateM 3 randomIO)
+            wldCubes . at (fromIntegral i) ?= Cube
+                { _cubBody = rigidBody
+                , _cubColor = V4 r g b 1
+                , _cubSize = planeSize
+                }
+
+        spatulaRigidBody <- createSpatula dynamicsWorld
+
+        whileWindow gpWindow $ do
+            now <- getNow
+            let a     = (*20) . sin . (/10) $ now
+                spatX = (*a) . sin  $ now
+                spatZ = (*a) . cos  $ now
+                _ = spatX :: Double
+            setRigidBodyWorldTransform spatulaRigidBody (V3 spatX 0.4 spatZ) (axisAngle (V3 0 1 0) (now + (pi/2)))
+
+            projMat <- getWindowProjection gpWindow fov 0.1 1000
+            viewMat <- viewMatrixFromPose <$> use wldPlayer
+            (x,y,w,h) <- getWindowViewport gpWindow
+            glViewport x y w h
+
+            processEvents gpEvents $ \e -> do
+                closeOnEscape gpWindow e
+                onMouseDown e $ \_ -> raycastCursorHits gpWindow dynamicsWorld projMat
+
+            applyMouseLook gpWindow wldPlayer
+            applyWASD gpWindow wldPlayer        
+
+            stepSimulation dynamicsWorld
+
+            renderSimulation gpWindow cubeShape projMat viewMat
+
+renderSimulation :: (MonadIO m, MonadState World m) 
+                 => Window -> Shape Uniforms -> M44 GLfloat -> M44 GLfloat -> m ()
+renderSimulation window cubeShape projMat viewMat = do
+    let Uniforms{..} = sUniforms cubeShape
+    glClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT)
+
+    uniformV3 uCamera =<< use (wldPlayer . posPosition)
+
+    let viewProj = projMat !*! viewMat
+
+    withVAO (sVAO cubeShape) $ do
+        cubes <- Map.toList <$> use wldCubes
+        forM_ cubes $ \(cubeID, cube) -> do
+            (position, orientation) <- getBodyState (cube ^. cubBody)
+
+            mCubeHit <- use (wldCubeHits . at cubeID)
+            forM_ mCubeHit $ \cubeHit ->
+                uniformV3 uCubeHit cubeHit
+
+            let model = mkTransformation orientation position !*! scaleMatrix (cube ^. cubSize)
+            uniformM44 uModelViewProjection (viewProj !*! model)
+            uniformM44 uInverseModel        (inv44 model)
+            uniformM44 uModel               model
+            uniformV4  uDiffuse             (cube ^. cubColor)
+
+            glDrawElements GL_TRIANGLES (geoVertCount (sGeometry cubeShape)) GL_UNSIGNED_INT nullPtr
+
+    swapBuffers window
+
+raycastCursorHits :: (MonadIO m, MonadState World m) 
+                  => Window -> DynamicsWorld -> M44 GLfloat -> m ()
+raycastCursorHits window dynamicsWorld projMat = do
+    playerPose <- use wldPlayer
+    cursorRay  <- cursorPosToWorldRay window projMat playerPose
+
+    mRayResult <- rayTestClosest dynamicsWorld cursorRay
+    forM_ mRayResult $ \rayResult -> do
+        bodyID <- getRigidBodyID (rrRigidBody rayResult)
+        mCube <- use (wldCubes . at (fromIntegral (unRigidBodyID bodyID)))
+        forM_ mCube $ \_cube -> do          
+
+            -- Convert the hit location into model space
+            -- (position, orientation) <- getBodyState (cube ^. cubBody)
+            -- let model = mkTransformation orientation position
+            --     pointOnModel = worldPointToModelPoint model (rrLocation rayResult)
+            let worldHit = rrLocation rayResult
+
+            let cubeID = fromIntegral (unRigidBodyID bodyID)
+            [r,g,b] <- liftIO (replicateM 3 randomIO)
+            wldCubes . at cubeID . traverse . cubColor .= V4 r g b 1
+
+            wldCubeHits . at cubeID ?= worldHit

rumpus.cabal

@@ -0,0 +1,34 @@
+name:                rumpus
+version:             0.1.0.0
+synopsis:            Initial project template from stack
+description:         Please see README.md
+homepage:            http://github.com/lukexi/rumpus#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Luke Iannini
+maintainer:          lukexi@me.com
+copyright:           Luke Iannini
+category:            Graphics
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+
+executable rumpus
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
+  build-depends:       base
+                     , bullet-mini
+                     , gl-pal
+                     , vr-pal
+                     , glfw-pal
+                     , random
+                     , mtl
+                     , lens-extra
+                     , containers
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/lukexi/rumpus

shaders/cube.frag

@@ -0,0 +1,42 @@
+#version 330 core
+
+uniform vec3 uCamera;
+uniform vec4 uDiffuse;
+uniform vec3 uCubeHit;
+
+in      vec3 vPosition;
+in      vec3 vNormal;
+
+out     vec4 fragColor;
+
+const   vec3 lightColor = vec3(1);
+const   float ambient = 0.2;
+
+void main() {
+
+    vec3 lightPosition = uCamera;
+
+    //calculate normal in world coordinates
+    vec3 normal = normalize(vNormal);
+
+    //calculate the location of this fragment in world coordinates
+    vec3 surfacePos = vPosition;
+
+    // vec4 surfaceColor = texture(materialTex, fragTexCoord);
+    vec4 surfaceColor = uDiffuse;
+    vec3 surfaceToLight = normalize(lightPosition - surfacePos);
+
+    // Calculate final color of the pixel, based on:
+    // 1. The angle of incidence: diffuseCoefficient
+    // 2. The color/intensities of the light: lightColor
+    // 3. The diffuse color: surfaceColor
+
+    float diffuseCoefficient = max(ambient, dot(normal, surfaceToLight));
+    vec3 diffuseLit = diffuseCoefficient * surfaceColor.rgb * lightColor;
+
+
+    fragColor = vec4(diffuseLit, uDiffuse.a);
+
+    float hitDist = distance(vPosition, uCubeHit);
+    fragColor.r += hitDist;
+}

shaders/cube.vert

@@ -0,0 +1,22 @@
+#version 330 core
+
+uniform mat4 uModel;
+uniform mat4 uModelViewProjection;
+uniform mat4 uInverseModel;
+
+in      vec3 aPosition;
+in      vec3 aNormal;
+in      vec2 aUV;
+in      vec3 aTangent;
+
+out     vec3 vPosition;
+out     vec3 vNormal;
+
+void main() {
+    // Apply all matrix transformations to vert
+    gl_Position = uModelViewProjection * vec4(aPosition, 1.0);
+
+    // Pass some variables to the fragment shader
+    vPosition = vec3(uModel * vec4(aPosition, 1.0));
+    vNormal   = vec3(uModel * vec4(aNormal, 0.0));
+}

stack.yaml

@@ -0,0 +1,15 @@
+resolver: nightly-2015-12-03
+packages:
+- '.'
+- ../gl-pal
+- ../udp-pal
+- ../bullet-mini
+- ../vr-pal
+- ../glfw-pal
+- ../pd-haskell
+- ../halive
+- ../animation-pal
+- ../linear-extra
+- ../lens-extra
+- ../openvr-hs
+- ../bindings-GLFW