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

modernize some examples

Browse source
This commit is contained in:
nek0 2021-09-11 00:15:31 +02:00
parent 69a951fd28
commit 9e13158141
7 changed files with 229 additions and 201 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
examples/example00/Init.hs
View file

@ -5,6 +5,8 @@ module Init where
import SDL (($=)) import SDL (($=))
import qualified SDL import qualified SDL
import Control.Concurrent.STM
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU import qualified Graphics.GLUtil as GLU
@ -111,18 +113,18 @@ load = do
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBalls po) mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBalls po)
addRigidBody (pWorld phys) (bodyRigidBody $ poGround po) addRigidBody (pWorld phys) (bodyRigidBody $ poGround po)
return StateData StateData
{ ships = shipList <$> newTVarIO shipList
, proj = perspective (pi/2) (1600 / 900) 1 (-1) <*> newTVarIO (Camera
, camera = Camera
{ cameraFocus = V3 0 0 0 { cameraFocus = V3 0 0 0
, cameraRot = Euler 0 0 0 , cameraRot = Euler 0 0 0
, cameraDist = -50 , cameraDist = -50
} })
, program = p <*> newTVarIO (perspective (pi/2) (1600 / 900) 1 (-1))
, physics = phys <*> newTVarIO p
, physicsObjects = po <*> newTVarIO phys
} <*> newTVarIO po
<*> newTVarIO True
loadTex :: FilePath -> IO GL.TextureObject loadTex :: FilePath -> IO GL.TextureObject
loadTex f = do loadTex f = do

154
examples/example00/Main.hs
View file

@ -12,6 +12,9 @@ import qualified Graphics.GLUtil as GLU
import Physics.Bullet.Raw import Physics.Bullet.Raw
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -28,7 +31,7 @@ import Debug.Trace as T
main :: IO () main :: IO ()
main = main =
withAffection AffectionConfig withAffection (AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "hw" , windowTitle = "hw"
, windowConfigs = , windowConfigs =
@ -36,26 +39,33 @@ main =
, SDL.defaultWindow , SDL.defaultWindow
{ SDL.windowInitialSize = SDL.V2 1600 900 { SDL.windowInitialSize = SDL.V2 1600 900
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL , 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 } :: AffectionConfig StateData)
, preLoop = return ()
, eventLoop = mapM_ handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = const (return ())
, canvasSize = Nothing
}
update :: Double -> Affection StateData () instance Affectionate StateData where
update dt = do loadState = load
sd <- getAffection 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 let phys = physics sd
physos = physicsObjects sd physos = physicsObjects sd
(phys, physos) <- liftIO $ atomically $
(,)
<$> readTVar (physics sd)
<*> readTVar (physicsObjects sd)
liftIO $ stepSimulation (pWorld phys) dt 10 Nothing liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
posrots <- mapM ((\ball -> do posrots <- mapM ((\ball -> do
ms <- liftIO $ getMotionState ball ms <- liftIO $ getMotionState ball
@ -63,80 +73,79 @@ update dt = do
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
return (npos, nrot)) return (npos, nrot))
. bodyRigidBody) (poBalls physos) . bodyRigidBody) (poBalls physos)
let nships = map (\(ship, (pos, rot)) -> let nships shipss = map (\(ship, (pos, rot)) ->
ship ship
{ shipRot = rot { shipRot = rot
, shipPos = pos , shipPos = pos
} }
) (zip (ships sd) posrots) ) (zip shipss posrots)
putAffection sd liftIO $ atomically $ modifyTVar (ships sd) $ \shs -> nships shs
{ ships = nships
}
draw :: Affection StateData () draw :: StateData -> Affection ()
draw = do 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) GL.viewport $= (GL.Position 0 0, GL.Size 1600 900)
StateData{..} <- getAffection
GL.currentProgram $= (Just . GLU.program $ program) GL.currentProgram $= (Just . GLU.program $ program)
mapM_ (\Ship{..} -> do mapM_ (\Ship{..} -> do
let view = lookAt let view = lookAt
(cameraFocus camera + (cameraFocus cam +
rotVecByEulerB2A rotVecByEulerB2A
(cameraRot camera) (cameraRot cam)
(V3 0 0 (-cameraDist camera))) (V3 0 0 (-cameraDist cam)))
(cameraFocus camera) (cameraFocus cam)
(V3 0 1 0) (V3 0 1 0)
model = mkTransformation shipRot shipPos model = mkTransformation shipRot shipPos
pvm = proj !*! view !*! model pvm = p !*! view !*! model
liftIO $ GLU.setUniform program "mvp" pvm liftIO $ GLU.setUniform program "mvp" pvm
GL.bindVertexArrayObject $= Just shipVao GL.bindVertexArrayObject $= Just shipVao
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen) liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
) ships ) ships
handle :: SDL.EventPayload -> Affection StateData () handle :: StateData -> SDL.EventPayload -> Affection ()
handle (SDL.WindowClosedEvent _) = quit handle sd (SDL.WindowClosedEvent _) = quit sd
handle (SDL.KeyboardEvent dat) = do handle sd (SDL.KeyboardEvent dat) = do
let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat) let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat)
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
handleKey key handleKey sd key
handle (SDL.MouseMotionEvent dat) = do handle sd (SDL.MouseMotionEvent dat) = do
sd <- getAffection
let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
c = camera sd liftIO $ atomically $ modifyTVar (camera sd) $ \c ->
putAffection sd case SDL.mouseMotionEventState dat of
{ camera = [SDL.ButtonRight] ->
case SDL.mouseMotionEventState dat of let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
[SDL.ButtonRight] -> in c {cameraFocus = cameraFocus c + V3 sx 0 sy}
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
let dphi = pi / 4 / 45 / 10 nangle
(Euler yaw pitch roll) = cameraRot c | nangle' >= qc = qc - mu
nangle | nangle' <= -qc = -qc + mu
| nangle' >= qc = qc - mu | otherwise = nangle'
| nangle' <= -qc = -qc + mu where
| otherwise = nangle' nangle' = (dphi * ry) + roll
where qc = pi / 2
nangle' = (dphi * ry) + roll mu = 0.01
qc = pi / 2 nrot =
mu = 0.01 Euler
nrot = yaw
Euler (pitch + (rx * dphi))
yaw nangle
(pitch + (rx * dphi)) in c
nangle { cameraRot = nrot
in c }
{ cameraRot = nrot _ ->
} c
_ ->
c
}
handle _ = return () handle _ _ = return ()
handleKey :: SDL.Keycode -> Affection StateData () handleKey :: StateData -> SDL.Keycode -> Affection ()
handleKey code handleKey sd code
| code == SDL.KeycodeR = | code == SDL.KeycodeR =
GL.clearColor $= GL.Color4 1 0 0 1 GL.clearColor $= GL.Color4 1 0 0 1
| code == SDL.KeycodeG = | code == SDL.KeycodeG =
@ -150,12 +159,12 @@ handleKey code
a <- liftIO $ randomRIO (0, 1) a <- liftIO $ randomRIO (0, 1)
GL.clearColor $= GL.Color4 r g b a GL.clearColor $= GL.Color4 r g b a
| code == SDL.KeycodeEscape = | code == SDL.KeycodeEscape =
quit quit sd
| code == SDL.KeycodeF = do | code == SDL.KeycodeF = do
dt <- deltaTime <$> get dt <- deltaTime <$> get
liftIO $ putStrLn $ show (1 / dt) ++ " FPS" liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
| code == SDL.KeycodeT = | code == SDL.KeycodeT =
toggleScreen toggleScreen 0
| code `elem` | code `elem`
[ SDL.KeycodeW [ SDL.KeycodeW
, SDL.KeycodeS , SDL.KeycodeS
@ -165,8 +174,8 @@ handleKey code
, SDL.KeycodeE , SDL.KeycodeE
] ]
= do = do
sd <- getAffection shipss <- liftIO $ atomically $ readTVar (ships sd)
let ship = head (ships sd) let ship = head shipss
rot = shipRot ship rot = shipRot ship
dphi = pi / 2 / 45 dphi = pi / 2 / 45
nquat = case code of nquat = case code of
@ -177,10 +186,9 @@ handleKey code
SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi) SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi)
SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi
_ -> rot _ -> rot
putAffection sd liftIO $ atomically $ modifyTVar (ships sd) $ \shipss ->
{ ships = ship ship
{ shipRot = nquat { shipRot = nquat
} : tail (ships sd) } : tail shipss
}
| otherwise = | otherwise =
return () return ()

15
examples/example00/Types.hs
View file

@ -9,13 +9,16 @@ import SpatialMath
import Physics.Bullet.Raw as Bullet import Physics.Bullet.Raw as Bullet
import Control.Concurrent.STM.TVar
data StateData = StateData data StateData = StateData
{ ships :: [Ship] { ships :: TVar [Ship]
, camera :: Camera , camera :: TVar Camera
, proj :: M44 Float , proj :: TVar (M44 Float)
, program :: GLU.ShaderProgram , program :: TVar GLU.ShaderProgram
, physics :: Physics , physics :: TVar Physics
, physicsObjects :: PhysicsObjects , physicsObjects :: TVar PhysicsObjects
, quitGame :: TVar Bool
} }
data Ship = Ship data Ship = Ship

28
examples/example02/Init.hs
View file

@ -5,6 +5,8 @@ module Init where
import SDL (($=)) import SDL (($=))
import qualified SDL import qualified SDL
import Control.Concurrent.STM.TVar
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU import qualified Graphics.GLUtil as GLU
@ -119,22 +121,22 @@ load = do
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po) mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po) addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)
return StateData StateData
{ ships = shipList <$> newTVarIO shipList
, planet = planet <*> newTVarIO planet
, oplanets = otherPlanets <*> newTVarIO otherPlanets
, proj = infinitePerspective (pi/2) (1600 / 900) 1 <*> newTVarIO (Camera
, camera = Camera
{ cameraFocus = V3 0 0 0 { cameraFocus = V3 0 0 0
, cameraRot = Euler 0 0 0 , cameraRot = Euler 0 0 0
, cameraDist = -100 , cameraDist = -100
} })
, program = p <*> newTVarIO (infinitePerspective (pi/2) (1600 / 900) 1)
, program2 = p2 <*> newTVarIO p
, physics = phys <*> newTVarIO p2
, physicsObjects = po <*> newTVarIO phys
, focusIndex = 0 <*> newTVarIO po
} <*> newTVarIO 0
<*> newTVarIO True
loadTex :: FilePath -> IO GL.TextureObject loadTex :: FilePath -> IO GL.TextureObject
loadTex f = do loadTex f = do

186
examples/example02/Main.hs
View file

@ -12,6 +12,9 @@ import qualified Graphics.GLUtil as GLU
import Physics.Bullet.Raw import Physics.Bullet.Raw
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -28,7 +31,7 @@ import Debug.Trace as T
main :: IO () main :: IO ()
main = main =
withAffection AffectionConfig withAffection (AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "hw - example 02" , windowTitle = "hw - example 02"
, windowConfigs = , windowConfigs =
@ -39,26 +42,29 @@ main =
{ SDL.glProfile = SDL.Core SDL.Normal 3 2 { SDL.glProfile = SDL.Core SDL.Normal 3 2
} }
} }
, SDL.FullscreenDesktop
) )
] ]
, initScreenMode = SDL.FullscreenDesktop } :: AffectionConfig StateData)
, preLoop = return ()
, eventLoop = mapM_ handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = const (return ())
, canvasSize = Nothing
}
update :: Double -> Affection StateData () instance Affectionate StateData where
update dt = do preLoop = const (return ())
sd <- getAffection handleEvents sd = mapM_(handle sd)
let phys = physics sd update = Main.update
physos = physicsObjects sd draw = Main.draw
g = 0.0667300 loadState = load
-- g = 0.0000000000667300 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 mapM_ (\smallBall -> do
ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall) ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
ms2 <- liftIO $ getMotionState (bodyRigidBody $ poBigBall physos) ms2 <- liftIO $ getMotionState (bodyRigidBody $ poBigBall physos)
@ -115,36 +121,50 @@ update dt = do
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
return (npos, nrot)) return (npos, nrot))
. bodyRigidBody) (poBigBalls physos) . bodyRigidBody) (poBigBalls physos)
let nships = map (\(ship, (pos, rot)) -> liftIO $ atomically $ do
modifyTVar (ships sd) $ \ships ->
map (\(ship, (pos, rot)) ->
ship ship
{ shipRot = rot { shipRot = rot
, shipPos = pos , shipPos = pos
} }
) (zip (ships sd) posrots) ) (zip ships posrots)
nplanets = map (\(ball, (pos, rot)) -> modifyTVar (oplanets sd) $ \oplanets ->
map (\(ball, (pos, rot)) ->
ball ball
{ shipRot = rot { shipRot = rot
, shipPos = pos , shipPos = pos
} }
) (zip (oplanets sd) posrots2) ) (zip oplanets posrots2)
putAffection sd liftIO $ atomically $ do
{ ships = nships ind <- readTVar (focusIndex sd)
, oplanets = nplanets nplanets <- readTVar (oplanets sd)
, camera = (camera sd) planet <- readTVar (planet sd)
{ cameraFocus = shipPos ((planet sd : nplanets) !! focusIndex sd) cam <- readTVar (camera sd)
writeTVar (camera sd) cam
{ cameraFocus = shipPos ((planet : nplanets) !! ind)
} }
}
draw :: Affection StateData () draw :: StateData -> Affection ()
draw = do draw sd = do
GL.viewport $= (GL.Position 0 0, GL.Size 1920 1080) 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 (planet : ships)
-- drawThings program (ships) -- drawThings program (ships)
drawThings program2 oplanets drawThings program2 oplanets
where where
drawThings prog ts = do 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) GL.currentProgram $= (Just . GLU.program $ prog)
mapM_ (\Ship{..} -> do mapM_ (\Ship{..} -> do
let view = lookAt let view = lookAt
@ -161,62 +181,52 @@ draw = do
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen) liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
) ts ) ts
handle :: SDL.EventPayload -> Affection StateData () handle :: StateData -> SDL.EventPayload -> Affection ()
handle (SDL.WindowClosedEvent _) = quit handle sd (SDL.WindowClosedEvent _) = quit sd
handle (SDL.KeyboardEvent dat) = do handle sd (SDL.KeyboardEvent dat) = do
let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat) let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat)
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
handleKey key handleKey sd key
handle (SDL.MouseMotionEvent dat) = do handle sd (SDL.MouseMotionEvent dat) = do
sd <- getAffection
let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
c = camera sd liftIO $ atomically $ modifyTVar (camera sd) $ \c ->
putAffection sd case SDL.mouseMotionEventState dat of
{ camera = -- [SDL.ButtonRight] ->
case SDL.mouseMotionEventState dat of -- let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
-- [SDL.ButtonRight] -> -- in c {cameraFocus = cameraFocus c + V3 sx 0 sy}
-- 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
let dphi = pi / 4 / 45 / 10 nangle
(Euler yaw pitch roll) = cameraRot c | nangle' >= qc = qc - mu
nangle | nangle' <= -qc = -qc + mu
| nangle' >= qc = qc - mu | otherwise = nangle'
| nangle' <= -qc = -qc + mu where
| otherwise = nangle' nangle' = (dphi * ry) + roll
where qc = pi / 2
nangle' = (dphi * ry) + roll mu = 0.01
qc = pi / 2 nrot =
mu = 0.01 Euler
nrot = yaw
Euler (pitch + (rx * dphi))
yaw nangle
(pitch + (rx * dphi)) in c
nangle { cameraRot = nrot
in c }
{ cameraRot = nrot _ ->
} c
_ ->
c
}
handle _ = return () handle _ _ = return ()
handleKey :: SDL.Keycode -> Affection StateData () handleKey :: StateData -> SDL.Keycode -> Affection ()
handleKey code handleKey sd code
| code == SDL.KeycodeTab = do | code == SDL.KeycodeTab = do
ud <- getAffection ps <- liftIO ((:) <$> readTVarIO (planet sd) <*> readTVarIO (oplanets sd))
let ind = focusIndex ud liftIO $ atomically $ modifyTVar (focusIndex sd) $ \ind ->
ps = planet ud : oplanets ud if ind + 1 < length ps
-- ps = oplanets ud then ind + 1
if ind + 1 < length ps else 0
then putAffection ud
{ focusIndex = ind + 1
}
else putAffection ud
{ focusIndex = 0
}
| code == SDL.KeycodeR = | code == SDL.KeycodeR =
GL.clearColor $= GL.Color4 1 0 0 1 GL.clearColor $= GL.Color4 1 0 0 1
| code == SDL.KeycodeG = | code == SDL.KeycodeG =
@ -230,12 +240,12 @@ handleKey code
a <- liftIO $ randomRIO (0, 1) a <- liftIO $ randomRIO (0, 1)
GL.clearColor $= GL.Color4 r g b a GL.clearColor $= GL.Color4 r g b a
| code == SDL.KeycodeEscape = | code == SDL.KeycodeEscape =
quit quit sd
| code == SDL.KeycodeF = do | code == SDL.KeycodeF = do
dt <- deltaTime <$> get dt <- deltaTime <$> get
liftIO $ putStrLn $ show (1 / dt) ++ " FPS" liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
| code == SDL.KeycodeT = | code == SDL.KeycodeT =
toggleScreen toggleScreen 0
| code `elem` | code `elem`
[ SDL.KeycodeW [ SDL.KeycodeW
, SDL.KeycodeS , SDL.KeycodeS
@ -245,9 +255,8 @@ handleKey code
, SDL.KeycodeE , SDL.KeycodeE
] ]
= do = do
sd <- getAffection ship <- head <$> liftIO (readTVarIO $ ships sd)
let ship = head (ships sd) let rot = shipRot ship
rot = shipRot ship
dphi = pi / 2 / 45 dphi = pi / 2 / 45
nquat = case code of nquat = case code of
SDL.KeycodeW -> rot * axisAngle (V3 1 0 0) (-dphi) 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.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi)
SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi
_ -> rot _ -> rot
putAffection sd liftIO $ atomically $ modifyTVar (ships sd) $ \ships ->
{ ships = ship ship
{ shipRot = nquat { shipRot = nquat
} : tail (ships sd) } : tail ships
}
| otherwise = | otherwise =
return () return ()

23
examples/example02/Types.hs
View file

@ -3,6 +3,8 @@ module Types where
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU import qualified Graphics.GLUtil as GLU
import Control.Concurrent.STM.TVar
import Linear as L import Linear as L
import SpatialMath import SpatialMath
@ -10,16 +12,17 @@ import SpatialMath
import Physics.Bullet.Raw as Bullet import Physics.Bullet.Raw as Bullet
data StateData = StateData data StateData = StateData
{ ships :: [Ship] { ships :: TVar [Ship]
, planet :: Ship , planet :: TVar Ship
, oplanets :: [Ship] , oplanets :: TVar [Ship]
, camera :: Camera , camera :: TVar Camera
, proj :: M44 Float , proj :: TVar (M44 Float)
, program :: GLU.ShaderProgram , program :: TVar GLU.ShaderProgram
, program2 :: GLU.ShaderProgram , program2 :: TVar GLU.ShaderProgram
, physics :: Physics , physics :: TVar Physics
, physicsObjects :: PhysicsObjects , physicsObjects :: TVar PhysicsObjects
, focusIndex :: Int , focusIndex :: TVar Int
, nextStep :: TVar Bool
} }
data Ship = Ship data Ship = Ship

4
hw.cabal
View file

@ -80,6 +80,7 @@ executable example00
, vector , vector
, wavefront , wavefront
, shoot , shoot
, stm
else else
buildable: False buildable: False
hs-source-dirs: examples/example00 hs-source-dirs: examples/example00
@ -137,8 +138,9 @@ executable example02
, GLUtil , GLUtil
, random , random
, vector , vector
, wavefront >= 0.7.1.2 , wavefront
, shoot , shoot
, stm
hs-source-dirs: examples/example02 hs-source-dirs: examples/example02
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall