bouncy ships falling down!
This commit is contained in:
nek0
parent
8a171ced87
commit
a3a0ac51cb
4 changed files with 269 additions and 132 deletions
7
hw.cabal
7
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++
|
||||
|
|
|
|||
165
src/Init.hs
Normal file
165
src/Init.hs
Normal 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
|
||||
}
|
||||
176
src/Main.hs
176
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
|
||||
|
|
|
|||
53
src/Types.hs
Normal file
53
src/Types.hs
Normal 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
|
||||
}
|
||||
Loading…
Reference in a new issue