From ae1f1d68150b7f9d63c9f8bbfe7c021fe4bcccd1 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Fri, 20 Jun 2014 16:27:11 +0200 Subject: [PATCH] ui: generalized viewport to access camera object via lens --- src/Main.hs | 2 +- src/Types.hs | 2 +- src/UI/Callbacks.hs | 8 ++++++-- src/UI/UIWidgets.hs | 32 ++++++++++++++++++-------------- 4 files changed, 26 insertions(+), 18 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 20ea800..92184c3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index e9fb681..e703559 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index dedfb8a..924b718 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -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 diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index b44a98e..42bf9d2 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -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