From a3a0ac51cb74bf1e0cbd35ac8eba8dc13e2d78f7 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 19 Sep 2017 17:27:49 +0200 Subject: [PATCH] bouncy ships falling down! --- hw.cabal | 7 +- src/Init.hs | 165 +++++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 176 +++++++++++++-------------------------------------- src/Types.hs | 53 ++++++++++++++++ 4 files changed, 269 insertions(+), 132 deletions(-) create mode 100644 src/Init.hs create mode 100644 src/Types.hs diff --git a/hw.cabal b/hw.cabal index 988bec4..64de382 100644 --- a/hw.cabal +++ b/hw.cabal @@ -18,12 +18,15 @@ cabal-version: >=1.10 executable hw main-is: Main.hs other-modules: Util + , Types + , Init -- other-extensions: default-extensions: OverloadedStrings - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 , affection , sdl2 , linear + , spatial-math , bytestring , OpenGL , OpenGLRaw @@ -31,6 +34,8 @@ executable hw , random , vector , wavefront + , shoot hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + extra-libraries: stdc++ diff --git a/src/Init.hs b/src/Init.hs new file mode 100644 index 0000000..62e97f9 --- /dev/null +++ b/src/Init.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +module Init where + +import SDL (($=)) +import qualified SDL + +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.GLUtil as GLU + +import qualified Data.ByteString as BS + +import System.Random (randomRIO) + +import Physics.Bullet.Raw + +import Codec.Wavefront + +import Linear as L + +import SpatialMath + +import Foreign + +import Util +import Types + +load :: IO StateData +load = do + _ <- SDL.setMouseLocationMode SDL.RelativeLocation + GL.depthFunc $= Just GL.Less + eobj <- fromFile "assets/ships/jaeger/jaeger.obj" + let obj = case eobj of + Right o -> o + Left err -> error err + -- (ptr, len) <- objLocsToPtr obj + -- (tptr, tlen) <- objUVsToPtr obj + let lobj = loadObj obj + + shipBO <- GL.genObjectName + GL.bindVertexArrayObject $= Just shipBO + + verts <- GL.genObjectName + GL.bindBuffer GL.ArrayBuffer $= Just verts + withArray (loTriangles lobj) $ \ptr -> + GL.bufferData GL.ArrayBuffer $= + ( fromIntegral $ length (loTriangles lobj) * 3 * sizeOf (0 :: Double) + , ptr + , GL.StaticDraw + ) + GL.vertexAttribPointer (GL.AttribLocation 0) $= + ( GL.ToFloat + , GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0) + ) + GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled + + texture <- GL.genObjectName + GL.bindBuffer GL.ArrayBuffer $= Just texture + maybe (return ()) (\a -> withArray a $ \ptr -> + GL.bufferData GL.ArrayBuffer $= + ( fromIntegral $ length a * 2 * sizeOf (0 :: Double) + , ptr + , GL.StaticDraw + )) (loTexTri lobj) + GL.vertexAttribPointer (GL.AttribLocation 1) $= + ( GL.ToFloat + , GL.VertexArrayDescriptor 2 GL.Float 0 (plusPtr nullPtr 0) + ) + GL.vertexAttribArray (GL.AttribLocation 1) $= GL.Enabled + + GL.texture GL.Texture2D $= GL.Enabled + GL.activeTexture $= GL.TextureUnit 0 + t <- loadTex "assets/ships/jaeger/jaeger.texture.tga" + GL.textureBinding GL.Texture2D $= Just t + + let vertexShader = foldl BS.append BS.empty + [ "attribute vec3 coord3d;" + , "attribute vec2 texcoord;" + , "uniform mat4 mvp;" + , "varying vec2 f_texcoord;" + , "void main(void) {" + , " gl_Position = mvp * vec4(coord3d, 1.0);" + , " f_texcoord = texcoord;" + , "}" + ] + fragmentShader = foldl BS.append BS.empty + [ "varying vec2 f_texcoord;" + , "uniform sampler2D texture;" + , "void main(void) {" + , " vec2 flip = vec2(f_texcoord.x, 1.0 - f_texcoord.y);" + , " gl_FragColor = texture2D(texture, flip);" + , "}" + ] + p <- GLU.simpleShaderProgramBS vertexShader fragmentShader + + poss <- mapM (\_ -> do + x <- randomRIO (-50, 50) + y <- randomRIO (-50, 50) + z <- randomRIO (-50, 50) + return (V3 x y z) + ) [0..2000] + + let shipList = map (uncurry $ Ship shipBO (length $ loTriangles lobj)) $ + zip poss (repeat $ Quaternion 1 (V3 0 0 0)) + -- [ (V3 0 0 0, Quaternion 1 (V3 0 0 0)) + -- -- , (V3 3 0 0, Quaternion 1 (V3 0 0 0)) + -- ] + + phys <- initPhysics + + po <- initPhysicsObjects poss + + mapM_ (addRigidBody (pWorld phys)) (map bodyRigidBody (poBalls po)) + addRigidBody (pWorld phys) (bodyRigidBody $ poGround po) + + return StateData + { ships = shipList + , proj = perspective (pi/2) (1600 / 900) 1 (-1) + , camera = Camera + { cameraFocus = V3 0 0 0 + , cameraRot = Euler 0 0 0 + , cameraDist = (-50) + } + , program = p + , physics = phys + , physicsObjects = po + } + +loadTex :: FilePath -> IO GL.TextureObject +loadTex f = do + t <- either error id <$> GLU.readTexture f + GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear') + GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge) + return t + +initPhysics :: IO Physics +initPhysics = do + bp <- newDbvtBroadphase + config <- newDefaultCollisionConfiguration + disp <- newCollisionDispatcher config + solver <- newSequentialImpulseConstraintSolver + world <- newDiscreteDynamicsWorld disp bp solver config + setGravity world (V3 0 (-10) 0) + return $ Physics bp config disp solver world + +initPhysicsObjects :: [V3 Float] -> IO PhysicsObjects +initPhysicsObjects poss = do + ground <- newStaticPlaneShape (V3 0 1 0) 1 + ball <- newSphereShape 1 + + groundMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0)) (V3 0 (-51) 0) + groundBody <- newRigidBody 0 groundMotionState 0.9 0.5 ground (V3 0 0 0) + + balls <- mapM (\pos -> do + ballMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0)) + (fmap realToFrac pos) + localInertia <- calculateLocalInertia ball 1 (V3 0 0 0) + ballBody <- newRigidBody 1 ballMotionState 0.9 0.5 ball localInertia + return $ PhysBody ball ballMotionState ballBody + ) poss + + return PhysicsObjects + { poGround = PhysBody ground groundMotionState groundBody + , poBalls = balls + } diff --git a/src/Main.hs b/src/Main.hs index c1f998f..f3df25e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -10,21 +10,20 @@ import qualified SDL import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.GLUtil as GLU +import Physics.Bullet.Raw + import Control.Monad (when) -import qualified Data.ByteString as BS - -import Codec.Wavefront - import Linear as L import System.Random (randomRIO) -import Foreign +import SpatialMath -import Util +import Init +import Types -import Debug.Trace +import Debug.Trace as T main :: IO () main = @@ -47,123 +46,27 @@ main = , canvasSize = Nothing } -data StateData = StateData - { ships :: [Ship] - , camera :: Camera - , proj :: M44 Float - -- , look :: V3 Float - -- , view :: M44 Float - , program :: GLU.ShaderProgram - } - -data Ship = Ship - { shipVao :: GL.VertexArrayObject - , shipVaoLen :: Int - , shipPos :: V3 Float - , shipRot :: Quaternion Float - } - -data Camera = Camera - { cameraFocus :: V3 Float - , cameraRot :: Quaternion Float - , cameraDist :: Float - } - -load :: IO StateData -load = do - _ <- SDL.setMouseLocationMode SDL.RelativeLocation - GL.depthFunc $= Just GL.Less - eobj <- fromFile "assets/ships/jaeger/jaeger.obj" - let obj = case eobj of - Right o -> o - Left err -> error err - -- (ptr, len) <- objLocsToPtr obj - -- (tptr, tlen) <- objUVsToPtr obj - let lobj = loadObj obj - - shipBO <- GL.genObjectName - GL.bindVertexArrayObject $= Just shipBO - - verts <- GL.genObjectName - GL.bindBuffer GL.ArrayBuffer $= Just verts - withArray (loTriangles lobj) $ \ptr -> - GL.bufferData GL.ArrayBuffer $= - ( fromIntegral $ length (loTriangles lobj) * 3 * sizeOf (0 :: Double) - , ptr - , GL.StaticDraw - ) - GL.vertexAttribPointer (GL.AttribLocation 0) $= - ( GL.ToFloat - , GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0) - ) - GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled - - texture <- GL.genObjectName - GL.bindBuffer GL.ArrayBuffer $= Just texture - maybe (return ()) (\a -> withArray a $ \ptr -> - GL.bufferData GL.ArrayBuffer $= - ( fromIntegral $ length a * 2 * sizeOf (0 :: Double) - , ptr - , GL.StaticDraw - )) (loTexTri lobj) - GL.vertexAttribPointer (GL.AttribLocation 1) $= - ( GL.ToFloat - , GL.VertexArrayDescriptor 2 GL.Float 0 (plusPtr nullPtr 0) - ) - GL.vertexAttribArray (GL.AttribLocation 1) $= GL.Enabled - - GL.texture GL.Texture2D $= GL.Enabled - GL.activeTexture $= GL.TextureUnit 0 - t <- loadTex "assets/ships/jaeger/jaeger.texture.tga" - GL.textureBinding GL.Texture2D $= Just t - - let vertexShader = foldl BS.append BS.empty - [ "attribute vec3 coord3d;" - , "attribute vec2 texcoord;" - , "uniform mat4 mvp;" - , "varying vec2 f_texcoord;" - , "void main(void) {" - , " gl_Position = mvp * vec4(coord3d, 1.0);" - , " f_texcoord = texcoord;" - , "}" - ] - fragmentShader = foldl BS.append BS.empty - [ "varying vec2 f_texcoord;" - , "uniform sampler2D texture;" - , "void main(void) {" - -- , " gl_FragColor = vec4(color, 1.0);" - -- , " gl_FragColor = vec4(1.0);" - , " vec2 flip = vec2(f_texcoord.x, 1.0 - f_texcoord.y);" - , " gl_FragColor = texture2D(texture, flip);" - , "}" - ] - p <- GLU.simpleShaderProgramBS vertexShader fragmentShader - - let shipList = map (uncurry $ Ship shipBO (length $ loTriangles lobj)) - [ (V3 (-3) 0 0, Quaternion 1 (V3 0 0 0)) - , (V3 3 0 0, Quaternion 1 (V3 0 0 0)) - ] - - return StateData - { ships = shipList - , proj = perspective (pi/2) (1600 / 900) 1 (-1) - , camera = Camera - { cameraFocus = V3 0 0 0 - , cameraRot = Quaternion (-1) (V3 0 0 0) - , cameraDist = (-10) - } - , program = p - } - -loadTex :: FilePath -> IO GL.TextureObject -loadTex f = do - t <- either error id <$> GLU.readTexture f - GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear') - GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge) - return t - update :: Double -> Affection StateData () -update _ = return () +update dt = do + sd <- getAffection + let phys = physics sd + physos = physicsObjects sd + liftIO $ stepSimulation (pWorld phys) dt 10 Nothing + posrots <- mapM (\ball -> do + ms <- liftIO $ getMotionState ball + npos <- liftIO $ return . fmap realToFrac =<< getPosition ms + nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms + return (npos, nrot) + ) (map bodyRigidBody $ poBalls physos) + let nships = map (\(ship, (pos, rot)) -> + ship + { shipRot = rot + , shipPos = pos + } + ) (zip (ships sd) posrots) + putAffection sd + { ships = nships + } draw :: Affection StateData () draw = do @@ -173,7 +76,7 @@ draw = do mapM_ (\(Ship{..}) -> do let view = lookAt (cameraFocus camera + - (L.rotate + (rotVecByEulerB2A (cameraRot camera) (V3 0 0 (-cameraDist camera)))) (cameraFocus camera) @@ -192,7 +95,6 @@ handle (SDL.KeyboardEvent dat) = do let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat) when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ handleKey key - handle (SDL.MouseMotionEvent dat) = do sd <- getAffection let (V2 rx ry) = fmap fromIntegral $ SDL.mouseMotionEventRelMotion dat @@ -201,14 +103,26 @@ handle (SDL.MouseMotionEvent dat) = do { camera = case SDL.mouseMotionEventState dat of [SDL.ButtonRight] -> - c {cameraFocus = cameraFocus c + V3 (rx / 10) 0 (ry / 10)} + let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10)) + in c {cameraFocus = cameraFocus c + V3 (sx) 0 (sy)} [] -> - let dphi = pi / 2 / 45 / 2 + let dphi = pi / 4 / 45 / 10 + (Euler yaw pitch roll) = cameraRot c + nangle + | nangle' >= qc = qc - mu + | nangle' <= -qc = -qc + mu + | otherwise = nangle' + where + nangle' = (dphi * ry) + roll + qc = pi / 2 + mu = 0.01 + nrot = + Euler + yaw + (pitch + (rx * dphi)) + nangle in c - { cameraRot = - cameraRot c * axisAngle - (normalize $ V3 (- ry) (- rx) 0) - dphi + { cameraRot = nrot } _ -> c diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..73d4798 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +module Types where + +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.GLUtil as GLU + +import Linear as L + +import SpatialMath + +import Physics.Bullet.Raw as Bullet + +data StateData = StateData + { ships :: [Ship] + , camera :: Camera + , proj :: M44 Float + , program :: GLU.ShaderProgram + , physics :: Physics + , physicsObjects :: PhysicsObjects + } + +data Ship = Ship + { shipVao :: GL.VertexArrayObject + , shipVaoLen :: Int + , shipPos :: V3 Float + , shipRot :: Quaternion Float + } + +data Camera = Camera + { cameraFocus :: V3 Float + , cameraRot :: Euler Float + , cameraDist :: Float + } + +data Physics = Physics + { pBroadphase :: DbvtBroadphase + , pConfig :: DefaultCollisionConfiguration + , pDispatcher :: CollisionDispatcher + , pSolver :: SequentialImpulseConstraintSolver + , pWorld :: DiscreteDynamicsWorld + } + +data PhysicsObjects = PhysicsObjects + { poGround :: PhysBody StaticPlaneShape + , poBalls :: [PhysBody SphereShape] + } + +data PhysBody a = PhysBody + { bodyShape :: a + , bodyMotionState :: MotionState + , bodyRigidBody :: RigidBody + }