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:
Stefan Dresselhaus
2014-05-16 22:05:27 +02:00
parent 2944d36703
commit 27d7873595
4 changed files with 64 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
src/UI/Callbacks.hs
View File

@ -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?
--TODO: Maybe queues are better?