Merge branch 'ui' into iqm

Conflicts:
	src/UI/UIBase.hs

src/Main.hs

@@ -44,7 +44,6 @@ import           UI.Callbacks
 import           Map.Graphics
 import           Map.Creation                          (exportedMap)
 import           Types
-import qualified UI.UIBase as UI
 import           Importer.IQM.Parser
 --import           Data.Attoparsec.Char8 (parseTest)
 --import qualified Data.ByteString as B
@@ -65,9 +64,12 @@ testParser a = print  =<< parseIQM a
 --------------------------------------------------------------------------------
 
 main :: IO ()
-main =
+main = do
+    let initialWidth = 1024
+        initialHeight = 600
     SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
-      SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl     -- we want openGL
+      SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight)
+          [SDL.WindowOpengl     -- we want openGL
           ,SDL.WindowShown      -- window should be visible
           ,SDL.WindowResizable  -- and resizable
           ,SDL.WindowInputFocus -- focused (=> active)
@@ -114,7 +116,6 @@ main =
         let zDistClosest'  = 2
             zDistFarthest' = zDistClosest' + 10
             --TODO: Move near/far/fov to state for runtime-changability & central storage
-            (guiMap, guiRoots) = createGUI
             aks = ArrowKeyState {
                   _up       = False
                 , _down     = False
@@ -140,8 +141,7 @@ main =
               , _camera              = cam'
               , _camStack            = camStack'
               , _mouse               = MouseState
-                        { _isDown              = False
+                        { _isDragging          = False
-                        , _isDragging          = False
                         , _dragStartX          = 0
                         , _dragStartY          = 0
                         , _dragStartXAngle     = 0
@@ -161,12 +161,7 @@ main =
                         , _glFramebuffer       = frameBuffer
                         }
               , _game                = game'
-              , _ui                  = UIState
+              , _ui                  = createGUI initialWidth initialHeight
-                        { _uiHasChanged        = True
-                        , _uiMap = guiMap
-                        , _uiRoots = guiRoots
-                        , _uiButtonState = UI.UIButtonState 0 Nothing False
-                        }
               }
 
         putStrLn "init done."

src/Types.hs

@@ -62,8 +62,7 @@ data GameState = GameState
     }
 
 data MouseState = MouseState
-    { _isDown              :: !Bool
+    { _isDragging          :: !Bool
-    , _isDragging          :: !Bool
     , _dragStartX          :: !Double
     , _dragStartY          :: !Double
     , _dragStartXAngle     :: !Double
@@ -172,9 +171,10 @@ data GLState = GLState
 
 data UIState = UIState
     { _uiHasChanged        :: !Bool
-    , _uiMap               :: Map.HashMap UIId (GUIWidget Pioneers)
+    , _uiMap               :: !(Map.HashMap UIId (GUIWidget Pioneers))
-    , _uiRoots             :: [UIId]
+    , _uiObserverEvents    :: !(Map.HashMap EventKey [EventHandler Pioneers])
-    , _uiButtonState       :: UIButtonState
+    , _uiRoots             :: !([UIId])
+    , _uiButtonState       :: !UIButtonState
     }
 
 data State = State

src/UI/Callbacks.hs

@@ -3,17 +3,17 @@ module UI.Callbacks where
 
 
 import qualified Graphics.Rendering.OpenGL.GL         as GL
-import           Control.Lens                         ((^.), (.~), (%~), (^?), at)
+import           Control.Lens                         ((^.), (.~), (%~), (^?), at, ix)
 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)
 import qualified Graphics.UI.SDL                      as SDL
-import           Control.Concurrent.STM.TVar          (readTVar, readTVarIO, writeTVar)
+import           Control.Concurrent.STM.TVar          (readTVar, writeTVar)
 import           Control.Concurrent.STM               (atomically)
 
 
@@ -23,13 +23,19 @@ import UI.UIWidgets
 import UI.UIOperations
 
 -- TODO: define GUI positions in a file
-createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
+createGUI :: ScreenUnit -> ScreenUnit -> UIState
-createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
+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
                                        , (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 )
                                        , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
-                          ], [UIId 0])
+                                       ]
+    , _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
+    , _uiRoots          = [UIId 0]
+    , _uiButtonState    = UIButtonState 0 Nothing False
+    }
          
 getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
 getGUI = Map.elems
@@ -69,9 +75,10 @@ eventCallback :: SDL.Event -> Pioneers ()
 eventCallback e = do
         env <- ask
         case SDL.eventData e of
-            SDL.Window _ _ -> -- windowID event
+            SDL.Window _ ev -> -- windowID event
-                -- TODO: resize GUI
+                case ev of
-                return ()
+                     SDL.Resized (SDL.Size x y) -> windowResizeHandler x y
+                     _ -> return ()
             SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
                      -- need modifiers? use "keyModifiers key" to get them
                 let aks = keyboard.arrowsPressed in
@@ -103,40 +110,15 @@ 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
-                    do
-                    cam <- liftIO $ readTVarIO (state ^. camera)
-                    modify $ (mouse.isDragging .~ True)
-                           . (mouse.dragStartX .~ fromIntegral x)
-                           . (mouse.dragStartY .~ fromIntegral y)
-                           . (mouse.dragStartXAngle .~ (cam ^. xAngle))
-                           . (mouse.dragStartYAngle .~ (cam ^. 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.LeftButton -> do
-                         let pressed = state == SDL.Pressed
-                         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
                 liftIO $ atomically $ do
                     cam <- readTVar (state ^. camera)
@@ -150,7 +132,18 @@ eventCallback e = do
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
 
 
-mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
+windowResizeHandler :: ScreenUnit -> ScreenUnit -> Pioneers ()
+windowResizeHandler x y = do
+    state <- get
+    case state ^. ui.uiObserverEvents.(at WindowEvent) of
+         Just evs -> let handle :: EventHandler Pioneers -> Pioneers (EventHandler Pioneers)
+                         handle (WindowHandler h _) = h x y
+                         handle h = return h -- TODO: may log invalid event mapping
+           in do newEvs <- mapM handle evs
+                 modify $ ui.uiObserverEvents.(ix WindowEvent) .~ newEvs
+         Nothing -> return ()
+
+mouseButtonHandler :: (WidgetEventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
                    -> MouseButton -> Pixel -> Pioneers ()
 mouseButtonHandler transFunc btn px = do
     state <- get
@@ -160,7 +153,7 @@ mouseButtonHandler transFunc btn px = do
          Just (wid, px') -> do
              let target = toGUIAny hMap wid
              target' <- case target ^. eventHandlers.(at MouseEvent) of
-                             Just ma -> transFunc ma btn (px -: px') target
+                             Just ma -> transFunc ma btn (px -: px') (state ^. ui.uiButtonState.mouseInside) target
                              Nothing  -> return target
              modify $ ui.uiMap %~ Map.insert wid target'
              return ()
@@ -229,7 +222,9 @@ mouseSetLeaving wid px = do
     modify $ ui.uiButtonState.mouseInside .~ False
     case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
          Just ma -> do
-             target' <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust
+             target_ <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust
+             target' <- if state ^. ui.uiButtonState.mousePressed <= 0 then return target_
+                        else fromJust (ma ^? onMouseMove) px target_ --TODO unsafe fromJust
              modify $ ui.uiMap %~ Map.insert wid target'
          Nothing -> return ()
         
@@ -245,7 +240,7 @@ mouseMoveHandler px = do
                   Left b -> -- no child hit
                       if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside
                         case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
-                             Just ma -> do target' <- fromJust (ma ^? onMouseMove) px' target
+                             Just ma -> do target' <- fromJust (ma ^? onMouseMove) (px -: px') target
                                            modify $ ui.uiMap %~ Map.insert wid target'
                              Nothing -> return () 
                       else if b then -- && not mouseInside --> entering
@@ -269,36 +264,6 @@ mouseMoveHandler px = do
              mouseSetMouseActive px
              
 
--- | Handler for UI-Inputs.
---   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
-clickHandler :: MouseButton -> Pixel -> Pioneers ()
-clickHandler btn pos@(x,y) = do
-  roots <- getRootIds
-  hits <- liftM concat $ mapM (getInsideId pos) roots
-  case hits of
-       [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
-       _  -> do
-         changes <- mapM (\(uid, pos') -> do
-           state <- get
-           let w = toGUIAny (state ^. ui.uiMap) uid
-               short = w ^. baseProperties.shorthand
-           bound <- w ^. baseProperties.boundary
-           prio <- w ^. baseProperties.priority
-           liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
-                             ++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
-           case w ^. eventHandlers.(at MouseEvent) of
-                Just ma -> do w'  <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
-                              w'' <- fromJust (ma ^? onMouseRelease) btn pos' w' -- TODO unsafe fromJust
-                              return $ Just (uid, w'')
-                Nothing  -> return Nothing
-           ) hits
-         state <- get
-         let hMap = state ^. ui.uiMap
-             newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
-         modify $ ui.uiMap .~ newMap
-         return ()
-         
-
 -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
 --
 --TODO: should be done asynchronously at one point.
@@ -320,7 +285,7 @@ prepareGUI = do
                 modify $ ui.uiHasChanged .~ False
 
 --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
-copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset
+copyGUI :: GL.TextureObject -> Pixel -- ^current view’s offset
         -> GUIWidget Pioneers -- ^the widget to draw
         -> Pioneers ()
 copyGUI tex (vX, vY) widget = do
@@ -332,6 +297,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,0]
                                 "CNT" -> [255,0,0,128]
                                 "BTN" -> [255,255,0,255]
                                 "PNL" -> [128,128,128,128]

src/UI/UIBase.hs

@@ -1,10 +1,10 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-}
 -- widget data is separated into several modules to avoid cyclic dependencies with the Type module
 -- TODO: exclude UIMouseState constructor from export?
 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
@@ -24,7 +24,7 @@ merge :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
 merge f (x, y) (x', y') = (f x x', f y y')
 {-# INLINABLE merge #-}
 
--- |Maps the over the elements of a tuple. Designed for use with 'Pixel'.
+-- |Maps over the elements of a tuple. Designed for use with 'Pixel'.
 (>:) :: (a -> b) -> (a, a) -> (b, b)
 f >: (x, y) = (f x, f y)
 {-# INLINABLE (>:) #-}
@@ -87,7 +87,7 @@ data MouseButtonState = MouseButtonState
       -- ^deferred if e. g. dragging but outside component
     } deriving (Eq, Show)
  
--- |An applied state a widget may take, depending on its usage and event handlers.
+-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'.
 data WidgetState =
     -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
     MouseState
@@ -101,67 +101,100 @@ data WidgetState =
 --- events
 ---------------------------
 
+-- |A key to reference a specific 'WidgetEventHandler'.
+data WidgetEventKey = MouseEvent | MouseMotionEvent
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
+
+instance Hashable WidgetEventKey where -- TODO: generic deriving creates functions that run forever
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
+
+--- event handlers
+
+-- |A handler to react on certain events. Corresponding key: 'WidgetEventKey'.
+data WidgetEventHandler m =
+    -- |Handler to control the functionality of a 'GUIWidget' on mouse button events.
+    --  
+    --  All screen coordinates are widget-local coordinates.
+    MouseHandler
+        {
+        -- |The function 'onMousePressed' is called when a button is pressed
+        --  while the button is mouse-active.
+        --  
+        --  The boolean value indicates if the button press happened within the widget
+        --  ('_isInside').
+        --  
+        --  The function returns the altered widget resulting from the button press.
+        _onMousePress :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m)
+        ,
+        -- |The function 'onMouseReleased' is called when a button is released
+        --  while the widget is mouse-active.
+        --  
+        --  Thus, the mouse is either within the widget or outside while still dragging.
+        --  
+        --  
+        --  The boolean value indicates if the button release happened within the widget
+        --  ('_isInside').
+        --  
+        --  The function returns the altered widget resulting from the button press.
+        _onMouseRelease :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m)
+        }
+    |
+    -- |Handler to control the functionality of a 'GUIWidget' on mouse movement.
+    --  
+    --  All screen coordinates are widget-local coordinates.
+    MouseMotionHandler
+        {
+        -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
+        --  widget’s extent ('isInside') while no button is pressed or when the mouse is inside the
+        --  widget’s extent while another button loses its mouse-active state. Triggered after
+        --  '_onMouseEnter' or '_onMouseLeave' (only if still mouse-active on leaving) if applicable.
+        --  
+        -- The function returns the altered widget resulting from the button press.
+        _onMouseMove :: Pixel -> GUIWidget m -> m (GUIWidget m)
+        ,
+        -- |The function 'onMouseMove' is invoked when the mouse enters the
+        --  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.
+        _onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m)
+        ,
+        -- |The function 'onMouseLeave' is invoked when the mouse leaves the
+        --  widget’s extent ('isInside') while no other widget is mouse-active.
+        --  
+        -- The function returns the altered widget resulting from the button press.
+        _onMouseLeave :: Pixel -> GUIWidget m -> m (GUIWidget m)
+        }
+    deriving ()
+
 -- |A key to reference a specific 'EventHandler'.
-data EventKey = MouseEvent | MouseMotionEvent
+data EventKey = WindowEvent | WidgetPositionEvent 
     deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
 
 instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
     hash = fromEnum
     hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
---- event handlers
+ -- |A handler to react on certain events. Corresponding key: 'EventKey'.
+data EventHandler (m :: * -> *) = 
+    WindowHandler
+        {
+        -- |The function '_onWindowResize' is invoked when the global application window changes size.
+        --  
+        --  The input is the window’s new width and height in that order.
+        --  
+        --  The returned handler is resulting handler that may change by the event. Its type must
+        --  remain @WindowHandler@. 
+        _onWindowResize :: ScreenUnit -> ScreenUnit -> m (EventHandler m)
+        ,
+        -- |Unique id to identify an event instance.
+        _eventId :: UIId
+        }
     
--- |A handler to react on certain events.
+instance Eq (EventHandler m) where
-data EventHandler m = 
+    WindowHandler _ id' == WindowHandler _ id'' = id' == id''
-    -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. 
+    _ == _ = False
-    MouseHandler
-        {
-        -- |The function 'onMousePressed' is called when a button is pressed
-        --  while the widget is mouse-active.
-        -- 
-        --  A widget becomes mouse-active if no other button is currently pressed and the mouse
-        --  coordinates are within the widget's extent ('isInside') until no button is pressed any
-        --  more.
-        _onMousePress :: MouseButton       -- the pressed button
-                      -> Pixel             -- screen position
-                      -> GUIWidget m       -- widget the event is invoked on
-                      -> m (GUIWidget m)   -- widget after the event and the possibly altered mouse handler
-        ,
-        -- |The function 'onMouseReleased' is called when a button is released
-        --  while the widget is mouse-active.
-        --  
-        --  Thus, the mouse is either within the widget or outside while still dragging.
-        _onMouseRelease :: MouseButton       -- the released button
-                        -> Pixel             -- screen position
-                        -> GUIWidget m       -- widget the event is invoked on
-                        -> m (GUIWidget m)   -- widget after the event and the altered handler
-        }
-    |
-    -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. 
-    MouseMotionHandler
-        {
-        -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-        --  widget's extent ('isInside') while no button is pressed or when the mouse is inside the
-        --  widget's extent while another button loses its mouse-active state. Triggered after
-        --  '_onMouseEnter'.
-        _onMouseMove :: Pixel             -- screen position
-                     -> GUIWidget m       -- widget the event is invoked on
-                     -> m (GUIWidget m)   -- widget after the event and the altered handler
-        ,
-        -- |The function 'onMouseMove' is invoked when the mouse enters the
-        --  widget's extent ('isInside') or when the mouse is inside the
-        --  widget's extent while another button loses its mouse-active state..
-        _onMouseEnter :: Pixel           -- screen position
-                      -> GUIWidget m     -- widget the event is invoked on
-                      -> m (GUIWidget m) -- widget after the event and the altered handler
-        ,
-        -- |The function 'onMouseLeave' is invoked when the mouse leaves the
-        --  widget's extent ('isInside') while no other widget is mouse-active.
-        _onMouseLeave :: Pixel           -- screen position
-                      -> GUIWidget m     -- widget the event is invoked on
-                      -> m (GUIWidget m) -- widget after the event and the altered handler
-        }
-    deriving ()
 
 
 ---------------------------
@@ -173,7 +206,7 @@ data GUIWidget m = Widget
     {_baseProperties :: GUIBaseProperties m
     ,_graphics :: GUIGraphics m
     ,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
-    ,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key
+    ,_eventHandlers :: Map.HashMap WidgetEventKey (WidgetEventHandler m) -- no guarantee that data match key
     }
 
 -- |Base properties are fundamental settings of any 'GUIWidget'.
@@ -186,7 +219,7 @@ data GUIBaseProperties m = BaseProperties
     ,
     -- |The @_getChildren@ function returns all children associated with this widget.
     --
-    --  All children must be wholly inside the parent's bounding box specified by '_boundary'.
+    --  All children must be wholly inside the parent’s bounding box specified by '_boundary'.
     _children :: m [UIId]
     ,
     -- |The function @_isInside@ tests whether a point is inside the widget itself.
@@ -195,9 +228,9 @@ data GUIBaseProperties m = BaseProperties
     --
     --  The default implementations tests if the point is within the rectangle specified by the 
     --  'getBoundary' function.
-    _isInside :: GUIWidget m
+    --
-              -> Pixel  -- local coordinates
+    --  The passed coordinates are widget-local coordinates.
-              -> m Bool
+    _isInside :: GUIWidget m -> Pixel -> m Bool
     ,
     -- |The @_getPriority@ function returns the priority score of a @GUIWidget@.
     --  A widget with a high score is more in the front than a low scored widget.
@@ -212,54 +245,91 @@ data GUIBaseProperties m = BaseProperties
 
 -- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
 
-data GUIGraphics m = Graphics 
+data GUIGraphics (m :: * -> *) = Graphics
-    {temp :: m Int}
 
 $(makeLenses ''UIButtonState)
 $(makeLenses ''WidgetState)
 $(makeLenses ''MouseButtonState)
-$(makeLenses ''EventHandler)
+$(makeLenses ''WidgetEventHandler)
 $(makeLenses ''GUIWidget)
 $(makeLenses ''GUIBaseProperties)
 $(makeLenses ''GUIGraphics)
 
+-- |Creates a default @MouseButtonState@.
 initialButtonState :: MouseButtonState
 initialButtonState = MouseButtonState False False
 {-# INLINE initialButtonState #-}
 
--- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
+-- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'.
---  provided in the passed list.
 initialMouseState :: WidgetState
 initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
                                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) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler 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 WidgetEventHandler" ++
+    " 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) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler 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 WidgetEventHandler" ++
+    " 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) => WidgetEventHandler 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) => WidgetEventHandler 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,
+-- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present,
 --  only fully functional in conjunction with 'setMouseMotionStateActions'.
-setMouseStateActions :: (Monad m) => EventHandler m
+setMouseStateActions :: (Monad m) => WidgetEventHandler m
 setMouseStateActions = MouseHandler press' release'
   where
-    -- |Change 'MouseButtonState's '_mouseIsDragging' to @True@.
+    -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@.
-    press' b _ w =
+    press' b _ _ w =
         return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
 
-    -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
+    -- |Change 'MouseButtonState'’s '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
-    release' b _ w =
+    release' b _ _ w =
         return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
                 (mouseIsDragging .~ False) . (mouseIsDeferred .~ False)
 
--- |Creates a 'MouseHandler' that sets a widget's 'WidgetState MouseState' properties if present,
+-- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present,
 --  only fully functional in conjunction with 'setMouseStateActions'.
-setMouseMotionStateActions :: (Monad m) => EventHandler m
+setMouseMotionStateActions :: (Monad m) => WidgetEventHandler m
 setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
   where
     -- |Updates mouse position.
     move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p
 
-    -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current
+    -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging'’s current
     --  value and sets '_mouseIsDragging' to @False@.
     enter' p w = return $ w & widgetStates.(ix MouseStateKey)
                     %~ (mouseIsReady .~ True) . (mousePixel .~ p)
@@ -268,7 +338,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
                          . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred)))
 
 
-    -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current
+    -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred'’s current
     --  value and sets '_mouseIsDeferred' to @False@.
     leave' p w = return $ w & widgetStates.(ix MouseStateKey)
                     %~ (mouseIsReady .~ False) . (mousePixel .~ p)
@@ -277,40 +347,38 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
                          . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
 
 -- TODO: make only fire if press started within widget
--- |Creates a MouseHandler that reacts on mouse clicks.
+-- |Creates a 'MouseHandler' that reacts on mouse clicks.
 -- 
---  Does /not/ update 'WidgetState MouseState'!
+--  Does /not/ update the widget’s 'MouseState'!
 buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-                                -> EventHandler m
+                                -> WidgetEventHandler m
 buttonMouseActions a = MouseHandler press' release'
   where
-    press' _ _ = return
+    press' _ _ _ = return
 
-    release' b p w = do fire <- (w ^. baseProperties.isInside) w p
+    release' b p inside w = if inside then a b w p else return w
-                        if fire then a b w p else return w
 
 -- TODO: make only fire if press started within widget
--- |Creates a MouseHandler that reacts on mouse clicks.
+-- |Creates a 'MouseHandler' that reacts on mouse clicks.
 --
---  Does /not/ update 'WidgetState MouseState'!
+--  Does /not/ update the widget’s 'MouseState'!
 buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-                                      -> MouseButton -> EventHandler m
+                                      -> MouseButton -> WidgetEventHandler m
 buttonSingleMouseActions a btn = MouseHandler press' release'
   where
-    press' _ _ = return
+    press' _ _ _ = return
 
-    release' b p w = do fire <- liftM (b == btn &&) $ (w ^. baseProperties.isInside) w p
+    release' b p inside w = if inside && b == btn then a w p else return w
-                        if fire then a w p else return w
 
 emptyGraphics :: (Monad m) => GUIGraphics m
-emptyGraphics = Graphics (return 3)
+emptyGraphics = Graphics
 
 -- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
 extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit)
 extractExtent (_,_,w,h) = (w,h)
 {-# INLINABLE extractExtent #-}
 
--- |Calculates whether a point's value exceed the given width and height.
+-- |Calculates whether a point’s value exceed the given width and height.
 isInsideExtent :: (ScreenUnit, ScreenUnit) -> Pixel -> Bool
 isInsideExtent (w,h) (x',y') = (x' <= w) && (x' >= 0) && (y' <= h) && (y' >= 0)
 

src/UI/UIOperations.hs

@@ -1,10 +1,12 @@
 module UI.UIOperations where
 
-import           Control.Lens                    ((^.))
+import           Control.Lens                    ((^.), (%~))
 import           Control.Monad                   (liftM)
 --import           Control.Monad.IO.Class          (liftIO)
-import           Control.Monad.RWS.Strict        (get)
+import           Control.Monad.RWS.Strict        (get, modify)
 import qualified Data.HashMap.Strict             as Map
+import           Data.Hashable
+--import qualified Data.List                       as L
 import           Data.Maybe
 
 import Types
@@ -29,9 +31,44 @@ isInsideFast wg px = do
   (_, _, w, h) <- wg ^. baseProperties.boundary
   liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
 
+-- |Adds an event to the given map. The new event is concatenated to present events. Does not test
+--  if the map already contains the given element.
+addEvent :: (Eq k, Hashable k) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
+addEvent k v eventMap = Map.insertWith (++) k [v] eventMap
+
+-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
+registerEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
+registerEvent k v = modify  $ ui.uiObserverEvents %~ addEvent k v
+
+-- |The 'deleteQualitative' function behaves like 'Data.List.deleteBy' but reports @True@ if the
+--  list contained the relevant object.
+deleteQualitative :: (a -> a -> Bool) -> a -> [a] -> ([a], Bool)
+deleteQualitative _  _ [] = ([], False)
+deleteQualitative eq x (y:ys)    = if x `eq` y then (ys, True) else
+    let (zs, b) = deleteQualitative eq x ys
+    in (y:zs, b)
+
+-- |Removes the first occurrence of an event from the given map if it is within the event list of
+--  the key.
+removeEvent :: (Eq k, Hashable k, Eq v) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
+removeEvent k v eventMap =
+  case Map.lookup k eventMap of
+       Just list -> case deleteQualitative (==) v list of
+            (_, False) -> eventMap
+            (ys, _) -> case ys of
+                            [] -> Map.delete k eventMap 
+                            _  -> Map.insert k ys eventMap 
+       Nothing   -> Map.insert k [v] eventMap
+
+
+-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
+deregisterEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
+deregisterEvent k v = modify $ ui.uiObserverEvents %~ removeEvent k v
+
+
 
 -- |The function 'getInsideId' returns child widgets that overlap with a 
---  specific screen position and the pixel's local coordinates.
+--  specific screen position and the pixel’s local coordinates.
 --  
 --  A screen position may be inside the bounding box of a widget but not
 --  considered part of the component. The function returns all hit widgets that 
@@ -46,7 +83,7 @@ getInsideId px uid = do
   (bX, bY, _, _) <- wg ^. baseProperties.boundary
   let px' = px -: (bX, bY)
   inside <- isInsideFast wg px'
-  if inside -- test inside parent's bounding box
+  if inside -- test inside parent’s bounding box
     then do
       childrenIds <- wg ^. baseProperties.children
       hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds

src/UI/UIWidgets.hs

@@ -2,16 +2,18 @@
 
 module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
 
-import           Control.Lens                         ((^.), (.~), (&))
+import           Control.Concurrent.STM.TVar          (readTVarIO)
+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
 
 import           Types
 import UI.UIBase
+import UI.UIOperations
 
 
 createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
@@ -43,3 +45,54 @@ 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 :: WidgetEventHandler Pioneers
+    viewportMouseAction =
+        let press btn' (x, y) _ w =
+              do when (btn == btn') $ do
+                     state <- get
+                     cam <- liftIO $ readTVarIO (state ^. camera)
+                     modify $ mouse %~ (isDragging .~ True)
+                                     . (dragStartX .~ fromIntegral x)
+                                     . (dragStartY .~ fromIntegral y)
+                                     . (dragStartXAngle .~ (cam ^. xAngle))
+                                     . (dragStartYAngle .~ (cam ^. 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 :: WidgetEventHandler 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
+        
+resizeToScreenHandler :: UIId -- ^id of a widget
+                      -> EventHandler Pioneers
+resizeToScreenHandler id' = WindowHandler resize (UIId 0) -- TODO: unique id
+  where resize :: ScreenUnit -> ScreenUnit -> Pioneers (EventHandler Pioneers)
+        resize w h = do
+            state <- get
+            let wg = toGUIAny (state ^. ui.uiMap) id'
+            (x, y, _, _) <- wg ^. baseProperties.boundary
+            let wg' = wg & baseProperties.boundary .~ return (x, y, w-x, h-y)
+            modify $ ui.uiMap %~ Map.insert id' wg'
+            return $ WindowHandler resize (UIId 0)
+            
+            
+