bouncy ships falling down!

This commit is contained in:
nek0 2017-09-19 17:27:49 +02:00
parent 8a171ced87
commit a3a0ac51cb
4 changed files with 269 additions and 132 deletions

View file

@ -18,12 +18,15 @@ cabal-version: >=1.10
executable hw executable hw
main-is: Main.hs main-is: Main.hs
other-modules: Util other-modules: Util
, Types
, Init
-- other-extensions: -- other-extensions:
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && <4.10 build-depends: base >=4.9
, affection , affection
, sdl2 , sdl2
, linear , linear
, spatial-math
, bytestring , bytestring
, OpenGL , OpenGL
, OpenGLRaw , OpenGLRaw
@ -31,6 +34,8 @@ executable hw
, random , random
, vector , vector
, wavefront , wavefront
, shoot
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
extra-libraries: stdc++

165
src/Init.hs Normal file
View file

@ -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
}

View file

@ -10,21 +10,20 @@ import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU import qualified Graphics.GLUtil as GLU
import Physics.Bullet.Raw
import Control.Monad (when) import Control.Monad (when)
import qualified Data.ByteString as BS
import Codec.Wavefront
import Linear as L import Linear as L
import System.Random (randomRIO) 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 :: IO ()
main = main =
@ -47,123 +46,27 @@ main =
, canvasSize = Nothing , 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 :: 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 :: Affection StateData ()
draw = do draw = do
@ -173,7 +76,7 @@ draw = do
mapM_ (\(Ship{..}) -> do mapM_ (\(Ship{..}) -> do
let view = lookAt let view = lookAt
(cameraFocus camera + (cameraFocus camera +
(L.rotate (rotVecByEulerB2A
(cameraRot camera) (cameraRot camera)
(V3 0 0 (-cameraDist camera)))) (V3 0 0 (-cameraDist camera))))
(cameraFocus camera) (cameraFocus camera)
@ -192,7 +95,6 @@ handle (SDL.KeyboardEvent dat) = do
let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat) let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat)
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
handleKey key handleKey key
handle (SDL.MouseMotionEvent dat) = do handle (SDL.MouseMotionEvent dat) = do
sd <- getAffection sd <- getAffection
let (V2 rx ry) = fmap fromIntegral $ SDL.mouseMotionEventRelMotion dat let (V2 rx ry) = fmap fromIntegral $ SDL.mouseMotionEventRelMotion dat
@ -201,14 +103,26 @@ handle (SDL.MouseMotionEvent dat) = do
{ camera = { camera =
case SDL.mouseMotionEventState dat of case SDL.mouseMotionEventState dat of
[SDL.ButtonRight] -> [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 in c
{ cameraRot = { cameraRot = nrot
cameraRot c * axisAngle
(normalize $ V3 (- ry) (- rx) 0)
dphi
} }
_ -> _ ->
c c

53
src/Types.hs Normal file
View file

@ -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
}