new UI-Widget type: Viewport, removed old hacked code (except mouse wheel) to handle camera movement and using viewport instead

src/Main.hs

@@ -133,8 +133,7 @@ main =
                         , _tessClockFactor     = 0
                         }
               , _mouse               = MouseState
-                        { _isDown              = False
+                        { _isDragging          = False
-                        , _isDragging          = False
                         , _dragStartX          = 0
                         , _dragStartY          = 0
                         , _dragStartXAngle     = 0

src/Types.hs

@@ -60,8 +60,7 @@ data GameState = GameState
     }
 
 data MouseState = MouseState
-    { _isDown              :: !Bool
+    { _isDragging          :: !Bool
-    , _isDragging          :: !Bool
     , _dragStartX          :: !Double
     , _dragStartY          :: !Double
     , _dragStartXAngle     :: !Double

src/UI/Callbacks.hs

@@ -8,7 +8,7 @@ import           Control.Monad                        (liftM, when, unless)
 import           Control.Monad.RWS.Strict             (ask, get, modify)
 import           Control.Monad.Trans                  (liftIO)
 import qualified Data.HashMap.Strict                  as Map
-import           Data.List                            (foldl')
+--import           Data.List                            (foldl')
 import           Data.Maybe
 import           Foreign.Marshal.Array                (pokeArray)
 import           Foreign.Marshal.Alloc                (allocaBytes)
@@ -22,7 +22,7 @@ import UI.UIOperations
 
 -- TODO: define GUI positions in a file
 createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
-createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
+createGUI = (Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize
                           , (UIId 1, createContainer (30, 215, 100, 80) [] 1)
                           , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
                           , (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
@@ -101,38 +101,14 @@ eventCallback e = do
                     _ ->
                         return ()
             SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
-                do
+                mouseMoveHandler (x, y)
-                state <- get
-                if state ^. mouse.isDown && not (state ^. mouse.isDragging)
-                  then
-                    modify $ (mouse.isDragging .~ True)
-                           . (mouse.dragStartX .~ fromIntegral x)
-                           . (mouse.dragStartY .~ fromIntegral y)
-                           . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
-                           . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
-                    else mouseMoveHandler (x, y)
-                modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
-                       . (mouse.mousePosition. Types._y .~ fromIntegral y)
             SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
-             do 
+               case state of
-                case button of
+                    SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
-                     SDL.LeftButton -> do
+                    SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
-                         let pressed = state == SDL.Pressed
+                    _ -> return ()
-                         modify $ mouse.isDown .~ pressed
-                         if pressed 
-                           then mouseReleaseHandler LeftButton (x, y)
-                           else do
-                             st <- get
-                             if st ^. mouse.isDragging then
-                                 modify $ mouse.isDragging .~ False
-                             else do
-                                 mousePressHandler LeftButton (x, y)
-                     _ -> case state of
-                               SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
-                               SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
-                               _ -> return ()
             SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
-                do
+                do -- TODO: MouseWheelHandler
                 state <- get
                 let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
                   modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
@@ -295,6 +271,7 @@ copyGUI tex (vX, vY) widget = do
                             --temporary color here. lateron better some getData-function to
                             --get a list of pixel-data or a texture.
                             color = case widget ^. baseProperties.shorthand of
+                                "VWP" -> [0,128,128,30]
                                 "CNT" -> [255,0,0,128]
                                 "BTN" -> [255,255,0,255]
                                 "PNL" -> [128,128,128,128]

src/UI/UIBase.hs

@@ -4,7 +4,7 @@
 module UI.UIBase where
 
 import           Control.Lens             ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
-import           Control.Monad            (liftM)
+import           Control.Monad            (join,liftM)
 import           Data.Array
 import           Data.Bits                 (xor)
 import           Data.Hashable
@@ -157,7 +157,7 @@ data EventHandler m =
         --  widget’s extent ('isInside') or when the mouse is inside the
         --  widget’s extent while another button loses its mouse-active state.
         --  
-        -- The function returns the altered widget resulting from the button press
+        -- The function returns the altered widget resulting from the button press.
         _onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m)
         ,
         -- |The function 'onMouseLeave' is invoked when the mouse leaves the
@@ -239,7 +239,45 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta
                                False (0, 0)
 {-# INLINE initialMouseState #-}
 
--- TODO: combined mouse handler
+-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions
+--  of two handlers. Thereby, the resulting widget of the first handler is the input widget of the
+--  second handler and all other parameters are the same for both function calls.
+--  
+--  If not both input handlers are of type @MouseHandler@ an error is raised.
+combinedMouseHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m
+combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) =
+    MouseHandler (comb p1 p2) (comb r1 r2)
+  where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside
+combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two EventHandler" ++
+    " with constructor MouseHandler"
+
+-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action
+--  functions of two handlers. Thereby, the resulting widget of the second handler is the input
+--  widget of the second handler and all other parameters are the same for both function calls.
+--  
+--  If not both input handlers are of type @MouseMotionHandler@ an error is raised.
+combinedMouseMotionHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m
+combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) =
+    MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2)
+  where comb h1 h2 px = join . liftM (h2 px) . h1 px
+combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two EventHandler" ++
+    " with constructor MouseMotionHandler" 
+
+-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing.
+--  It may be useful as construction kit.
+--  
+--  >>> emptyMouseHandler & _onMousePress .~ myPressFunction
+--  >>> emptyMouseHandler { _onMousePress = myPressFunction }
+emptyMouseHandler :: (Monad m) => EventHandler m
+emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
+
+-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing.
+--  It may be useful as construction kit.
+--  
+--  >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction
+--  >>> emptyMouseHandler { _onMouseMove = myMoveFunction }
+emptyMouseMotionHandler :: (Monad m) => EventHandler m
+emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return)
 
 -- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export
 -- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present,

src/UI/UIWidgets.hs

@@ -2,10 +2,10 @@
 
 module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
 
-import           Control.Lens                         ((^.), (.~), (&))
+import           Control.Lens                         ((^.), (.~), (%~), (&))
 import           Control.Monad
---import           Control.Monad.IO.Class -- MonadIO
+-- import           Control.Monad.IO.Class               (liftIO)
-import           Control.Monad.RWS.Strict             (get)
+import           Control.Monad.RWS.Strict             (get, modify)
 import           Data.List
 import           Data.Maybe
 import qualified Data.HashMap.Strict as Map
@@ -43,3 +43,38 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
                                       emptyGraphics
                                       (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
                                       (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers
+
+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 [(MouseEvent, viewportMouseAction)
+                                                  ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
+  where
+    viewportMouseAction :: EventHandler Pioneers
+    viewportMouseAction =
+        let press btn' (x, y) _ w =
+              do when (btn == btn') $ do
+                     state <- get
+                     modify $ mouse %~ (isDragging .~ True)
+                                     . (dragStartX .~ fromIntegral x)
+                                     . (dragStartY .~ fromIntegral y)
+                                     . (dragStartXAngle .~ (state ^. camera.xAngle))
+                                     . (dragStartYAngle .~ (state ^. camera.yAngle))
+                                     . (mousePosition.Types._x .~ fromIntegral x)
+                                     . (mousePosition.Types._y .~ fromIntegral y)
+                 return w
+            release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False)
+                                    return w
+        in MouseHandler press release
+    
+    viewportMouseMotionAction :: EventHandler Pioneers
+    viewportMouseMotionAction =
+        let move (x, y) w =
+              do state <- get
+                 when (state ^. mouse.isDragging) $
+                        modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
+                                        . (mousePosition.Types._y .~ fromIntegral y)
+                 return w
+        in emptyMouseMotionHandler & onMouseMove .~ move