From 27d78735956d0558000d475f72a3de1caed47478 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Fri, 16 May 2014 22:05:27 +0200 Subject: [PATCH] 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?