From 9e131581411758a43eb9221278171ac946795c8d Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 11 Sep 2021 00:15:31 +0200 Subject: [PATCH] modernize some examples --- examples/example00/Init.hs | 20 ++-- examples/example00/Main.hs | 154 +++++++++++++++-------------- examples/example00/Types.hs | 15 +-- examples/example02/Init.hs | 28 +++--- examples/example02/Main.hs | 186 +++++++++++++++++++----------------- examples/example02/Types.hs | 23 +++-- hw.cabal | 4 +- 7 files changed, 229 insertions(+), 201 deletions(-) diff --git a/examples/example00/Init.hs b/examples/example00/Init.hs index 97285f1..1177f68 100644 --- a/examples/example00/Init.hs +++ b/examples/example00/Init.hs @@ -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 diff --git a/examples/example00/Main.hs b/examples/example00/Main.hs index 9579fad..8cac8bc 100644 --- a/examples/example00/Main.hs +++ b/examples/example00/Main.hs @@ -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 () diff --git a/examples/example00/Types.hs b/examples/example00/Types.hs index f7c239b..81b887a 100644 --- a/examples/example00/Types.hs +++ b/examples/example00/Types.hs @@ -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 diff --git a/examples/example02/Init.hs b/examples/example02/Init.hs index e824ef5..3b03ce2 100644 --- a/examples/example02/Init.hs +++ b/examples/example02/Init.hs @@ -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 diff --git a/examples/example02/Main.hs b/examples/example02/Main.hs index 0a58849..aa1f84a 100644 --- a/examples/example02/Main.hs +++ b/examples/example02/Main.hs @@ -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 () diff --git a/examples/example02/Types.hs b/examples/example02/Types.hs index f2a281a..d81f539 100644 --- a/examples/example02/Types.hs +++ b/examples/example02/Types.hs @@ -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 diff --git a/hw.cabal b/hw.cabal index f7365b4..5c45765 100644 --- a/hw.cabal +++ b/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