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

Merge branch 'STM'

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-05-17 12:58:23 +02:00
commit 35364b50aa
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
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue,
newTQueueIO)
import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar)
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' <- newTVarIO CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25 curMap
}
game' <- newTVarIO 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 <- readTVar (state ^. camera)
cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
writeTVar (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 <- readTVar (state ^. camera)
game' <- readTVar (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
writeTVar (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 <- readTVar (state ^. camera)
cam' <- return $ frustum .~ frust $ cam
writeTVar (state ^. camera) cam'
rb <- liftIO $ do
-- bind ints to CInt for lateron.
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.Monad.RWS.Strict (liftIO)
import qualified Control.Monad.RWS.Strict as RWS (get)
import Control.Concurrent.STM.TVar (readTVarIO)
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 $ readTVarIO (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

6
src/Types.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
module Types where
import Control.Concurrent.STM (TQueue)
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 :: !CameraState
, _camera :: TVar CameraState
, _io :: !IOState
, _mouse :: !MouseState
, _keyboard :: !KeyboardState
, _gl :: !GLState
, _game :: !GameState
, _game :: TVar GameState
, _ui :: !UIState
}

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.TVar (readTVar, readTVarIO, writeTVar)
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 $ readTVarIO (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 <- readTVar (state ^. camera)
let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
cam' <- return $ zDist .~ zDist'' $ cam
writeTVar (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?