camera is recalculated on mouse action instead of at every frame

src/Main.hs

@@ -143,17 +143,6 @@ main = do
               , _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
                         }
@@ -190,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

src/Types.hs

@@ -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
@@ -185,7 +176,6 @@ data State = State
     , _mapTexture          :: TVar TextureObject
     , _camStack            :: TVar (Map.HashMap UIId (CameraState, 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/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)
 
 ---------------------------
@@ -176,7 +186,7 @@ instance Hashable EventKey where -- TODO: generic deriving creates functions tha
     hash = fromEnum
     hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
- -- |A handler to react on certain events. Corresponding key: 'EventKey'.
+-- |A handler to react on certain events. Corresponding key: 'EventKey'.
 data EventHandler (m :: * -> *) = 
     WindowHandler
         {
@@ -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)
+import           Control.Lens                         ((^.), (.~), (%~), (&), (^?), at)
 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
 
@@ -50,35 +52,60 @@ createViewport :: MouseButton -- ^ button to drag with
                -> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
 createViewport 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 -> Pioneers ()
+    updateCamera xStart' yStart' x y sodxa sodya = do
+        state <- get
+        cam <- liftIO $ readTVarIO (state ^. camera)
+        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'
+        
+        liftIO $ atomically $
+            writeTVar (state ^. camera) $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
+  
     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)
-                     modify $ mouse %~ (isDragging .~ True)
+                          let sodxa = cam ^. xAngle
-                                     . (dragStartX .~ fromIntegral x)
+                              sodya = cam ^. yAngle
-                                     . (dragStartY .~ fromIntegral y)
+                          updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya
-                                     . (dragStartXAngle .~ (cam ^. xAngle))
+                          return $ w & widgetStates . at ViewportStateKey .~
-                                     . (dragStartYAngle .~ (cam ^. yAngle))
+                              Just (ViewportState True (fromIntegral x) (fromIntegral y) sodxa sodya)
-                                     . (mousePosition.Types._x .~ fromIntegral x)
+                  else return w
-                                     . (mousePosition.Types._y .~ fromIntegral y)
+            release btn' _ _ w = if (btn' == btn)
-                 return w
+              then
-            release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False)
+                -- modify ViewportState to "not dragging" or recreate ViewportState state if not present
-                                    return w
+                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
+                          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
+                      Nothing -> return ()
                  return w
         in emptyMouseMotionHandler & onMouseMove .~ move