nek0/hw
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

fun & play

Browse source
This commit is contained in:
nek0 2018-05-17 23:42:07 +02:00
parent 5b026f74ae
commit e793085399
3 changed files with 134 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
examples/example02/Init.hs
View file

@ -71,13 +71,20 @@ load = do
, " f_texcoord = texcoord;"
, "}"
]
fragmentShader = foldl BS.append BS.empty
fragmentShaderSmall = foldl BS.append BS.empty
[ "varying vec2 f_texcoord;"
, "void main(void) {"
, " gl_FragColor = vec4(1.0,1.0,1.0,1.0);"
, "}"
]
p <- GLU.simpleShaderProgramBS vertexShader fragmentShader
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
poss <- mapM (\_ -> do
x <- randomRIO (-50, 50)
@ -86,21 +93,33 @@ load = do
return (V3 x y z)
) [0..2000]
poss2 <- mapM (\_ -> do
x <- randomRIO (-100, 100)
y <- randomRIO (-100, 100)
z <- randomRIO (-100, 100)
return (V3 x y z)
) [0..9]
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))
otherPlanets = zipWith (Ship planetBO ptl)
poss2
(repeat $ Quaternion 1 (V3 0 0 0))
phys <- initPhysics
po <- initPhysicsObjects poss
po <- initPhysicsObjects poss poss2
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poSmallBalls po)
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)
return StateData
{ ships = shipList
, planet = planet
, oplanets = otherPlanets
, proj = perspective (pi/2) (1600 / 900) 1 (-1)
, camera = Camera
{ cameraFocus = V3 0 0 0
@ -108,8 +127,10 @@ load = do
, cameraDist = -100
}
, program = p
, program2 = p2
, physics = phys
, physicsObjects = po
, focusIndex = 0
}
loadTex :: FilePath -> IO GL.TextureObject
@ -129,8 +150,8 @@ initPhysics = do
setGravity world (V3 0 0 0)
return $ Physics bp config disp solver world
initPhysicsObjects :: [V3 Float] -> IO PhysicsObjects
initPhysicsObjects poss = do
initPhysicsObjects :: [V3 Float] -> [V3 Float] -> IO PhysicsObjects
initPhysicsObjects poss poss2 = do
-- ground <- newStaticPlaneShape (V3 0 1 0) 1
smallBall <- newSphereShape 1
bigBall <- newSphereShape 5
@ -139,13 +160,30 @@ initPhysicsObjects poss = do
-- groundBody <- newRigidBody 0 groundMotionState 0.9 0.5 ground (V3 0 0 0)
smallBallPOs <- mapM (\pos -> do
-- fx <- randomRIO (-1000, 1000)
-- fy <- randomRIO (-1000, 1000)
-- fz <- randomRIO (-1000, 1000)
smallBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
(fmap realToFrac pos)
localInertia <- calculateLocalInertia smallBall 1 (V3 0 0 0)
smallBallBody <- newRigidBody 1 smallBallMotionState 0.9 0.5 smallBall localInertia
-- applyCentralForce smallBallBody (V3 fx fy fz)
return $ PhysBody smallBall smallBallMotionState smallBallBody 1
) poss
bigBallsPOs <- mapM (\pos -> do
let m = 1000000
fx <- randomRIO (-1000, 1000)
fy <- randomRIO (-1000, 1000)
fz <- randomRIO (-1000, 1000)
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
applyCentralForce bigBallBody (V3 fx fy fz)
return $ PhysBody bigBall bigBallMotionState bigBallBody m
) poss2
bigBallPO <- do
bigBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
(V3 0 0 0)
@ -156,4 +194,5 @@ initPhysicsObjects poss = do
return PhysicsObjects
{ poBigBall = bigBallPO
, poSmallBalls = smallBallPOs
, poBigBalls = bigBallsPOs
}

108
examples/example02/Main.hs
View file

@ -52,20 +52,52 @@ update dt = do
sd <- getAffection
let phys = physics sd
physos = physicsObjects sd
g = 0.0667300
-- g = 0.0000000000667300
mapM_ (\smallBall -> do
ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
ms2 <- liftIO $ getMotionState (bodyRigidBody $ poBigBall physos)
r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
r2 <- liftIO $ return . fmap realToFrac =<< getPosition ms2
let g = 0.0000000000667300
m1 = bodyMass smallBall
let m1 = bodyMass smallBall
-- m2 = bodyMass (poBigBall physos)
m2 = 1000000000000000
-- m2 = 1000000000000000
m2 = 1000000
eta_sq = 0.1 ^ 2
force = (g * m2 * m1 *^ (r2 - r1)) ^/
((sqrt (((r2 - r1) `dot` (r2 - r1)) + eta_sq)) ^ 3)
liftIO $ applyCentralForce (bodyRigidBody smallBall) force
) (poSmallBalls physos)
) (poSmallBalls physos ++ poBigBalls physos)
mapM_ (\(bb1, bb2) -> do
ms1 <- liftIO $ getMotionState (bodyRigidBody bb1)
ms2 <- liftIO $ getMotionState (bodyRigidBody bb2)
r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
r2 <- liftIO $ return . fmap realToFrac =<< getPosition ms2
let m1 = bodyMass bb1
-- m2 = bodyMass (poBigBall physos)
m2 = bodyMass bb2
eta_sq = 0.1 ^ 2
force = (g * m2 * m1 *^ (r2 - r1)) ^/
((sqrt (((r2 - r1) `dot` (r2 - r1)) + eta_sq)) ^ 3)
liftIO $ applyCentralForce (bodyRigidBody bb1) force
) ((,) <$> (poBigBalls physos) <*> (poBigBalls physos))
mapM_ (\(bb1, bb2) -> do
ms1 <- liftIO $ getMotionState (bodyRigidBody bb1)
ms2 <- liftIO $ getMotionState (bodyRigidBody bb2)
r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
r2 <- liftIO $ return . fmap realToFrac =<< getPosition ms2
let m1 = bodyMass bb1
-- m2 = bodyMass (poBigBall physos)
m2 = bodyMass bb2
eta_sq = 0.1 ^ 2
force = (g * m2 * m1 *^ (r2 - r1)) ^/
((sqrt (((r2 - r1) `dot` (r2 - r1)) + eta_sq)) ^ 3)
liftIO $ applyCentralForce (bodyRigidBody bb1) force
) ((,) <$> (poSmallBalls physos) <*> (poBigBalls physos))
liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
posrots <- mapM ((\ball -> do
ms <- liftIO $ getMotionState ball
@ -73,35 +105,56 @@ update dt = do
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
return (npos, nrot))
. bodyRigidBody) (poSmallBalls physos)
posrots2 <- mapM ((\ball -> do
ms <- liftIO $ getMotionState ball
npos <- liftIO $ return . fmap realToFrac =<< getPosition ms
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
return (npos, nrot))
. bodyRigidBody) (poBigBalls physos)
let nships = map (\(ship, (pos, rot)) ->
ship
{ shipRot = rot
, shipPos = pos
}
) (zip (ships sd) posrots)
nplanets = map (\(ball, (pos, rot)) ->
ball
{ shipRot = rot
, shipPos = pos
}
) (zip (oplanets sd) posrots2)
putAffection sd
{ ships = nships
, oplanets = nplanets
, camera = (camera sd)
{ cameraFocus = shipPos ((planet sd : nplanets) !! focusIndex sd)
}
}
draw :: Affection StateData ()
draw = do
GL.viewport $= (GL.Position 0 0, GL.Size 1600 900)
StateData{..} <- getAffection
GL.currentProgram $= (Just . GLU.program $ program)
mapM_ (\Ship{..} -> do
let view = lookAt
(cameraFocus camera +
rotVecByEulerB2A
(cameraRot camera)
(V3 0 0 (-cameraDist camera)))
(cameraFocus camera)
(V3 0 1 0)
model = mkTransformation shipRot shipPos
pvm = proj !*! view !*! model
liftIO $ GLU.setUniform program "mvp" pvm
GL.bindVertexArrayObject $= Just shipVao
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
) (planet : ships)
drawThings program (planet : ships)
drawThings program2 oplanets
where
drawThings prog ts = do
StateData{..} <- getAffection
GL.currentProgram $= (Just . GLU.program $ prog)
mapM_ (\Ship{..} -> do
let view = lookAt
(cameraFocus camera +
rotVecByEulerB2A
(cameraRot camera)
(V3 0 0 (-cameraDist camera)))
(cameraFocus camera)
(V3 0 1 0)
model = mkTransformation shipRot shipPos
pvm = proj !*! view !*! model
liftIO $ GLU.setUniform program "mvp" pvm
GL.bindVertexArrayObject $= Just shipVao
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
) ts
handle :: SDL.EventPayload -> Affection StateData ()
handle (SDL.WindowClosedEvent _) = quit
@ -117,9 +170,9 @@ handle (SDL.MouseMotionEvent dat) = do
putAffection sd
{ camera =
case SDL.mouseMotionEventState dat of
[SDL.ButtonRight] ->
let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
in c {cameraFocus = cameraFocus c + V3 sx 0 sy}
-- [SDL.ButtonRight] ->
-- 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 / 4 / 45 / 10
(Euler yaw pitch roll) = cameraRot c
@ -147,6 +200,17 @@ handle _ = return ()
handleKey :: SDL.Keycode -> Affection StateData ()
handleKey code
| code == SDL.KeycodeTab = do
ud <- getAffection
let ind = focusIndex ud
ps = planet ud : oplanets ud
if ind + 1 < length ps
then putAffection ud
{ focusIndex = ind + 1
}
else putAffection ud
{ focusIndex = 0
}
| code == SDL.KeycodeR =
GL.clearColor $= GL.Color4 1 0 0 1
| code == SDL.KeycodeG =

4
examples/example02/Types.hs
View file

@ -12,11 +12,14 @@ import Physics.Bullet.Raw as Bullet
data StateData = StateData
{ ships :: [Ship]
, planet :: Ship
, oplanets :: [Ship]
, camera :: Camera
, proj :: M44 Float
, program :: GLU.ShaderProgram
, program2 :: GLU.ShaderProgram
, physics :: Physics
, physicsObjects :: PhysicsObjects
, focusIndex :: Int
}
data Ship = Ship
@ -43,6 +46,7 @@ data Physics = Physics
data PhysicsObjects = PhysicsObjects
{ poBigBall :: PhysBody SphereShape
, poSmallBalls :: [PhysBody SphereShape]
, poBigBalls :: [PhysBody SphereShape]
}
data PhysBody a = PhysBody