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 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
|
||||||
|
|
|
@ -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,49 +73,49 @@ 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
|
|
||||||
{ camera =
|
|
||||||
case SDL.mouseMotionEventState dat of
|
case SDL.mouseMotionEventState dat of
|
||||||
[SDL.ButtonRight] ->
|
[SDL.ButtonRight] ->
|
||||||
let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
|
let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
|
||||||
|
@ -131,12 +141,11 @@ handle (SDL.MouseMotionEvent dat) = do
|
||||||
}
|
}
|
||||||
_ ->
|
_ ->
|
||||||
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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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,19 +181,16 @@ 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
|
|
||||||
{ camera =
|
|
||||||
case SDL.mouseMotionEventState dat of
|
case SDL.mouseMotionEventState dat of
|
||||||
-- [SDL.ButtonRight] ->
|
-- [SDL.ButtonRight] ->
|
||||||
-- let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
|
-- let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
|
||||||
|
@ -199,24 +216,17 @@ handle (SDL.MouseMotionEvent dat) = do
|
||||||
}
|
}
|
||||||
_ ->
|
_ ->
|
||||||
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
|
|
||||||
-- ps = oplanets ud
|
|
||||||
if ind + 1 < length ps
|
if ind + 1 < length ps
|
||||||
then putAffection ud
|
then ind + 1
|
||||||
{ focusIndex = ind + 1
|
else 0
|
||||||
}
|
|
||||||
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 ()
|
||||||
|
|
|
@ -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
4
hw.cabal
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue