modernize some examples
This commit is contained in:
parent
69a951fd28
commit
9e13158141
7 changed files with 229 additions and 201 deletions
|
|
@ -5,6 +5,8 @@ module Init where
|
|||
import SDL (($=))
|
||||
import qualified SDL
|
||||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.GLUtil as GLU
|
||||
|
||||
|
|
@ -111,18 +113,18 @@ load = do
|
|||
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBalls po)
|
||||
addRigidBody (pWorld phys) (bodyRigidBody $ poGround po)
|
||||
|
||||
return StateData
|
||||
{ ships = shipList
|
||||
, proj = perspective (pi/2) (1600 / 900) 1 (-1)
|
||||
, camera = Camera
|
||||
StateData
|
||||
<$> newTVarIO shipList
|
||||
<*> newTVarIO (Camera
|
||||
{ cameraFocus = V3 0 0 0
|
||||
, cameraRot = Euler 0 0 0
|
||||
, cameraDist = -50
|
||||
}
|
||||
, program = p
|
||||
, physics = phys
|
||||
, physicsObjects = po
|
||||
}
|
||||
})
|
||||
<*> newTVarIO (perspective (pi/2) (1600 / 900) 1 (-1))
|
||||
<*> newTVarIO p
|
||||
<*> newTVarIO phys
|
||||
<*> newTVarIO po
|
||||
<*> newTVarIO True
|
||||
|
||||
loadTex :: FilePath -> IO GL.TextureObject
|
||||
loadTex f = do
|
||||
|
|
|
|||
|
|
@ -12,6 +12,9 @@ import qualified Graphics.GLUtil as GLU
|
|||
|
||||
import Physics.Bullet.Raw
|
||||
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
|
|
@ -28,7 +31,7 @@ import Debug.Trace as T
|
|||
|
||||
main :: IO ()
|
||||
main =
|
||||
withAffection AffectionConfig
|
||||
withAffection (AffectionConfig
|
||||
{ initComponents = All
|
||||
, windowTitle = "hw"
|
||||
, windowConfigs =
|
||||
|
|
@ -36,26 +39,33 @@ main =
|
|||
, SDL.defaultWindow
|
||||
{ SDL.windowInitialSize = SDL.V2 1600 900
|
||||
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
|
||||
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
|
||||
{ SDL.glProfile = SDL.Compatibility SDL.Debug 4 0
|
||||
}
|
||||
}
|
||||
, SDL.Fullscreen
|
||||
)
|
||||
]
|
||||
, initScreenMode = SDL.Fullscreen
|
||||
, preLoop = return ()
|
||||
, eventLoop = mapM_ handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, loadState = load
|
||||
, cleanUp = const (return ())
|
||||
, canvasSize = Nothing
|
||||
}
|
||||
} :: AffectionConfig StateData)
|
||||
|
||||
update :: Double -> Affection StateData ()
|
||||
update dt = do
|
||||
sd <- getAffection
|
||||
instance Affectionate StateData where
|
||||
loadState = load
|
||||
preLoop _ = return ()
|
||||
handleEvents sd = mapM_ (handle sd)
|
||||
update = Main.update
|
||||
draw = Main.draw
|
||||
cleanUp = const (return ())
|
||||
hasNextStep = liftIO . readTVarIO . quitGame
|
||||
|
||||
quit = liftIO . atomically . (\sd -> writeTVar (quitGame sd) False)
|
||||
|
||||
update :: StateData -> Double -> Affection ()
|
||||
update sd dt = do
|
||||
let phys = physics sd
|
||||
physos = physicsObjects sd
|
||||
(phys, physos) <- liftIO $ atomically $
|
||||
(,)
|
||||
<$> readTVar (physics sd)
|
||||
<*> readTVar (physicsObjects sd)
|
||||
liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
|
||||
posrots <- mapM ((\ball -> do
|
||||
ms <- liftIO $ getMotionState ball
|
||||
|
|
@ -63,80 +73,79 @@ update dt = do
|
|||
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
|
||||
return (npos, nrot))
|
||||
. bodyRigidBody) (poBalls physos)
|
||||
let nships = map (\(ship, (pos, rot)) ->
|
||||
let nships shipss = map (\(ship, (pos, rot)) ->
|
||||
ship
|
||||
{ shipRot = rot
|
||||
, shipPos = pos
|
||||
}
|
||||
) (zip (ships sd) posrots)
|
||||
putAffection sd
|
||||
{ ships = nships
|
||||
}
|
||||
) (zip shipss posrots)
|
||||
liftIO $ atomically $ modifyTVar (ships sd) $ \shs -> nships shs
|
||||
|
||||
draw :: Affection StateData ()
|
||||
draw = do
|
||||
draw :: StateData -> Affection ()
|
||||
draw sd = do
|
||||
(cam, p, ships, program) <- liftIO $ do
|
||||
cam <- readTVarIO (camera sd)
|
||||
p <- readTVarIO (proj sd)
|
||||
ships <- readTVarIO (ships sd)
|
||||
program <- readTVarIO (program sd)
|
||||
return (cam, p, ships, program)
|
||||
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 +
|
||||
(cameraFocus cam +
|
||||
rotVecByEulerB2A
|
||||
(cameraRot camera)
|
||||
(V3 0 0 (-cameraDist camera)))
|
||||
(cameraFocus camera)
|
||||
(cameraRot cam)
|
||||
(V3 0 0 (-cameraDist cam)))
|
||||
(cameraFocus cam)
|
||||
(V3 0 1 0)
|
||||
model = mkTransformation shipRot shipPos
|
||||
pvm = proj !*! view !*! model
|
||||
pvm = p !*! view !*! model
|
||||
liftIO $ GLU.setUniform program "mvp" pvm
|
||||
GL.bindVertexArrayObject $= Just shipVao
|
||||
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
|
||||
) ships
|
||||
|
||||
handle :: SDL.EventPayload -> Affection StateData ()
|
||||
handle (SDL.WindowClosedEvent _) = quit
|
||||
handle :: StateData -> SDL.EventPayload -> Affection ()
|
||||
handle sd (SDL.WindowClosedEvent _) = quit sd
|
||||
|
||||
handle (SDL.KeyboardEvent dat) = do
|
||||
handle sd (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
|
||||
handleKey sd key
|
||||
handle sd (SDL.MouseMotionEvent dat) = do
|
||||
let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
|
||||
c = camera sd
|
||||
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}
|
||||
[] ->
|
||||
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 = nrot
|
||||
}
|
||||
_ ->
|
||||
c
|
||||
}
|
||||
liftIO $ atomically $ modifyTVar (camera sd) $ \c ->
|
||||
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}
|
||||
[] ->
|
||||
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 = nrot
|
||||
}
|
||||
_ ->
|
||||
c
|
||||
|
||||
handle _ = return ()
|
||||
handle _ _ = return ()
|
||||
|
||||
handleKey :: SDL.Keycode -> Affection StateData ()
|
||||
handleKey code
|
||||
handleKey :: StateData -> SDL.Keycode -> Affection ()
|
||||
handleKey sd code
|
||||
| code == SDL.KeycodeR =
|
||||
GL.clearColor $= GL.Color4 1 0 0 1
|
||||
| code == SDL.KeycodeG =
|
||||
|
|
@ -150,12 +159,12 @@ handleKey code
|
|||
a <- liftIO $ randomRIO (0, 1)
|
||||
GL.clearColor $= GL.Color4 r g b a
|
||||
| code == SDL.KeycodeEscape =
|
||||
quit
|
||||
quit sd
|
||||
| code == SDL.KeycodeF = do
|
||||
dt <- deltaTime <$> get
|
||||
liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
|
||||
| code == SDL.KeycodeT =
|
||||
toggleScreen
|
||||
toggleScreen 0
|
||||
| code `elem`
|
||||
[ SDL.KeycodeW
|
||||
, SDL.KeycodeS
|
||||
|
|
@ -165,8 +174,8 @@ handleKey code
|
|||
, SDL.KeycodeE
|
||||
]
|
||||
= do
|
||||
sd <- getAffection
|
||||
let ship = head (ships sd)
|
||||
shipss <- liftIO $ atomically $ readTVar (ships sd)
|
||||
let ship = head shipss
|
||||
rot = shipRot ship
|
||||
dphi = pi / 2 / 45
|
||||
nquat = case code of
|
||||
|
|
@ -177,10 +186,9 @@ handleKey code
|
|||
SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi)
|
||||
SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi
|
||||
_ -> rot
|
||||
putAffection sd
|
||||
{ ships = ship
|
||||
liftIO $ atomically $ modifyTVar (ships sd) $ \shipss ->
|
||||
ship
|
||||
{ shipRot = nquat
|
||||
} : tail (ships sd)
|
||||
}
|
||||
} : tail shipss
|
||||
| otherwise =
|
||||
return ()
|
||||
|
|
|
|||
|
|
@ -9,13 +9,16 @@ import SpatialMath
|
|||
|
||||
import Physics.Bullet.Raw as Bullet
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
data StateData = StateData
|
||||
{ ships :: [Ship]
|
||||
, camera :: Camera
|
||||
, proj :: M44 Float
|
||||
, program :: GLU.ShaderProgram
|
||||
, physics :: Physics
|
||||
, physicsObjects :: PhysicsObjects
|
||||
{ ships :: TVar [Ship]
|
||||
, camera :: TVar Camera
|
||||
, proj :: TVar (M44 Float)
|
||||
, program :: TVar GLU.ShaderProgram
|
||||
, physics :: TVar Physics
|
||||
, physicsObjects :: TVar PhysicsObjects
|
||||
, quitGame :: TVar Bool
|
||||
}
|
||||
|
||||
data Ship = Ship
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ module Init where
|
|||
import SDL (($=))
|
||||
import qualified SDL
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.GLUtil as GLU
|
||||
|
||||
|
|
@ -119,22 +121,22 @@ load = do
|
|||
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
|
||||
addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)
|
||||
|
||||
return StateData
|
||||
{ ships = shipList
|
||||
, planet = planet
|
||||
, oplanets = otherPlanets
|
||||
, proj = infinitePerspective (pi/2) (1600 / 900) 1
|
||||
, camera = Camera
|
||||
StateData
|
||||
<$> newTVarIO shipList
|
||||
<*> newTVarIO planet
|
||||
<*> newTVarIO otherPlanets
|
||||
<*> newTVarIO (Camera
|
||||
{ cameraFocus = V3 0 0 0
|
||||
, cameraRot = Euler 0 0 0
|
||||
, cameraDist = -100
|
||||
}
|
||||
, program = p
|
||||
, program2 = p2
|
||||
, physics = phys
|
||||
, physicsObjects = po
|
||||
, focusIndex = 0
|
||||
}
|
||||
})
|
||||
<*> newTVarIO (infinitePerspective (pi/2) (1600 / 900) 1)
|
||||
<*> newTVarIO p
|
||||
<*> newTVarIO p2
|
||||
<*> newTVarIO phys
|
||||
<*> newTVarIO po
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO True
|
||||
|
||||
loadTex :: FilePath -> IO GL.TextureObject
|
||||
loadTex f = do
|
||||
|
|
|
|||
|
|
@ -12,6 +12,9 @@ import qualified Graphics.GLUtil as GLU
|
|||
|
||||
import Physics.Bullet.Raw
|
||||
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
|
|
@ -28,7 +31,7 @@ import Debug.Trace as T
|
|||
|
||||
main :: IO ()
|
||||
main =
|
||||
withAffection AffectionConfig
|
||||
withAffection (AffectionConfig
|
||||
{ initComponents = All
|
||||
, windowTitle = "hw - example 02"
|
||||
, windowConfigs =
|
||||
|
|
@ -39,26 +42,29 @@ main =
|
|||
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
|
||||
}
|
||||
}
|
||||
, SDL.FullscreenDesktop
|
||||
)
|
||||
]
|
||||
, initScreenMode = SDL.FullscreenDesktop
|
||||
, preLoop = return ()
|
||||
, eventLoop = mapM_ handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, loadState = load
|
||||
, cleanUp = const (return ())
|
||||
, canvasSize = Nothing
|
||||
}
|
||||
} :: AffectionConfig StateData)
|
||||
|
||||
update :: Double -> Affection StateData ()
|
||||
update dt = do
|
||||
sd <- getAffection
|
||||
let phys = physics sd
|
||||
physos = physicsObjects sd
|
||||
g = 0.0667300
|
||||
-- g = 0.0000000000667300
|
||||
instance Affectionate StateData where
|
||||
preLoop = const (return ())
|
||||
handleEvents sd = mapM_(handle sd)
|
||||
update = Main.update
|
||||
draw = Main.draw
|
||||
loadState = load
|
||||
cleanUp = const (return ())
|
||||
hasNextStep = liftIO . readTVarIO . nextStep
|
||||
|
||||
quit = liftIO . atomically . flip writeTVar False . nextStep
|
||||
|
||||
update :: StateData -> Double -> Affection ()
|
||||
update sd dt = do
|
||||
let g = 0.0667300
|
||||
(phys, physos) <- liftIO $ do
|
||||
p <- readTVarIO (physics sd)
|
||||
po <- readTVarIO (physicsObjects sd)
|
||||
return (p, po)
|
||||
mapM_ (\smallBall -> do
|
||||
ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
|
||||
ms2 <- liftIO $ getMotionState (bodyRigidBody $ poBigBall physos)
|
||||
|
|
@ -115,36 +121,50 @@ update dt = do
|
|||
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
|
||||
return (npos, nrot))
|
||||
. bodyRigidBody) (poBigBalls physos)
|
||||
let nships = map (\(ship, (pos, rot)) ->
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar (ships sd) $ \ships ->
|
||||
map (\(ship, (pos, rot)) ->
|
||||
ship
|
||||
{ shipRot = rot
|
||||
, shipPos = pos
|
||||
}
|
||||
) (zip (ships sd) posrots)
|
||||
nplanets = map (\(ball, (pos, rot)) ->
|
||||
) (zip ships posrots)
|
||||
modifyTVar (oplanets sd) $ \oplanets ->
|
||||
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)
|
||||
) (zip oplanets posrots2)
|
||||
liftIO $ atomically $ do
|
||||
ind <- readTVar (focusIndex sd)
|
||||
nplanets <- readTVar (oplanets sd)
|
||||
planet <- readTVar (planet sd)
|
||||
cam <- readTVar (camera sd)
|
||||
writeTVar (camera sd) cam
|
||||
{ cameraFocus = shipPos ((planet : nplanets) !! ind)
|
||||
}
|
||||
}
|
||||
|
||||
draw :: Affection StateData ()
|
||||
draw = do
|
||||
draw :: StateData -> Affection ()
|
||||
draw sd = do
|
||||
GL.viewport $= (GL.Position 0 0, GL.Size 1920 1080)
|
||||
StateData{..} <- getAffection
|
||||
(planet, oplanets, ships, program, program2) <- liftIO $ do
|
||||
p <- readTVarIO $ planet sd
|
||||
o <- readTVarIO $ oplanets sd
|
||||
s <- readTVarIO $ ships sd
|
||||
pr <- readTVarIO $ program sd
|
||||
pr2 <- readTVarIO $ program2 sd
|
||||
return (p, o, s, pr, pr2)
|
||||
drawThings program (planet : ships)
|
||||
-- drawThings program (ships)
|
||||
drawThings program2 oplanets
|
||||
where
|
||||
drawThings prog ts = do
|
||||
StateData{..} <- getAffection
|
||||
(camera, proj, program) <- liftIO $ do
|
||||
cam <- readTVarIO (camera sd)
|
||||
p <- readTVarIO (proj sd)
|
||||
program <- readTVarIO (program sd)
|
||||
return (cam, p, program)
|
||||
GL.currentProgram $= (Just . GLU.program $ prog)
|
||||
mapM_ (\Ship{..} -> do
|
||||
let view = lookAt
|
||||
|
|
@ -161,62 +181,52 @@ draw = do
|
|||
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
|
||||
) ts
|
||||
|
||||
handle :: SDL.EventPayload -> Affection StateData ()
|
||||
handle (SDL.WindowClosedEvent _) = quit
|
||||
handle :: StateData -> SDL.EventPayload -> Affection ()
|
||||
handle sd (SDL.WindowClosedEvent _) = quit sd
|
||||
|
||||
handle (SDL.KeyboardEvent dat) = do
|
||||
handle sd (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
|
||||
handleKey sd key
|
||||
handle sd (SDL.MouseMotionEvent dat) = do
|
||||
let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
|
||||
c = camera sd
|
||||
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}
|
||||
[] ->
|
||||
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 = nrot
|
||||
}
|
||||
_ ->
|
||||
c
|
||||
}
|
||||
liftIO $ atomically $ modifyTVar (camera sd) $ \c ->
|
||||
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}
|
||||
[] ->
|
||||
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 = nrot
|
||||
}
|
||||
_ ->
|
||||
c
|
||||
|
||||
handle _ = return ()
|
||||
handle _ _ = return ()
|
||||
|
||||
handleKey :: SDL.Keycode -> Affection StateData ()
|
||||
handleKey code
|
||||
handleKey :: StateData -> SDL.Keycode -> Affection ()
|
||||
handleKey sd code
|
||||
| code == SDL.KeycodeTab = do
|
||||
ud <- getAffection
|
||||
let ind = focusIndex ud
|
||||
ps = planet ud : oplanets ud
|
||||
-- ps = oplanets ud
|
||||
if ind + 1 < length ps
|
||||
then putAffection ud
|
||||
{ focusIndex = ind + 1
|
||||
}
|
||||
else putAffection ud
|
||||
{ focusIndex = 0
|
||||
}
|
||||
ps <- liftIO ((:) <$> readTVarIO (planet sd) <*> readTVarIO (oplanets sd))
|
||||
liftIO $ atomically $ modifyTVar (focusIndex sd) $ \ind ->
|
||||
if ind + 1 < length ps
|
||||
then ind + 1
|
||||
else 0
|
||||
| code == SDL.KeycodeR =
|
||||
GL.clearColor $= GL.Color4 1 0 0 1
|
||||
| code == SDL.KeycodeG =
|
||||
|
|
@ -230,12 +240,12 @@ handleKey code
|
|||
a <- liftIO $ randomRIO (0, 1)
|
||||
GL.clearColor $= GL.Color4 r g b a
|
||||
| code == SDL.KeycodeEscape =
|
||||
quit
|
||||
quit sd
|
||||
| code == SDL.KeycodeF = do
|
||||
dt <- deltaTime <$> get
|
||||
liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
|
||||
| code == SDL.KeycodeT =
|
||||
toggleScreen
|
||||
toggleScreen 0
|
||||
| code `elem`
|
||||
[ SDL.KeycodeW
|
||||
, SDL.KeycodeS
|
||||
|
|
@ -245,9 +255,8 @@ handleKey code
|
|||
, SDL.KeycodeE
|
||||
]
|
||||
= do
|
||||
sd <- getAffection
|
||||
let ship = head (ships sd)
|
||||
rot = shipRot ship
|
||||
ship <- head <$> liftIO (readTVarIO $ ships sd)
|
||||
let rot = shipRot ship
|
||||
dphi = pi / 2 / 45
|
||||
nquat = case code of
|
||||
SDL.KeycodeW -> rot * axisAngle (V3 1 0 0) (-dphi)
|
||||
|
|
@ -257,10 +266,9 @@ handleKey code
|
|||
SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi)
|
||||
SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi
|
||||
_ -> rot
|
||||
putAffection sd
|
||||
{ ships = ship
|
||||
liftIO $ atomically $ modifyTVar (ships sd) $ \ships ->
|
||||
ship
|
||||
{ shipRot = nquat
|
||||
} : tail (ships sd)
|
||||
}
|
||||
} : tail ships
|
||||
| otherwise =
|
||||
return ()
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@ module Types where
|
|||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.GLUtil as GLU
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
|
||||
import Linear as L
|
||||
|
||||
import SpatialMath
|
||||
|
|
@ -10,16 +12,17 @@ import SpatialMath
|
|||
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
|
||||
{ ships :: TVar [Ship]
|
||||
, planet :: TVar Ship
|
||||
, oplanets :: TVar [Ship]
|
||||
, camera :: TVar Camera
|
||||
, proj :: TVar (M44 Float)
|
||||
, program :: TVar GLU.ShaderProgram
|
||||
, program2 :: TVar GLU.ShaderProgram
|
||||
, physics :: TVar Physics
|
||||
, physicsObjects :: TVar PhysicsObjects
|
||||
, focusIndex :: TVar Int
|
||||
, nextStep :: TVar Bool
|
||||
}
|
||||
|
||||
data Ship = Ship
|
||||
|
|
|
|||
4
hw.cabal
4
hw.cabal
|
|
@ -80,6 +80,7 @@ executable example00
|
|||
, vector
|
||||
, wavefront
|
||||
, shoot
|
||||
, stm
|
||||
else
|
||||
buildable: False
|
||||
hs-source-dirs: examples/example00
|
||||
|
|
@ -137,8 +138,9 @@ executable example02
|
|||
, GLUtil
|
||||
, random
|
||||
, vector
|
||||
, wavefront >= 0.7.1.2
|
||||
, wavefront
|
||||
, shoot
|
||||
, stm
|
||||
hs-source-dirs: examples/example02
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
|
|
|||
Loading…
Reference in a new issue