Merge branch 'ui' into tessallation

src/Main.hs

@@ -162,7 +162,7 @@ main =
                         { _uiHasChanged        = True
                         , _uiMap = guiMap
                         , _uiRoots = guiRoots
-                        , _uiButtonState = UI.UIButtonState 0 Nothing
+                        , _uiButtonState = UI.UIButtonState 0 Nothing False
                         }
               }
 
@@ -234,7 +234,7 @@ run = do
         let 	double = fromRational.toRational :: (Real a) => a -> Double
 		targetFramerate = 60.0
 		targetFrametime = 1.0/targetFramerate
-		targetFrametimeμs = targetFrametime * 1000000.0
+		--targetFrametimeμs = targetFrametime * 1000000.0
         now <- getCurrentTime
         let diff  = diffUTCTime now (state ^. io.clock) -- get time-diffs
             title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]

src/UI/Callbacks.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DoAndIfThenElse #-}
 module UI.Callbacks where
 
 
@@ -102,28 +103,34 @@ eventCallback e = do
             SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
                 do
                 state <- get
-                when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
+                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 button of
-                    SDL.LeftButton -> do
+                     SDL.LeftButton -> do
-                        let pressed = state == SDL.Pressed
+                         let pressed = state == SDL.Pressed
-                        modify $ mouse.isDown .~ pressed
+                         modify $ mouse.isDown .~ pressed
-                        unless pressed $ do
+                         if pressed 
-                            st <- get
+                           then mouseReleaseHandler LeftButton (x, y)
-                            if st ^. mouse.isDragging then
+                           else do
-                                modify $ mouse.isDragging .~ False
+                             st <- get
-                            else
+                             if st ^. mouse.isDragging then
-                                clickHandler LeftButton (x, y)
+                                 modify $ mouse.isDragging .~ False
-                    _ -> when (state == SDL.Released)
+                             else do
-                                $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
+                                 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
                 state <- get
@@ -137,17 +144,16 @@ eventCallback e = do
 mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
                    -> MouseButton -> Pixel -> Pioneers ()
 mouseButtonHandler transFunc btn px = do
-    modify $ ui.uiButtonState %~ (mousePressed %~ (+1)) -- TODO: what happens if released outside window? not reset properly?
     state <- get
     let hMap = state ^. ui.uiMap
         currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget
     case currentWidget of
-         Just (wui, px') -> do
+         Just (wid, px') -> do
-             let target = toGUIAny hMap wui
+             let target = toGUIAny hMap wid
              target' <- case target ^. eventHandlers.(at MouseEvent) of
-                             Just ma -> transFunc ma btn (px -: px') target -- TODO unsafe fromJust
+                             Just ma -> transFunc ma btn (px -: px') target
                              Nothing  -> return target
-             modify $ ui.uiMap %~ Map.insert wui target'
+             modify $ ui.uiMap %~ Map.insert wid target'
              return ()
          Nothing -> return ()
          
@@ -160,24 +166,112 @@ mouseReleaseHandler :: MouseButton -> Pixel -> Pioneers ()
 mouseReleaseHandler btn px = do
     modify $ ui.uiButtonState %~ (mousePressed %~ flip (-) 1) -- TODO: what happens if pressed outside window? not set properly?
     mouseButtonHandler (\ma -> fromJust (ma ^? onMouseRelease)) btn px
-    -- TODO: trigger move/enter/leave
+    state <- get
+    unless (state ^. ui.uiButtonState.mousePressed > 0) $ do
+      case state ^. ui.uiButtonState.mouseCurrentWidget of
+           Just (wid, px') -> do
+               let target = toGUIAny (state ^. ui.uiMap) wid
+               -- debug
+               let short = target ^. baseProperties.shorthand
+               bound <- target ^. baseProperties.boundary
+               prio <- target ^. baseProperties.priority
+               liftIO $ putStrLn $ "releasing(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
+                                ++ show prio ++ " at [" ++ show (fst px) ++ "," ++ show (snd px) ++ "]"
+               -- /debug
+               target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
+                               Just ma -> do
+                                    target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
+                                    fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
+                               Nothing  -> return target
+               modify $ ui.uiMap %~ Map.insert wid target'
+           Nothing -> return ()
+      mouseSetMouseActive px -- TODO leave current
 
+mouseSetMouseActiveTargeted :: (UIId, Pixel) -- ^ (target widget, local coorinates)
+                               -> Pixel         -- ^ global coordinates
+                               -> Pioneers ()
+mouseSetMouseActiveTargeted (wid, px') px = do
+    state <- get
+    --liftIO $ putStrLn $ "new target: " ++ show wid
+    let hMap = state ^. ui.uiMap
+        target = toGUIAny hMap wid
+    modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Just (wid, px -: px')) . (mouseInside .~ True)
+    target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
+                    Just ma -> do
+                         target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
+                         fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
+                    Nothing  -> return target
+    modify $ ui.uiMap %~ Map.insert wid target'
+    
+mouseSetMouseActive :: Pixel -- ^global coordinates
+                       -> Pioneers ()
+mouseSetMouseActive px = do
+    roots <- getRootIds
+    hits <- liftM concat $ mapM (getInsideId px) roots
+    leading <- getLeadingWidget hits
+    case leading of
+         Just hit -> mouseSetMouseActiveTargeted hit px
+         Nothing -> modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Nothing) . (mouseInside .~ False)
+        
+mouseSetLeaving :: UIId -> Pixel -> Pioneers ()
+mouseSetLeaving wid px = do
+    state <- get
+    let target = toGUIAny (state ^. ui.uiMap) wid
+    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
+             modify $ ui.uiMap %~ Map.insert wid target'
+         Nothing -> return ()
+        
 mouseMoveHandler :: Pixel -> Pioneers ()
-mouseMoveHandler px = undefined
+mouseMoveHandler px = do
+    state <- get
+    --liftIO $ print $ state ^. ui.uiButtonState
+    case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget?
+         Just (wid, px') -> do
+             let target = toGUIAny (state ^. ui.uiMap) wid
+             inTest <- isHittingChild (px -: px') target
+             case inTest of
+                  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
+                                           modify $ ui.uiMap %~ Map.insert wid target'
+                             Nothing -> return () 
+                      else if b then -- && not mouseInside --> entering
+                        do modify $ ui.uiButtonState.mouseInside .~ True
+                           case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
+                                Just ma -> do
+                                    target_ <- fromJust (ma ^? onMouseEnter) (px -: px') target --TODO unsafe fromJust
+                                    target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ --TODO unsafe fromJust
+                                    modify $ ui.uiMap %~ Map.insert wid target'
+                                Nothing -> return ()
+                      else -- not b && mouseInside --> leaving
+                        do mouseSetLeaving wid (px -: px')
+                           when (state ^. ui.uiButtonState.mousePressed <= 0)  -- change mouse-active widget?
+                               $ mouseSetMouseActive px
+
+                  Right childHit -> do
+                      mouseSetLeaving wid (px -: px')
+                      when (state ^. ui.uiButtonState.mousePressed <= 0)  -- change mouse-active widget?
+                          $ mouseSetMouseActiveTargeted childHit px
+         Nothing -> 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
-  state <- get
-  let hMap = state ^. ui.uiMap
   roots <- getRootIds
-  hits <- liftM concat $ mapM (getInsideId hMap pos) roots
+  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
-           let w = toGUIAny hMap uid
+           state <- get
+           let w = toGUIAny (state ^. ui.uiMap) uid
                short = w ^. baseProperties.shorthand
            bound <- w ^. baseProperties.boundary
            prio <- w ^. baseProperties.priority
@@ -189,7 +283,8 @@ clickHandler btn pos@(x,y) = do
                               return $ Just (uid, w'')
                 Nothing  -> return Nothing
            ) hits
-         let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
+         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 ()

src/UI/UIBase.hs

@@ -77,6 +77,7 @@ data UIButtonState = UIButtonState
       -- ^the current mouse-active widget and its global coordinates.
       --  If @_mousePressed == 0@: widget the mouse is hovering over,
       --  otherwise: widget the first button has been pressed on.
+    , _mouseInside :: Bool -- ^@True@ if the mouse is currently within the mouse-active widget
     } deriving (Show, Eq)
 
 -- |The button dependant state of a 'MouseState'.
@@ -195,7 +196,7 @@ data GUIBaseProperties m = BaseProperties
     --  The default implementations tests if the point is within the rectangle specified by the 
     --  'getBoundary' function.
     _isInside :: GUIWidget m
-              -> Pixel  -- ^screen position
+              -> Pixel  -- ^local coordinates
               -> m Bool
     ,
     -- |The @_getPriority@ function returns the priority score of a @GUIWidget@.

src/UI/UIOperations.hs

@@ -2,6 +2,8 @@ module UI.UIOperations where
 
 import           Control.Lens                    ((^.))
 import           Control.Monad                   (liftM)
+--import           Control.Monad.IO.Class          (liftIO)
+import           Control.Monad.RWS.Strict        (get)
 import qualified Data.HashMap.Strict             as Map
 import           Data.Maybe
 
@@ -19,6 +21,14 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
 {-# INLINABLE toGUIAnys #-}
 -- TODO: check for missing components?
 
+-- | Tests whether a point is inside a widget by testing its bounding box first.
+isInsideFast :: Monad m => GUIWidget m
+             -> Pixel  -- ^ local coordinates
+             -> m Bool
+isInsideFast wg px = do
+  (_, _, w, h) <- wg ^. baseProperties.boundary
+  liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
+
 
 -- |The function 'getInsideId' returns child widgets that overlap with a 
 --  specific screen position and the pixel's local coordinates.
@@ -27,27 +37,49 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
 --  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.
-getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
+getInsideId :: Pixel  -- ^parent’s local coordinates
-            -> Pixel  -- ^screen position
             -> UIId  -- ^the parent widget
             -> Pioneers [(UIId, Pixel)]
-getInsideId hMap px uid = do
+getInsideId px uid = do
-  let wg  = toGUIAny hMap uid
+  state <- get
-  bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary
+  let wg  = toGUIAny (state ^. ui.uiMap) uid
+  (bX, bY, _, _) <- wg ^. baseProperties.boundary
   let px' = px -: (bX, bY)
-  inside <- liftM (isInsideRect bnd px &&) $ (wg ^. baseProperties.isInside) wg px'
+  inside <- isInsideFast 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 px') childrenIds
       case hitChildren of
            [] -> return [(uid, px')]
            _  -> return hitChildren
     else return []
 --TODO: Priority queue?
+--TODO: only needs to return single target if non-overlapping-child convention applies
 
+-- TODO not needed if non-overlapping-child convention applies
 getLeadingWidget :: [(UIId, Pixel)]  -- ^widgets and their screen positions
                  -> Pioneers (Maybe (UIId, Pixel))    -- ^the leading widget
 getLeadingWidget [] = return Nothing
 getLeadingWidget (x:_) = return $ Just x
               
+-- |The function 'isHittingChild' tests if a pixel is hitting a child of the given widget.
+--  
+--  @'Left' 'False'@ is returned if the point is outside the widget,
+--  @'Left' 'True'@ is returned if the point is inside the widget and hits no child and
+--  'Right' in combination with both the innermost hit child and the position’s local coordinates
+--  is returned otherwise.
+isHittingChild :: Pixel -- ^parent’s local coordinates
+               -> GUIWidget Pioneers -- ^parent widget
+               -> Pioneers (Either Bool (UIId, Pixel))
+isHittingChild px wg = do
+  isIn <- isInsideFast wg px
+  if isIn
+    then do
+      chld <- wg ^. baseProperties.children
+      hitChld <- liftM concat $ mapM (getInsideId px) chld
+      hitLead <- getLeadingWidget hitChld
+      case hitLead of
+           Nothing -> return $ Left True
+           Just h -> return $ Right h
+    else return $ Left False