From 27d78735956d0558000d475f72a3de1caed47478 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 16 May 2014 22:05:27 +0200 Subject: [PATCH 1/2] reworked Types to support STM - deadlocks somewhere... --- src/Main.hs | 67 ++++++++++++++++++++++++++------------------ src/Render/Render.hs | 13 +++++---- src/Types.hs | 6 ++-- src/UI/Callbacks.hs | 19 +++++++++---- 4 files changed, 64 insertions(+), 41 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0a7e867..e5f9328 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,8 +12,8 @@ import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) -import Control.Concurrent.STM (TQueue, - newTQueueIO) +import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) +import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -94,16 +94,26 @@ main = --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 --TTF.setFontStyle font TTFNormal --TTF.setFontHinting font TTFHNormal - - glHud' <- initHud - let zDistClosest' = 2 - zDistFarthest' = zDistClosest' + 10 - --TODO: Move near/far/fov to state for runtime-changability & central storage + let fov = 90 --field of view near = 1 --near plane far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio + cam' <- newTMVarIO CameraState + { _xAngle = pi/6 + , _yAngle = pi/2 + , _zDist = 10 + , _frustum = frust + , _camObject = createFlatCam 25 25 curMap + } + game' <- newTMVarIO GameState + { _currentMap = curMap + } + glHud' <- initHud + let zDistClosest' = 2 + zDistFarthest' = zDistClosest' + 10 + --TODO: Move near/far/fov to state for runtime-changability & central storage (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False @@ -123,17 +133,11 @@ main = , _height = fbHeight , _shouldClose = False } - , _camera = CameraState - { _xAngle = pi/6 - , _yAngle = pi/2 - , _zDist = 10 - , _frustum = frust - , _camObject = createFlatCam 25 25 curMap - } , _io = IOState { _clock = now , _tessClockFactor = 0 } + , _camera = cam' , _mouse = MouseState { _isDown = False , _isDragging = False @@ -155,9 +159,7 @@ main = , _glRenderbuffer = renderBuffer , _glFramebuffer = frameBuffer } - , _game = GameState - { _currentMap = curMap - } + , _game = game' , _ui = UIState { _uiHasChanged = True , _uiMap = guiMap @@ -207,20 +209,26 @@ run = do | otherwise = newYAngle' newYAngle' = sodya + myrot/100 - modify $ ((camera.xAngle) .~ newXAngle) - . ((camera.yAngle) .~ newYAngle) + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam + putTMVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement - let - multc = cos $ state ^. camera.yAngle - mults = sin $ state ^. camera.yAngle - modx x' = x' - 0.2 * kxrot * multc - - 0.2 * kyrot * mults - mody y' = y' + 0.2 * kxrot * mults - - 0.2 * kyrot * multc - modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap)) + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + game' <- readTMVar (state ^. game) + let + multc = cos $ cam ^. yAngle + mults = sin $ cam ^. yAngle + modx x' = x' - 0.2 * kxrot * multc + - 0.2 * kyrot * mults + mody y' = y' + 0.2 * kxrot * mults + - 0.2 * kyrot * multc + cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam + putTMVar (state ^. camera) cam' {- --modify the state with all that happened in mt time. @@ -290,7 +298,10 @@ adjustWindow = do ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) - modify $ camera.frustum .~ frust + liftIO $ atomically $ do + cam <- readTMVar (state ^. camera) + cam' <- return $ frustum .~ frust $ cam + putTMVar (state ^. camera) cam' rb <- liftIO $ do -- bind ints to CInt for lateron. let fbCWidth = (fromInteger.toInteger) fbWidth diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 7863ceb..ee91b27 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -12,6 +12,8 @@ import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) import qualified Control.Monad.RWS.Strict as RWS (get) +import Control.Concurrent.STM.TMVar (readTMVar) +import Control.Concurrent.STM (atomically) import Data.Distributive (distribute, collect) -- FFI import Foreign (Ptr, castPtr, with) @@ -364,11 +366,12 @@ drawMap = do render :: Pioneers () render = do state <- RWS.get - let xa = state ^. camera.xAngle - ya = state ^. camera.yAngle - frust = state ^. camera.Types.frustum - camPos = state ^. camera.camObject - zDist' = state ^. camera.zDist + cam <- liftIO $ atomically $ readTMVar (state ^. camera) + let xa = cam ^. xAngle + ya = cam ^. yAngle + frust = cam ^. Types.frustum + camPos = cam ^. camObject + zDist' = cam ^. zDist d = state ^. gl.glMap.mapShaderData (UniformLocation proj) = shdrProjMatIndex d (UniformLocation nmat) = shdrNormalMatIndex d diff --git a/src/Types.hs b/src/Types.hs index 75932ea..c722d11 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue) +import Control.Concurrent.STM (TQueue, TMVar) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -161,12 +161,12 @@ data UIState = UIState data State = State { _window :: !WindowState - , _camera :: !CameraState + , _camera :: TMVar CameraState , _io :: !IOState , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState - , _game :: !GameState + , _game :: TMVar GameState , _ui :: !UIState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 31d5a73..9ce6cc5 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -13,6 +13,8 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL +import Control.Concurrent.STM.TMVar (readTMVar, takeTMVar, putTMVar) +import Control.Concurrent.STM (atomically) import Render.Misc (curb,genColorData) @@ -105,11 +107,13 @@ eventCallback e = do state <- get if state ^. mouse.isDown && not (state ^. mouse.isDragging) then + do + cam <- liftIO $ atomically $ readTMVar (state ^. camera) modify $ (mouse.isDragging .~ True) . (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartY .~ fromIntegral y) - . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) - . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) + . (mouse.dragStartXAngle .~ (cam ^. xAngle)) + . (mouse.dragStartYAngle .~ (cam ^. yAngle)) else mouseMoveHandler (x, y) modify $ (mouse.mousePosition. Types._x .~ fromIntegral x) . (mouse.mousePosition. Types._y .~ fromIntegral y) @@ -134,8 +138,13 @@ eventCallback e = do SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do state <- get - let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in - modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' + liftIO $ atomically $ do + cam <- takeTMVar (state ^. camera) + let zDist' = (cam ^. zDist) + realToFrac (negate vscroll) + zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' + cam' <- return $ zDist .~ zDist'' $ cam + putTMVar (state ^. camera) cam' + -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] @@ -340,4 +349,4 @@ copyGUI tex (vX, vY) widget = do mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? \ No newline at end of file +--TODO: Maybe queues are better? From 230e31bf635690103e19222b4a25cdce04b1d27b Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 12:57:49 +0200 Subject: [PATCH 2/2] changed TMVar to TVar - compiles & runs again --- src/Main.hs | 20 ++++++++++---------- src/Render/Render.hs | 4 ++-- src/Types.hs | 6 +++--- src/UI/Callbacks.hs | 8 ++++---- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index e5f9328..f4d401c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -13,7 +13,7 @@ import Control.Arrow ((***)) -- data consistency/conversion import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) -import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar) +import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -100,14 +100,14 @@ main = far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio - cam' <- newTMVarIO CameraState + cam' <- newTVarIO CameraState { _xAngle = pi/6 , _yAngle = pi/2 , _zDist = 10 , _frustum = frust , _camObject = createFlatCam 25 25 curMap } - game' <- newTMVarIO GameState + game' <- newTVarIO GameState { _currentMap = curMap } glHud' <- initHud @@ -210,16 +210,16 @@ run = do newYAngle' = sodya + myrot/100 liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) + cam <- readTVar (state ^. camera) cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) - game' <- readTMVar (state ^. game) + cam <- readTVar (state ^. camera) + game' <- readTVar (state ^. game) let multc = cos $ cam ^. yAngle mults = sin $ cam ^. yAngle @@ -228,7 +228,7 @@ run = do mody y' = y' + 0.2 * kxrot * mults - 0.2 * kyrot * multc cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' {- --modify the state with all that happened in mt time. @@ -299,9 +299,9 @@ adjustWindow = do frust = createFrustum fov near far ratio liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) liftIO $ atomically $ do - cam <- readTMVar (state ^. camera) + cam <- readTVar (state ^. camera) cam' <- return $ frustum .~ frust $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' rb <- liftIO $ do -- bind ints to CInt for lateron. let fbCWidth = (fromInteger.toInteger) fbWidth diff --git a/src/Render/Render.hs b/src/Render/Render.hs index ee91b27..59fe4ed 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -12,7 +12,7 @@ import qualified Linear as L import Control.Lens ((^.)) import Control.Monad.RWS.Strict (liftIO) import qualified Control.Monad.RWS.Strict as RWS (get) -import Control.Concurrent.STM.TMVar (readTMVar) +import Control.Concurrent.STM.TVar (readTVarIO) import Control.Concurrent.STM (atomically) import Data.Distributive (distribute, collect) -- FFI @@ -366,7 +366,7 @@ drawMap = do render :: Pioneers () render = do state <- RWS.get - cam <- liftIO $ atomically $ readTMVar (state ^. camera) + cam <- liftIO $ readTVarIO (state ^. camera) let xa = cam ^. xAngle ya = cam ^. yAngle frust = cam ^. Types.frustum diff --git a/src/Types.hs b/src/Types.hs index c722d11..cbdba50 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue, TMVar) +import Control.Concurrent.STM (TQueue, TVar) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -161,12 +161,12 @@ data UIState = UIState data State = State { _window :: !WindowState - , _camera :: TMVar CameraState + , _camera :: TVar CameraState , _io :: !IOState , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState - , _game :: TMVar GameState + , _game :: TVar GameState , _ui :: !UIState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 9ce6cc5..6b5d7f3 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -13,7 +13,7 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL -import Control.Concurrent.STM.TMVar (readTMVar, takeTMVar, putTMVar) +import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar) import Control.Concurrent.STM (atomically) @@ -108,7 +108,7 @@ eventCallback e = do if state ^. mouse.isDown && not (state ^. mouse.isDragging) then do - cam <- liftIO $ atomically $ readTMVar (state ^. camera) + cam <- liftIO $ readTVarIO (state ^. camera) modify $ (mouse.isDragging .~ True) . (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartY .~ fromIntegral y) @@ -139,11 +139,11 @@ eventCallback e = do do state <- get liftIO $ atomically $ do - cam <- takeTMVar (state ^. camera) + cam <- readTVar (state ^. camera) let zDist' = (cam ^. zDist) + realToFrac (negate vscroll) zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' cam' <- return $ zDist .~ zDist'' $ cam - putTMVar (state ^. camera) cam' + writeTVar (state ^. camera) cam' -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True