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

Merge remote-tracking branch 'origin/ui' into iqm

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-07-07 15:23:13 +02:00
commit aedb5b5337
6 changed files with 101 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
src/Main.hs
View File

@ -14,7 +14,7 @@ import Control.Lens ((^.), (.~), (%~))
-- data consistency/conversion
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar)
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar, readTVarIO)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Data.Functor ((<$>))
@ -89,7 +89,8 @@ main = do
initRendering
--generate map vertices
curMap <- exportedMap
glMap' <- initMapShader 4 =<< getMapBufferObject curMap
(glMap', tex) <- initMapShader 4 =<< getMapBufferObject curMap
tex' <- newTVarIO tex
eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
now <- getCurrentTime
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
@ -111,7 +112,7 @@ main = do
game' <- newTVarIO GameState
{ _currentMap = curMap
}
camStack' <- newTVarIO Map.empty
let camStack' = Map.empty
glHud' <- initHud
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
@ -140,18 +141,8 @@ main = do
, _tessClockTime = now
}
, _camera = cam'
, _mapTexture = tex'
, _camStack = camStack'
, _mouse = MouseState
{ _isDragging = False
, _dragStartX = 0
, _dragStartY = 0
, _dragStartXAngle = 0
, _dragStartYAngle = 0
, _mousePosition = Types.Position
{ Types.__x = 5
, Types.__y = 5
}
}
, _keyboard = KeyboardState
{ _arrowsPressed = aks
}
@ -188,28 +179,6 @@ run = do
-- update State
state <- get
-- change in camera-angle
when (state ^. mouse.isDragging) $ do
let sodx = state ^. mouse.dragStartX
sody = state ^. mouse.dragStartY
sodxa = state ^. mouse.dragStartXAngle
sodya = state ^. mouse.dragStartYAngle
x' = state ^. mouse.mousePosition._x
y' = state ^. mouse.mousePosition._y
myrot = (x' - sodx) / 2
mxrot = (y' - sody) / 2
newXAngle = curb (pi/12) (0.45*pi) newXAngle'
newXAngle' = sodxa + mxrot/100
newYAngle
| newYAngle' > pi = newYAngle' - 2 * pi
| newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle'
newYAngle' = sodya + myrot/100
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
@ -241,7 +210,7 @@ run = do
targetFrametime = 1.0/targetFramerate
--targetFrametimeμs = targetFrametime * 1000000.0
now <- getCurrentTime
let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs
let diff = max 0.001 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
updatediff = diffUTCTime now (state ^. io.tessClockTime) -- get diff to last update
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
ddiff = double diff
@ -325,8 +294,8 @@ adjustWindow = do
let hudtexid = state ^. gl.glHud.hudTexture
maptexid = state ^. gl.glMap.renderedMapTexture
smaptexid = state ^. gl.glMap.shadowMapTexture
maptexid <- liftIO $ readTVarIO (state ^. mapTexture)
allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
--default to ugly pink to see if
--somethings go wrong.

15
src/Render/Render.hs
View File

@ -62,7 +62,7 @@ initBuffer varray =
initMapShader ::
Int -- ^ initial Tessallation-Factor
-> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor
-> IO GLMapState
-> IO (GLMapState, TextureObject)
initMapShader tessFac (buf, vertDes) = do
! vertexSource <- B.readFile mapVertexShaderFile
! tessControlSource <- B.readFile mapTessControlShaderFile
@ -210,11 +210,10 @@ initMapShader tessFac (buf, vertDes) = do
, shdrMOTessOuterIndex = UniformLocation 0 --tessLevelOuter'
}
return GLMapState
return (GLMapState
{ _mapProgram = program
, _mapShaderData = sdata
, _mapObjectShaderData = smodata
, _renderedMapTexture = tex
, _stateTessellationFactor = tessFac
, _stateMap = buf
, _mapVert = vertDes
@ -224,7 +223,7 @@ initMapShader tessFac (buf, vertDes) = do
, _mapObjects = objs
, _objectProgram = objProgram
, _shadowMapProgram = shadowProgram
}
}, tex)
initHud :: IO GLHud
initHud = do
@ -445,12 +444,13 @@ render = do
---- RENDER MAP IN TEXTURE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-- COLORMAP
textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
tex <- liftIO $ readTVarIO (state ^. mapTexture)
textureBinding Texture2D $= Just tex
framebufferTexture2D
Framebuffer
(ColorAttachment 0)
Texture2D
(state ^. gl.glMap.renderedMapTexture)
tex
0
-- Render to FrameBufferObject
@ -503,7 +503,8 @@ render = do
uniform (hud ^. hudTexIndex) $= Index1 (0::GLint)
activeTexture $= TextureUnit 1
textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
tex <- liftIO $ readTVarIO (state ^. mapTexture)
textureBinding Texture2D $= Just tex
uniform (hud ^. hudBackIndex) $= Index1 (1::GLint)
bindBuffer ArrayBuffer $= Just (hud ^. hudVBO)

21
src/Types.hs
View File

@ -11,7 +11,7 @@ import Linear.Matrix (M44)
import Linear (V3)
import Control.Monad.RWS.Strict (RWST, liftIO, get)
import Control.Monad.Writer.Strict
import Control.Monad (when)
--import Control.Monad (when)
import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types
@ -64,15 +64,6 @@ data GameState = GameState
{ _currentMap :: !PlayMap
}
data MouseState = MouseState
{ _isDragging :: !Bool
, _dragStartX :: !Double
, _dragStartY :: !Double
, _dragStartXAngle :: !Double
, _dragStartYAngle :: !Double
, _mousePosition :: !Position --TODO: Get rid of mouse-prefix
}
data ArrowKeyState = ArrowKeyState {
_up :: !Bool
,_down :: !Bool
@ -111,7 +102,6 @@ data GLMapState = GLMapState
, _stateMap :: !GL.BufferObject
, _mapVert :: !GL.NumArrayIndices
, _mapProgram :: !GL.Program
, _renderedMapTexture :: !TextureObject --TODO: Probably move to UI?
, _overviewTexture :: !TextureObject
, _shadowMapTexture :: !TextureObject
, _mapTextures :: ![TextureObject] --TODO: Fix size on list?
@ -174,8 +164,8 @@ data GLState = GLState
data UIState = UIState
{ _uiHasChanged :: !Bool
, _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers))
, _uiObserverEvents :: !(Map.HashMap EventKey [EventHandler Pioneers])
, _uiMap :: Map.HashMap UIId (GUIWidget Pioneers)
, _uiObserverEvents :: Map.HashMap EventKey [EventHandler Pioneers]
, _uiRoots :: !([UIId])
, _uiButtonState :: !UIButtonState
}
@ -183,9 +173,9 @@ data UIState = UIState
data State = State
{ _window :: !WindowState
, _camera :: TVar CameraState
, _camStack :: TVar (Map.HashMap UIId (CameraState, TextureObject))
, _mapTexture :: TVar TextureObject
, _camStack :: (Map.HashMap UIId (TVar CameraState, TVar TextureObject))
, _io :: !IOState
, _mouse :: !MouseState
, _keyboard :: !KeyboardState
, _gl :: !GLState
, _game :: TVar GameState
@ -208,7 +198,6 @@ $(makeLenses ''GLMapState)
$(makeLenses ''GLHud)
$(makeLenses ''KeyboardState)
$(makeLenses ''ArrowKeyState)
$(makeLenses ''MouseState)
$(makeLenses ''GameState)
$(makeLenses ''IOState)
$(makeLenses ''CameraState)

11
src/UI/Callbacks.hs
View File

@ -26,11 +26,12 @@ import UI.UIOperations
createGUI :: ScreenUnit -> ScreenUnit -> UIState
createGUI w h = UIState
{ _uiHasChanged = True
, _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize
, (UIId 1, createContainer (30, 215, 100, 80) [] 1)
, (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
, _uiMap = Map.fromList [ (UIId 0, createViewport (camera) LeftButton (0, 0, w, h) [UIId 1, UIId 2, UIId 5] 0) -- TODO: automatic resize
, (UIId 1, createContainer (30, 415, 100, 80) [] 1)
, (UIId 2, createPanel (50, 240, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
, (UIId 5, createViewport (camera) LeftButton (10, 10, 300, 200) [] 5) -- TODO: wrong camera
]
, _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
, _uiRoots = [UIId 0]
@ -311,6 +312,10 @@ copyGUI tex (vX, vY) widget = do
(GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff)))
(GL.TextureSize2D (int wWidth) (int wHeight))
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
prio <- widget ^. baseProperties.priority
when (widget ^. baseProperties.shorthand == "VWP" && prio == 5) $ do
-- copy camera texture on screen
return ()
nextChildrenIds <- widget ^. baseProperties.children
mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds

17
src/UI/UIBase.hs
View File

@ -63,7 +63,7 @@ instance Hashable MouseButton where -- TODO: generic deriving creates functions
--- widget state
---------------------------
-- |A key to reference a specific type of 'WidgetState'.
data WidgetStateKey = MouseStateKey
data WidgetStateKey = MouseStateKey | ViewportStateKey
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever
@ -85,6 +85,7 @@ data MouseButtonState = MouseButtonState
{ _mouseIsDragging :: Bool -- ^firing if pressed but not confirmed
, _mouseIsDeferred :: Bool
-- ^deferred if e. g. dragging but outside component
, _dragStart :: (ScreenUnit, ScreenUnit)
} deriving (Eq, Show)
-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'.
@ -95,6 +96,15 @@ data WidgetState =
, _mouseIsReady :: Bool -- ^ready if mouse is above component
, _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component
}
|
-- |A position to store screen units. Referenced by 'ViewportStateKey'.
ViewportState
{ _isDragging :: Bool
, _dragStartX :: Double
, _dragStartY :: Double
, _dragAngleX :: Double
, _dragAngleY :: Double
}
deriving (Eq, Show)
---------------------------
@ -255,9 +265,12 @@ $(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIGraphics)
initialViewportState :: WidgetState
initialViewportState = ViewportState False 0 0 0 0
-- |Creates a default @MouseButtonState@.
initialButtonState :: MouseButtonState
initialButtonState = MouseButtonState False False
initialButtonState = MouseButtonState False False (0, 0)
{-# INLINE initialButtonState #-}
-- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'.

75
src/UI/UIWidgets.hs
View File

@ -2,8 +2,9 @@
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Lens ((^.), (.~), (%~), (&))
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (readTVarIO, writeTVar, TVar())
import Control.Lens ((^.), (.~), (%~), (&), (^?), at, Getting())
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify)
@ -12,6 +13,7 @@ import Data.Maybe
import qualified Data.HashMap.Strict as Map
import Types
import Render.Misc (curb)
import UI.UIBase
import UI.UIOperations
@ -46,39 +48,68 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
(Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
(Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers
createViewport :: MouseButton -- ^ button to drag with
createViewport :: Getting (TVar CameraState) State (TVar CameraState)
--Setting (->) State State (TVar CameraState) (TVar CameraState) -- ^ lens to connected @TVar CameraState@
-> MouseButton -- ^ button to drag with
-> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
createViewport thelens btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
emptyGraphics
Map.empty -- widget states
(Map.fromList [(ViewportStateKey, initialViewportState)]) -- widget states
(Map.fromList [(MouseEvent, viewportMouseAction)
,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
where
updateCamera :: Double -> Double -> Double -> Double -> Double -> Double -> CameraState -> CameraState
updateCamera xStart' yStart' x y sodxa sodya cam =
let myrot = (x - xStart') / 2
mxrot = (y - yStart') / 2
newXAngle' = sodxa + mxrot/100
newXAngle = curb (pi/12) (0.45*pi) newXAngle'
newYAngle' = sodya + myrot/100
newYAngle
| newYAngle' > pi = newYAngle' - 2 * pi
| newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle'
in cam & (xAngle .~ newXAngle) . (yAngle .~ newYAngle)
viewportMouseAction :: WidgetEventHandler Pioneers
viewportMouseAction =
let press btn' (x, y) _ w =
do when (btn == btn') $ do
state <- get
cam <- liftIO $ readTVarIO (state ^. camera)
modify $ mouse %~ (isDragging .~ True)
. (dragStartX .~ fromIntegral x)
. (dragStartY .~ fromIntegral y)
. (dragStartXAngle .~ (cam ^. xAngle))
. (dragStartYAngle .~ (cam ^. yAngle))
. (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w
release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False)
return w
do if (btn == btn')
then do state <- get
let camT = state ^. thelens
cam <- liftIO $ readTVarIO camT
let sodxa = cam ^. xAngle
sodya = cam ^. yAngle
liftIO $ atomically $ writeTVar camT $
updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya cam
return $ w & widgetStates . at ViewportStateKey .~
Just (ViewportState True (fromIntegral x) (fromIntegral y) sodxa sodya)
else return w
release btn' _ _ w = if (btn' == btn)
then
-- modify ViewportState to "not dragging" or recreate ViewportState state if not present
return $ w & widgetStates . at ViewportStateKey %~
maybe (Just $ initialViewportState) (\s -> Just (s & isDragging .~ False))
else return w
in MouseHandler press release
viewportMouseMotionAction :: WidgetEventHandler Pioneers
viewportMouseMotionAction =
let move (x, y) w =
do state <- get
when (state ^. mouse.isDragging) $
modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
do let mbPosState = w ^. widgetStates.(at ViewportStateKey)
case mbPosState of
Just posState ->
when (maybe False id (posState ^? isDragging)) $ do
state <- get
let camT = state ^. thelens
cam <- liftIO $ readTVarIO camT
let xS = fromJust $ posState ^? dragStartX -- fromJust is safe
yS = fromJust $ posState ^? dragStartY -- fromJust is safe
sodxa = fromJust $ posState ^? dragAngleX -- fromJust is safe
sodya = fromJust $ posState ^? dragAngleY -- fromJust is safe
liftIO $ atomically $ writeTVar camT $
updateCamera xS yS (fromIntegral x) (fromIntegral y) sodxa sodya cam
Nothing -> return ()
return w
in emptyMouseMotionHandler & onMouseMove .~ move