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

src/Main.hs

@@ -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.

src/Render/Render.hs

@@ -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)

src/Types.hs

@@ -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))
+    , _uiMap               :: Map.HashMap UIId (GUIWidget Pioneers)
-    , _uiObserverEvents    :: !(Map.HashMap EventKey [EventHandler 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)

src/UI/Callbacks.hs

@@ -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
+    , _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, 215, 100, 80) [] 1)
+                                       , (UIId 1, createContainer (30, 415, 100, 80) [] 1)
-                                       , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
+                                       , (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
 

src/UI/UIBase.hs

@@ -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'.

src/UI/UIWidgets.hs

@@ -2,8 +2,9 @@
 
 module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
 
-import           Control.Concurrent.STM.TVar          (readTVarIO)
+import           Control.Concurrent.STM               (atomically)
-import           Control.Lens                         ((^.), (.~), (%~), (&))
+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
+              do if (btn == btn') 
-                     state <- get
+                  then do state <- get
-                     cam <- liftIO $ readTVarIO (state ^. camera)
+                          let camT = state ^. thelens
-                     modify $ mouse %~ (isDragging .~ True)
+                          cam <- liftIO $ readTVarIO camT
-                                     . (dragStartX .~ fromIntegral x)
+                          let sodxa = cam ^. xAngle
-                                     . (dragStartY .~ fromIntegral y)
+                              sodya = cam ^. yAngle
-                                     . (dragStartXAngle .~ (cam ^. xAngle))
+                          liftIO $ atomically $ writeTVar camT $
-                                     . (dragStartYAngle .~ (cam ^. yAngle))
+                            updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya cam
-                                     . (mousePosition.Types._x .~ fromIntegral x)
+                          return $ w & widgetStates . at ViewportStateKey .~
-                                     . (mousePosition.Types._y .~ fromIntegral y)
+                              Just (ViewportState True (fromIntegral x) (fromIntegral y) sodxa sodya)
-                 return w
+                  else return w
-            release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False)
+            release btn' _ _ w = if (btn' == btn)
-                                    return w
+              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
+              do let mbPosState = w ^. widgetStates.(at ViewportStateKey)
-                 when (state ^. mouse.isDragging) $
+                 case mbPosState of
-                        modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
+                      Just posState ->
-                                        . (mousePosition.Types._y .~ fromIntegral y)
+                        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