Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

reworked Types to support STM

Browse Source 
- deadlocks somewhere...
This commit is contained in:
Nicole Dresselhaus 2014-05-16 22:05:27 +02:00
parent 2944d36703
commit 27d7873595
No known key found for this signature in database
GPG Key ID: BC16D887851A1A80
4 changed files with 64 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
src/Main.hs
View File

@ -12,8 +12,8 @@ import Control.Arrow ((***))
-- data consistency/conversion -- data consistency/conversion
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue, import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
newTQueueIO) import Control.Concurrent.STM.TMVar (newTMVarIO, takeTMVar, putTMVar, readTMVar)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Data.Functor ((<$>)) import Data.Functor ((<$>))
@ -94,16 +94,26 @@ main =
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
--TTF.setFontStyle font TTFNormal --TTF.setFontStyle font TTFNormal
--TTF.setFontHinting font TTFHNormal --TTF.setFontHinting font TTFHNormal
let
glHud' <- initHud
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage
fov = 90 --field of view fov = 90 --field of view
near = 1 --near plane near = 1 --near plane
far = 500 --far plane far = 500 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio 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 (guiMap, guiRoots) = createGUI
aks = ArrowKeyState { aks = ArrowKeyState {
_up = False _up = False
@ -123,17 +133,11 @@ main =
, _height = fbHeight , _height = fbHeight
, _shouldClose = False , _shouldClose = False
} }
, _camera = CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25 curMap
}
, _io = IOState , _io = IOState
{ _clock = now { _clock = now
, _tessClockFactor = 0 , _tessClockFactor = 0
} }
, _camera = cam'
, _mouse = MouseState , _mouse = MouseState
{ _isDown = False { _isDown = False
, _isDragging = False , _isDragging = False
@ -155,9 +159,7 @@ main =
, _glRenderbuffer = renderBuffer , _glRenderbuffer = renderBuffer
, _glFramebuffer = frameBuffer , _glFramebuffer = frameBuffer
} }
, _game = GameState , _game = game'
{ _currentMap = curMap
}
, _ui = UIState , _ui = UIState
{ _uiHasChanged = True { _uiHasChanged = True
, _uiMap = guiMap , _uiMap = guiMap
@ -207,20 +209,26 @@ run = do
| otherwise = newYAngle' | otherwise = newYAngle'
newYAngle' = sodya + myrot/100 newYAngle' = sodya + myrot/100
modify $ ((camera.xAngle) .~ newXAngle) liftIO $ atomically $ do
. ((camera.yAngle) .~ newYAngle) cam <- takeTMVar (state ^. camera)
cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
putTMVar (state ^. camera) cam'
-- get cursor-keys - if pressed -- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle --TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
let liftIO $ atomically $ do
multc = cos $ state ^. camera.yAngle cam <- takeTMVar (state ^. camera)
mults = sin $ state ^. camera.yAngle game' <- readTMVar (state ^. game)
modx x' = x' - 0.2 * kxrot * multc let
- 0.2 * kyrot * mults multc = cos $ cam ^. yAngle
mody y' = y' + 0.2 * kxrot * mults mults = sin $ cam ^. yAngle
- 0.2 * kyrot * multc modx x' = x' - 0.2 * kxrot * multc
modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap)) - 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. --modify the state with all that happened in mt time.
@ -290,7 +298,10 @@ adjustWindow = do
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio frust = createFrustum fov near far ratio
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) 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 rb <- liftIO $ do
-- bind ints to CInt for lateron. -- bind ints to CInt for lateron.
let fbCWidth = (fromInteger.toInteger) fbWidth let fbCWidth = (fromInteger.toInteger) fbWidth

13
src/Render/Render.hs
View File

@ -12,6 +12,8 @@ import qualified Linear as L
import Control.Lens ((^.)) import Control.Lens ((^.))
import Control.Monad.RWS.Strict (liftIO) import Control.Monad.RWS.Strict (liftIO)
import qualified Control.Monad.RWS.Strict as RWS (get) 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) import Data.Distributive (distribute, collect)
-- FFI -- FFI
import Foreign (Ptr, castPtr, with) import Foreign (Ptr, castPtr, with)
@ -364,11 +366,12 @@ drawMap = do
render :: Pioneers () render :: Pioneers ()
render = do render = do
state <- RWS.get state <- RWS.get
let xa = state ^. camera.xAngle cam <- liftIO $ atomically $ readTMVar (state ^. camera)
ya = state ^. camera.yAngle let xa = cam ^. xAngle
frust = state ^. camera.Types.frustum ya = cam ^. yAngle
camPos = state ^. camera.camObject frust = cam ^. Types.frustum
zDist' = state ^. camera.zDist camPos = cam ^. camObject
zDist' = cam ^. zDist
d = state ^. gl.glMap.mapShaderData d = state ^. gl.glMap.mapShaderData
(UniformLocation proj) = shdrProjMatIndex d (UniformLocation proj) = shdrProjMatIndex d
(UniformLocation nmat) = shdrNormalMatIndex d (UniformLocation nmat) = shdrNormalMatIndex d

6
src/Types.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Types where module Types where
import Control.Concurrent.STM (TQueue) import Control.Concurrent.STM (TQueue, TMVar)
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.UI.SDL as SDL (Event, Window) import Graphics.UI.SDL as SDL (Event, Window)
import Foreign.C (CFloat) import Foreign.C (CFloat)
@ -161,12 +161,12 @@ data UIState = UIState
data State = State data State = State
{ _window :: !WindowState { _window :: !WindowState
, _camera :: !CameraState , _camera :: TMVar CameraState
, _io :: !IOState , _io :: !IOState
, _mouse :: !MouseState , _mouse :: !MouseState
, _keyboard :: !KeyboardState , _keyboard :: !KeyboardState
, _gl :: !GLState , _gl :: !GLState
, _game :: !GameState , _game :: TMVar GameState
, _ui :: !UIState , _ui :: !UIState
} }

19
src/UI/Callbacks.hs
View File

@ -13,6 +13,8 @@ import Data.Maybe
import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL 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) import Render.Misc (curb,genColorData)
@ -105,11 +107,13 @@ eventCallback e = do
state <- get state <- get
if state ^. mouse.isDown && not (state ^. mouse.isDragging) if state ^. mouse.isDown && not (state ^. mouse.isDragging)
then then
do
cam <- liftIO $ atomically $ readTMVar (state ^. camera)
modify $ (mouse.isDragging .~ True) modify $ (mouse.isDragging .~ True)
. (mouse.dragStartX .~ fromIntegral x) . (mouse.dragStartX .~ fromIntegral x)
. (mouse.dragStartY .~ fromIntegral y) . (mouse.dragStartY .~ fromIntegral y)
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) . (mouse.dragStartXAngle .~ (cam ^. xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) . (mouse.dragStartYAngle .~ (cam ^. yAngle))
else mouseMoveHandler (x, y) else mouseMoveHandler (x, y)
modify $ (mouse.mousePosition. Types._x .~ fromIntegral x) modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
. (mouse.mousePosition. Types._y .~ fromIntegral y) . (mouse.mousePosition. Types._y .~ fromIntegral y)
@ -134,8 +138,13 @@ eventCallback e = do
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do do
state <- get state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in liftIO $ atomically $ do
modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' 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 -- there is more (joystic, touchInterface, ...), but currently ignored
SDL.Quit -> modify $ window.shouldClose .~ True SDL.Quit -> modify $ window.shouldClose .~ True
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] _ -> 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 mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
--TODO: Maybe queues are better? --TODO: Maybe queues are better?