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

ui: generalized viewport to access camera object via lens

Browse Source
This commit is contained in:
tpajenka
2014-06-20 16:27:11 +02:00
parent 41e75dcdeb
commit ae1f1d6815
4 changed files with 26 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Main.hs
View File

@@ -112,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

2
src/Types.hs
View File

@@ -174,7 +174,7 @@ data State = State
{ _window :: !WindowState
, _camera :: TVar CameraState
, _mapTexture :: TVar TextureObject
, _camStack :: TVar (Map.HashMap UIId (CameraState, TextureObject))
, _camStack :: (Map.HashMap UIId (TVar CameraState, TVar TextureObject))
, _io :: !IOState
, _keyboard :: !KeyboardState
, _gl :: !GLState

8
src/UI/Callbacks.hs
View File

@@ -26,12 +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, UIId 5] 0) -- TODO: automatic resize
, _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 LeftButton (10, 10, 300, 200) [] 0)
, (UIId 5, createViewport (camera) LeftButton (10, 10, 300, 200) [] 5) -- TODO: wrong camera
]
, _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
, _uiRoots = [UIId 0]
@@ -312,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

32
src/UI/UIWidgets.hs
View File

@@ -3,8 +3,8 @@
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (readTVarIO, writeTVar)
import Control.Lens ((^.), (.~), (%~), (&), (^?), at)
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)
@@ -48,18 +48,18 @@ 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.fromList [(ViewportStateKey, initialViewportState)]) -- widget states
(Map.fromList [(MouseEvent, viewportMouseAction)
,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
where
updateCamera :: Double -> Double -> Double -> Double -> Double -> Double -> Pioneers ()
updateCamera xStart' yStart' x y sodxa sodya = do
state <- get
cam <- liftIO $ readTVarIO (state ^. camera)
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
@@ -69,19 +69,19 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
| newYAngle' > pi = newYAngle' - 2 * pi
| newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle'
liftIO $ atomically $
writeTVar (state ^. camera) $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
in cam & (xAngle .~ newXAngle) . (yAngle .~ newYAngle)
viewportMouseAction :: WidgetEventHandler Pioneers
viewportMouseAction =
let press btn' (x, y) _ w =
do if (btn == btn')
then do state <- get
cam <- liftIO $ readTVarIO (state ^. camera)
let camT = state ^. thelens
cam <- liftIO $ readTVarIO camT
let sodxa = cam ^. xAngle
sodya = cam ^. yAngle
updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya
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
@@ -100,11 +100,15 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
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
updateCamera xS yS (fromIntegral x) (fromIntegral y) sodxa sodya
liftIO $ atomically $ writeTVar camT $
updateCamera xS yS (fromIntegral x) (fromIntegral y) sodxa sodya cam
Nothing -> return ()
return w
in emptyMouseMotionHandler & onMouseMove .~ move