ui: generalized viewport to access camera object via lens

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

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

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
 

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.Concurrent.STM.TVar          (readTVarIO, writeTVar, TVar())
-import           Control.Lens                         ((^.), (.~), (%~), (&), (^?), at)
+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 :: Double -> Double -> Double -> Double -> Double -> Double -> CameraState -> CameraState
-    updateCamera xStart' yStart' x y sodxa sodya = do
+    updateCamera xStart' yStart' x y sodxa sodya cam =
-        state <- get
-        cam <- liftIO $ readTVarIO (state ^. camera)
         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'
-        
+        in cam & (xAngle .~ newXAngle) . (yAngle .~ newYAngle)
-        liftIO $ atomically $
-            writeTVar (state ^. camera) $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
   
     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