reworked Types to support STM
- deadlocks somewhere...
This commit is contained in:
parent
2944d36703
commit
27d7873595
67
src/Main.hs
67
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
@ -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]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user