hw/examples/example02/Init.hs

206 lines
6.1 KiB
Haskell
Raw Normal View History

2017-11-07 21:22:46 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Init where
import SDL (($=))
import qualified SDL
2021-09-10 22:15:31 +00:00
import Control.Concurrent.STM.TVar
2017-11-07 21:22:46 +00:00
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
genVertBufObject path = do
eobj <- fromFile path
let obj = case eobj of
Right o -> o
Left err -> error err
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 $=
2018-05-17 19:59:22 +00:00
( fromIntegral $ length (loTriangles lobj) * sizeOf (0 :: Float)
2017-11-07 21:22:46 +00:00
, 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
2018-05-17 19:59:22 +00:00
GL.bindBuffer GL.ArrayBuffer $= Nothing
GL.bindVertexArrayObject $= Nothing
2017-11-07 21:22:46 +00:00
return (shipBO, length (loTriangles lobj))
load :: IO StateData
load = do
_ <- SDL.setMouseLocationMode SDL.RelativeLocation
GL.depthFunc $= Just GL.Less
(shipBO, stl) <- genVertBufObject "assets/spheres/smallsphere.obj"
(planetBO, ptl) <- genVertBufObject "assets/spheres/bigsphere.obj"
let vertexShader = foldl BS.append BS.empty
[ "attribute vec3 coord3d;"
, "attribute vec2 texcoord;"
, "uniform mat4 mvp;"
, "varying vec2 f_texcoord;"
, "void main(void) {"
2018-05-18 05:56:11 +00:00
, " float zoom = 1.0;"
2017-11-07 21:22:46 +00:00
, " gl_Position = mvp * vec4(coord3d, 1.0);"
2018-05-18 05:56:11 +00:00
-- , " gl_Position.z = 0.0;"
-- , " gl_Position.w += 10.0;"
2017-11-07 21:22:46 +00:00
, " f_texcoord = texcoord;"
, "}"
]
2018-05-17 21:42:07 +00:00
fragmentShaderSmall = foldl BS.append BS.empty
2017-11-07 21:22:46 +00:00
[ "varying vec2 f_texcoord;"
, "void main(void) {"
2018-05-17 19:59:22 +00:00
, " gl_FragColor = vec4(1.0,1.0,1.0,1.0);"
2017-11-07 21:22:46 +00:00
, "}"
]
2018-05-17 21:42:07 +00:00
fragmentShaderBig = foldl BS.append BS.empty
[ "varying vec2 f_texcoord;"
, "void main(void) {"
, " gl_FragColor = vec4(1.0,0,0,1.0);"
, "}"
]
p <- GLU.simpleShaderProgramBS vertexShader fragmentShaderSmall
p2 <- GLU.simpleShaderProgramBS vertexShader fragmentShaderBig
2017-11-07 21:22:46 +00:00
poss <- mapM (\_ -> do
x <- randomRIO (-50, 50)
y <- randomRIO (-50, 50)
z <- randomRIO (-50, 50)
return (V3 x y z)
2020-01-05 14:22:41 +00:00
) [0..1999]
2017-11-07 21:22:46 +00:00
2018-05-17 21:42:07 +00:00
poss2 <- mapM (\_ -> do
x <- randomRIO (-100, 100)
y <- randomRIO (-100, 100)
z <- randomRIO (-100, 100)
return (V3 x y z)
2020-01-05 14:22:41 +00:00
) [] -- [0..9]
2018-05-17 21:42:07 +00:00
2017-11-07 21:22:46 +00:00
let shipList = zipWith (Ship shipBO stl)
poss
(repeat $ Quaternion 1 (V3 0 0 0))
planet = Ship planetBO ptl (V3 0 0 0) (Quaternion 1 (V3 0 0 0))
2018-05-17 21:42:07 +00:00
otherPlanets = zipWith (Ship planetBO ptl)
poss2
(repeat $ Quaternion 1 (V3 0 0 0))
2017-11-07 21:22:46 +00:00
phys <- initPhysics
2018-05-17 21:42:07 +00:00
po <- initPhysicsObjects poss poss2
2017-11-07 21:22:46 +00:00
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poSmallBalls po)
2018-05-17 21:42:07 +00:00
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
2017-11-07 21:22:46 +00:00
addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)
2021-09-10 22:15:31 +00:00
StateData
<$> newTVarIO shipList
<*> newTVarIO planet
<*> newTVarIO otherPlanets
<*> newTVarIO (Camera
2017-11-07 21:22:46 +00:00
{ cameraFocus = V3 0 0 0
, cameraRot = Euler 0 0 0
2017-11-12 13:18:46 +00:00
, cameraDist = -100
2021-09-10 22:15:31 +00:00
})
<*> newTVarIO (infinitePerspective (pi/2) (1600 / 900) 1)
<*> newTVarIO p
<*> newTVarIO p2
<*> newTVarIO phys
<*> newTVarIO po
<*> newTVarIO 0
<*> newTVarIO True
2017-11-07 21:22:46 +00:00
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
2017-11-07 22:04:43 +00:00
setGravity world (V3 0 0 0)
2017-11-07 21:22:46 +00:00
return $ Physics bp config disp solver world
2018-05-17 21:42:07 +00:00
initPhysicsObjects :: [V3 Float] -> [V3 Float] -> IO PhysicsObjects
initPhysicsObjects poss poss2 = do
2017-11-07 21:22:46 +00:00
-- ground <- newStaticPlaneShape (V3 0 1 0) 1
smallBall <- newSphereShape 1
bigBall <- newSphereShape 5
-- 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)
smallBallPOs <- mapM (\pos -> do
2018-05-17 21:42:07 +00:00
-- fx <- randomRIO (-1000, 1000)
-- fy <- randomRIO (-1000, 1000)
-- fz <- randomRIO (-1000, 1000)
2018-05-18 05:56:11 +00:00
let m = 100
2017-11-07 21:22:46 +00:00
smallBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
(fmap realToFrac pos)
2018-05-18 05:56:11 +00:00
localInertia <- calculateLocalInertia smallBall m (V3 0 0 0)
smallBallBody <- newRigidBody m smallBallMotionState 0.9 0.5 smallBall localInertia
2018-05-17 21:42:07 +00:00
-- applyCentralForce smallBallBody (V3 fx fy fz)
2018-05-18 05:56:11 +00:00
return $ PhysBody smallBall smallBallMotionState smallBallBody m
2017-11-07 21:22:46 +00:00
) poss
2018-05-17 21:42:07 +00:00
bigBallsPOs <- mapM (\pos -> do
let m = 1000000
2018-05-18 05:56:11 +00:00
-- fx <- randomRIO (-1000, 1000)
-- fy <- randomRIO (-1000, 1000)
-- fz <- randomRIO (-1000, 1000)
2018-05-17 21:42:07 +00:00
bigBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
(fmap realToFrac pos)
localInertia <- calculateLocalInertia bigBall m (V3 0 0 0)
bigBallBody <- newRigidBody m bigBallMotionState 0.9 0.5 bigBall localInertia
2018-05-18 05:56:11 +00:00
-- applyCentralForce bigBallBody (V3 fx fy fz)
2018-05-17 21:42:07 +00:00
return $ PhysBody bigBall bigBallMotionState bigBallBody m
) poss2
2017-11-07 21:22:46 +00:00
bigBallPO <- do
bigBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
(V3 0 0 0)
localInertia <- calculateLocalInertia bigBall 1 (V3 0 0 0)
bigBallBody <- newRigidBody 0 bigBallMotionState 0.9 0.5 bigBall localInertia
return $ PhysBody bigBall bigBallMotionState bigBallBody 0
return PhysicsObjects
{ poBigBall = bigBallPO
, poSmallBalls = smallBallPOs
2018-05-17 21:42:07 +00:00
, poBigBalls = bigBallsPOs
2018-05-18 05:56:11 +00:00
-- , poBigBalls = []
2017-11-07 21:22:46 +00:00
}