Merge branch 'ui'

src/UI/Callbacks.hs

@@ -2,7 +2,7 @@ module UI.Callbacks where
 
 
 import qualified Graphics.Rendering.OpenGL.GL         as GL
-import           Control.Lens                         ((^.), (.~), (%~))
+import           Control.Lens                         ((^.), (.~), (%~), (^?), at)
 import           Control.Monad                        (liftM, when, unless)
 import           Control.Monad.RWS.Strict             (ask, get, modify)
 import           Control.Monad.Trans                  (liftIO)
@@ -19,13 +19,13 @@ import Types
 import UI.UIWidgets
 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)
-                          , (UIId 1, createContainer (20, 50, 120, 80) [] 1)
+                          , (UIId 1, createContainer (30, 215, 100, 80) [] 1)
-                          , (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3)
+                          , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
-                          , (UIId 3, createContainer (100, 140, 130, 200) [] 4 )
+                          , (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
-                          , (UIId 4, createButton (30, 200, 60, 175) 2 testMessage)
+                          , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
                           ], [UIId 0])
          
 getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
@@ -89,12 +89,12 @@ eventCallback e = do
                         modify $ aks.down  .~ (movement == SDL.KeyDown)
                     SDL.KeypadPlus ->
                         when (movement == SDL.KeyDown) $ do
-                            modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1))
+                            modify $ gl.glMap.stateTessellationFactor %~ (min 5) . (+1)
                             state <- get
                             liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
                     SDL.KeypadMinus ->
                         when (movement == SDL.KeyDown) $ do
-                            modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1)))
+                            modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1))
                             state <- get
                             liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
                     _ ->
@@ -104,13 +104,13 @@ eventCallback e = do
                 state <- get
                 when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
                     modify $ (mouse.isDragging .~ True)
-                           . (mouse.dragStartX .~ (fromIntegral x))
+                           . (mouse.dragStartX .~ fromIntegral x)
-                           . (mouse.dragStartY .~ (fromIntegral y))
+                           . (mouse.dragStartY .~ fromIntegral y)
                            . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
                            . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
 
-                modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
+                modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
-                       . (mouse.mousePosition. Types._y .~ (fromIntegral y))
+                       . (mouse.mousePosition. Types._y .~ fromIntegral y)
             SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
                 case button of
                     SDL.LeftButton -> do
@@ -122,13 +122,13 @@ eventCallback e = do
                                 modify $ mouse.isDragging .~ False
                             else
                                 clickHandler LeftButton (x, y)
-                    _ -> do when (state == SDL.Released)
+                    _ -> when (state == SDL.Released)
                                 $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
             SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
                 do
                 state <- get
                 let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
-                  modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
+                  modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
             -- there is more (joystic, touchInterface, ...), but currently ignored
             SDL.Quit -> modify $ window.shouldClose .~ True
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
@@ -145,19 +145,19 @@ clickHandler btn pos@(x,y) = do
   case hits of
        [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
        _  -> do
-         changes <- mapM (\uid -> do
+         changes <- mapM (\(uid, pos') -> do
            let w = toGUIAny hMap uid
                short = w ^. baseProperties.shorthand
            bound <- w ^. baseProperties.boundary
            prio <- w ^. baseProperties.priority
-           liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
+           liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
-                            ++ " at [" ++ show x ++ "," ++ show y ++ "]"
+                             ++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
-           case w ^. mouseActions of
+           case w ^. eventHandlers.(at MouseEvent) of
-                Just ma -> do w'  <- (ma ^. onMousePress) btn pos w
+                Just ma -> do w'  <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
-                              w'' <- (ma ^. onMouseRelease) btn pos w'
+                              w'' <- fromJust (ma ^? onMouseRelease) btn pos' True w' -- TODO unsafe fromJust
                               return $ Just (uid, w'')
                 Nothing  -> return Nothing
-           ) $ hits
+           ) hits
          let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
              newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
          modify $ ui.uiMap .~ newMap
@@ -177,16 +177,18 @@ prepareGUI :: Pioneers ()
 prepareGUI = do
                 state <- get
                 roots <- getRoots
-                let tex = (state ^. gl.glHud.hudTexture)
+                let tex = state ^. gl.glHud.hudTexture
                 liftIO $ do
                     -- bind texture - all later calls work on this one.
                     GL.textureBinding GL.Texture2D GL.$= Just tex
-                mapM_ (copyGUI tex) roots
+                mapM_ (copyGUI tex (0, 0)) roots
                 modify $ ui.uiHasChanged .~ False
 
 --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
-copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers ()
+copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset
-copyGUI tex widget = do
+        -> GUIWidget Pioneers -- ^the widget to draw
+        -> Pioneers ()
+copyGUI tex (vX, vY) widget = do
                         (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
                         state <- get
                         let 
@@ -205,11 +207,11 @@ copyGUI tex widget = do
                                 GL.texSubImage2D
                                         GL.Texture2D
                                         0
-                                        (GL.TexturePosition2D (int xoff) (int yoff))
+                                        (GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff)))
                                         (GL.TextureSize2D (int wWidth) (int wHeight))
                                         (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
                         nextChildrenIds <- widget ^. baseProperties.children
-                        mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
+                        mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
 
 --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
 --TODO: Maybe queues are better?

src/UI/UIBase.hs

@@ -3,12 +3,14 @@
 -- TODO: exclude UIMouseState constructor from export?
 module UI.UIBase where
 
-import           Control.Lens             ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses)
+import           Control.Lens             ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
 import           Control.Monad            (liftM)
 import           Data.Array
+import          Data.Bits                 (xor)
 import           Data.Hashable
+import qualified Data.HashMap.Strict      as Map
 import           Data.Ix                  ()
-import           Data.Maybe
+-- import           Data.Maybe
 import           GHC.Generics (Generic)
 
 -- |Unit of screen/window
@@ -17,48 +19,145 @@ type ScreenUnit = Int
 -- | @x@ and @y@ position on screen. 
 type Pixel = (ScreenUnit, ScreenUnit)
 
+-- |Combines two tuples element-wise. Designed for use with 'Pixel'.
+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'.
+(>:) :: (a -> b) -> (a, a) -> (b, b)
+f >: (x, y) = (f x, f y)
+{-# INLINABLE (>:) #-}
+
+-- |Adds two numeric tuples component-wise.
+(+:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
+(+:) = merge (+)
+{-# INLINABLE (+:) #-}
+
+-- |Calculates the component-wise difference between two tuples.
+(-:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
+(-:) = merge (-)
+{-# INLINABLE (-:) #-}
+
+-- |Multiplies two numeric tuples component-wise.
+(*:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
+(*:) = merge (*)
+{-# INLINABLE (*:) #-}
+
+infixl 7 *:
+infixl 6 +:, -:
+infixl 5 >:
+
+-- |Id to reference a specific widget, must be unique.
 newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
 
+-- |Mouse buttons processed by the program.
 data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
     deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
 
-instance Hashable MouseButton
+instance Hashable MouseButton where -- TODO: generic deriving creates functions that run forever
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
-firstButton :: MouseButton
+---------------------------
-firstButton = LeftButton
+--- widget state
+---------------------------
+-- |A key to reference a specific type of 'WidgetState'.
+data WidgetStateKey = MouseStateKey
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
     
-lastButton :: MouseButton
+instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever
-lastButton = MiddleButton
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
--- |The button dependant state of a 'UIMouseState'.
+-- |The button dependant state of a 'MouseState'.
-data UIMouseStateSingle = MouseStateSingle
+data MouseButtonState = MouseButtonState
-    { _mouseIsFiring      :: Bool -- ^firing if pressed but not confirmed
+    { _mouseIsDragging      :: Bool -- ^firing if pressed but not confirmed
     , _mouseIsDeferred    :: Bool
       -- ^deferred if e. g. dragging but outside component
     } deriving (Eq, Show)
     
--- |The state of a clickable ui widget.
+-- |An applied state a widget may take, depending on its usage and event handlers.
-data UIMouseState = MouseState
+data WidgetState = 
-    { _mouseStates :: Array MouseButton UIMouseStateSingle
+    -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
+    MouseState
+        { _mouseStates   :: Array MouseButton MouseButtonState
         , _mouseIsReady  :: Bool -- ^ready if mouse is above component
-    } deriving (Eq, Show)
+        , _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component
+        }
+    deriving (Eq, Show)
+
+---------------------------
+--- events
+---------------------------
+
+-- |A key to reference a specific 'EventHandler'.
+data EventKey = MouseEvent | MouseMotionEvent
+    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.
+data EventHandler m = 
+    -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. 
+    MouseHandler
+        {
+        -- |The function 'onMousePressed' is called when a button is pressed
+        --  while inside a screen coordinate within the widget ('isInside').
+        _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 pressing event occured within the widget ('isInside').
+        --  
+        --  Thus, the mouse is either within the widget or outside while still dragging.
+        _onMouseRelease :: MouseButton       -- ^the released button
+                        -> Pixel             -- ^screen position
+                        -> Bool              -- ^@True@ if the event occured inside the widget
+                        -> 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 space ('isInside').
+        _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 space ('isInside').
+        _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 'onMouseMove' is invoked when the mouse leaves the
+        --  widget's space ('isInside').
+        _onMouseLeave :: Pixel           -- ^screen position
+                      -> GUIWidget m     -- ^widget the event is invoked on
+                      -> m (GUIWidget m) -- ^widget after the event and the altered handler
+        }
+    deriving ()
 
 
--- |Switches primary and secondary mouse actions.
+---------------------------
---  "monad type" "widget type" "original handler"
+--- widgets
-data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
+---------------------------
-
--- |A 'UI.UIClasses.MouseHandler' with button behaviour.
-data ButtonHandler m w = ButtonHandler 
-    { _action :: w -> Pixel -> m w }
-instance Show (ButtonHandler m w) where
-  show _ = "ButtonHandler ***"
 
 -- |A @GUIWidget@ is a visual object the HUD is composed of. 
 data GUIWidget m = Widget
     {_baseProperties :: GUIBaseProperties m
-    ,_mouseActions :: Maybe (GUIMouseActions m)
     ,_graphics :: GUIGraphics m
+    ,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
+    ,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key
     }
 
 -- |Base properties are fundamental settings of any 'GUIWidget'.
@@ -93,46 +192,6 @@ data GUIBaseProperties m = BaseProperties
     _shorthand :: String
     }
 
--- |Mouse actions control the functionality of a 'GUIWidget' on mouse events. 
-data GUIMouseActions m = MouseActions
-    {
-    -- |The @_mouseState@ function returns the current mouse state of a widget.
-    _mouseState :: UIMouseState
-    ,
-    -- |The function 'onMousePressed' is called when a button is pressed
-    --  while inside a screen coordinate within the widget ('isInside').
-    _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 pressing event occured within the widget ('isInside').
-    --  
-    --  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
-    ,
-    -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-    --  widget's space ('isInside').
-    _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 space ('isInside').
-    _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 'onMouseMove' is invoked when the mouse leaves the
-    --  widget's space ('isInside').
-    _onMouseLeave :: Pixel           -- ^screen position
-                  -> GUIWidget m     -- ^widget the event is invoked on
-                  -> m (GUIWidget m) -- ^widget after the event and the altered handler
-    }
 
 
 -- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
@@ -140,93 +199,112 @@ data GUIMouseActions m = MouseActions
 data GUIGraphics m = Graphics 
     {temp :: m Int}
 
-$(makeLenses ''UIMouseState)
+$(makeLenses ''WidgetStateKey)
-$(makeLenses ''UIMouseStateSingle)
+$(makeLenses ''WidgetState)
+$(makeLenses ''MouseButtonState)
+$(makeLenses ''EventKey)
+$(makeLenses ''EventHandler)
 $(makeLenses ''GUIWidget)
 $(makeLenses ''GUIBaseProperties)
-$(makeLenses ''GUIMouseActions)
 $(makeLenses ''GUIGraphics)
 
-initialMouseStateS :: UIMouseStateSingle
+initialButtonState :: MouseButtonState
-initialMouseStateS = MouseStateSingle False False
+initialButtonState = MouseButtonState False False
-{-# INLINE initialMouseStateS #-}
+{-# INLINE initialButtonState #-}
 
 -- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
 --  provided in the passed list.
-initialMouseState :: UIMouseState
+initialMouseState :: WidgetState
-initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)])
+initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
-                               False
+                               False (0, 0)
 {-# INLINE initialMouseState #-}
 
-emptyMouseAction :: (Monad m) => GUIMouseActions m
-emptyMouseAction = MouseActions initialMouseState empty'' empty'' empty' empty' empty'
-    where empty' _ = return
-          empty'' _ _ = return
-
 -- TODO: combined mouse handler
 
--- TODO? breaks if 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 @GUIMouseActions@ handler that enables button clicks.
+--  only fully functional in conjunction with 'setMouseMotionStateActions'.
--- 
+setMouseStateActions :: (Monad m) => EventHandler m
---  The action is peformed right before the button state change.
+setMouseStateActions = MouseHandler press' release'
-buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-                                -> GUIMouseActions m
-buttonMouseActions a = MouseActions initialMouseState press' release' move' enter' leave'
   where 
-    -- |Change 'UIMouseState's '_mouseIsFiring' to @True@.
+    -- |Change 'MouseButtonState's '_mouseIsDragging' to @True@.
     press' b _ w =
-        return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True
+        return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
 
-    -- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and
+    -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
-    --  call action if '_mouseIsFiring' was @True@.
+    release' b _ _ w =
-    release' b p w =
+        return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
-      let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly
+                (mouseIsDragging .~ False) . (mouseIsDeferred .~ False)
-      in do w' <- if fire
-                  then a b w p
-                  else return w
-            return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~
-                (mouseIsFiring .~ False) . (mouseIsDeferred .~ False)
 
-    -- |Do nothing.
+-- |Creates a 'MouseHandler' that sets a widget's 'WidgetState MouseState' properties if present,
-    move' _ = return
+--  only fully functional in conjunction with 'setMouseStateActions'.
+setMouseMotionStateActions :: (Monad m) => EventHandler m
+setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
+  where
+    -- |Updates mouse position.
+    move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p
     
-    -- |Set 'UIMouseState's '_mouseIsReady' to @True@ and
+    -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current
-    --  update dragging state (only drag if inside widget).
+    --  value and sets '_mouseIsDragging' to @False@. 
-    --  In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value
+    enter' p w = return $ w & widgetStates.(ix MouseStateKey)
-    --  and set '_mouseIsFiring' to @False@. 
+                    %~ (mouseIsReady .~ True) . (mousePixel .~ p)
-    enter' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ True)
                      . (mouseStates.mapped %~ (mouseIsDeferred .~ False)
                          -- following line executed BEFORE above line
-                            .(\sState -> sState & mouseIsFiring .~ not (sState ^. mouseIsDeferred)))
+                         . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred)))
    
     
-    -- |Set 'UIMouseState's 'buttonstateIsReady' to @False@ and
+    -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current
-    --  update dragging state (only drag if inside widget).
+    --  value and sets '_mouseIsDeferred' to @False@. 
-    --  In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
+    leave' p w = return $ w & widgetStates.(ix MouseStateKey)
-    --  and set '_buttonstateIsDeferred's' to @False@.
+                    %~ (mouseIsReady .~ False) . (mousePixel .~ p)
-    leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False)
+                     . (mouseStates.mapped %~ (mouseIsDragging .~ False)
-                        .(mouseStates.mapped %~ (mouseIsFiring .~ False)
                          -- following line executed BEFORE above line
-                            .(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
+                         . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
+
+                            
+-- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
+-- |Creates a MouseHandler that reacts on mouse clicks.
+-- 
+--  Does /not/ update 'WidgetState MouseState'!
+buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
+                                -> EventHandler m
+buttonMouseActions a = MouseHandler press' release'
+  where 
+    press' _ _ = return
+
+    release' b p isIn w =
+      if isIn
+      then a b w p
+      else return w
 
 emptyGraphics :: (Monad m) => GUIGraphics m
 emptyGraphics = Graphics (return 3)
 
-isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
+-- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
-isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
+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.
+isInsideExtent :: (ScreenUnit, ScreenUnit) -> Pixel -> Bool
+isInsideExtent (w,h) (x',y') = (x' <= w) && (x' >= 0) && (y' <= h) && (y' >= 0)
+
+-- |Calculates whether a point is within a given rectangle.
+isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
+isInsideRect (x,y,w,h) px = isInsideExtent (w, h) $ px -: (x, y)
+
+
+-- |@GUIBaseProperties@ with a rectangular base that fills the bounds.
 rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
 rectangularBase bnd chld prio short =
     BaseProperties (return bnd) (return chld)
-                   (\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary))
+                   (\w p -> liftM (flip isInsideExtent p . extractExtent) (w ^. baseProperties.boundary)) -- isInside
                    (return prio) short
 
 debugShowWidget' :: (Monad m) => GUIWidget m -> m String
-debugShowWidget' (Widget base mouse _) = do
+debugShowWidget' (Widget base _ _ handler) = do
     bnd <- base ^. boundary
     chld <- base ^. children
     prio <- base ^. priority
     let short = base ^. shorthand
     return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
-                    ",priority:",show prio, maybe "" (const ", with mouse handler") mouse]
+                    ",priority:",show prio, maybe "" (const ", with mouse handler") (Map.lookup MouseEvent handler)]
-    

src/UI/UIOperations.hs

@@ -8,63 +8,40 @@ import           Data.Maybe
 import Types
 import UI.UIBase
 
+-- TODO: test GUI function to scan for overlapping widgets
+
 toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m
 toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
-{-# INLINE toGUIAny #-}
+{-# INLINABLE toGUIAny #-}
 
 toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
 toGUIAnys m = mapMaybe (`Map.lookup` m)
-{-# INLINE toGUIAnys #-}
+{-# INLINABLE toGUIAnys #-}
 -- TODO: check for missing components?
 
 
--- |The function 'getInside' returns child widgets that overlap with a specific
---  screen position.
---  
---  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 
---  have no hit children, which may be the input widget itself,
---  or @[]@ if the point does not hit the widget.
---  
---  This function returns the widgets themselves unlike 'getInsideId'.
-getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-          -> Pixel  -- ^screen position
-          -> GUIWidget Pioneers  -- ^the parent widget
-          -> Pioneers [GUIWidget Pioneers]
-getInside hMap px wg = do
-  inside <- (wg ^. baseProperties.isInside) wg px
-  if inside -- test inside parent's bounding box
-  then do
-       childrenIds <- wg ^. baseProperties.children
-       hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds)
-       case hitChildren of
-            [] -> return [wg]
-            _  -> return hitChildren
-  else return []
---TODO: Priority queue?
-
 -- |The function 'getInsideId' returns child widgets that overlap with a 
---  specific screen position.
+--  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 
 --  have no hit children, which may be the input widget itself,
 --  or @[]@ if the point does not hit the widget.
---  
---  This function returns the 'UIId's of the widgets unlike 'getInside'.
 getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
             -> Pixel  -- ^screen position
             -> UIId  -- ^the parent widget
-            -> Pioneers [UIId]
+            -> Pioneers [(UIId, Pixel)]
 getInsideId hMap px uid = do
   let wg  = toGUIAny hMap uid
-  inside <- (wg ^. baseProperties.isInside) wg px
+  bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary
+  let px' = px -: (bX, bY)
+  inside <- liftM (isInsideRect bnd px &&) $ (wg ^. baseProperties.isInside) wg px'
   if inside -- test inside parent's bounding box
     then do
       childrenIds <- wg ^. baseProperties.children
-      hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds
+      hitChildren <- liftM concat $ mapM (getInsideId hMap px') childrenIds
       case hitChildren of
-           [] -> return [uid]
+           [] -> return [(uid, px')]
            _  -> return hitChildren
     else return []
 --TODO: Priority queue?

src/UI/UIWidgets.hs

@@ -16,27 +16,23 @@ import UI.UIBase
 
 createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
 createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
-                                          Nothing
                                        emptyGraphics
+                                       Map.empty -- widget states
+                                       Map.empty -- event handlers
 
 
 createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
 createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
-                                      Nothing
                                    emptyGraphics
+                                   Map.empty -- widget states
+                                   Map.empty -- event handlers
   where
     autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
     autosize' = do
         state <- get
         let hmap = state ^. ui . uiMap
-            -- TODO: local coordinates
             determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
-            determineSize' (x, y, w, h) (x', y', w', h') =
+            determineSize' (x, y, w, h) (x', y', w', h') = (x, y, max w (x' + w'), max h (y' + h'))
-               let x'' = if x' < x then x' else x
-                   y'' = if y' < y then y' else y
-                   w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
-                   h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
-                in (x'', y'', w'', h'')
         case chld of
              [] -> return bnd
              cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs 
@@ -44,5 +40,6 @@ createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & bounda
 
 createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m
 createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
-                                         (Just $ buttonMouseActions action)
                                       emptyGraphics
+                                      (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
+                                      (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers