fun & play
This commit is contained in:
nek0
parent
5b026f74ae
commit
e793085399
3 changed files with 134 additions and 27 deletions
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,21 +105,42 @@ 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)
|
||||
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 +
|
||||
|
|
@ -101,7 +154,7 @@ draw = do
|
|||
liftIO $ GLU.setUniform program "mvp" pvm
|
||||
GL.bindVertexArrayObject $= Just shipVao
|
||||
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
|
||||
) (planet : ships)
|
||||
) 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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue