mouse events use local widget coordinates

src/UI/Callbacks.hs

@@ -145,7 +145,7 @@ 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
@@ -153,8 +153,8 @@ clickHandler btn pos@(x,y) = do
            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 True w' -- TODO unsafe fromJust
+                Just ma -> do w'  <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
+                              w'' <- fromJust (ma ^? onMouseRelease) btn pos' True w' -- TODO unsafe fromJust
                               return $ Just (uid, w'')
                 Nothing  -> return Nothing
            ) hits

src/UI/UIBase.hs

@@ -44,6 +44,10 @@ f >: (x, y) = (f x, f y)
 (*:) = 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)
 
@@ -275,13 +279,25 @@ buttonMouseActions a = MouseHandler press' release'
 emptyGraphics :: (Monad m) => GUIGraphics m
 emptyGraphics = Graphics (return 3)
 
-isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
-isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
+-- |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.
+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)) -- isInside
+                   (\w p -> liftM (flip isInsideExtent p . extractExtent) (w ^. baseProperties.boundary)) -- isInside
                    (return prio) short
 
 debugShowWidget' :: (Monad m) => GUIWidget m -> m String

src/UI/UIOperations.hs

@@ -21,7 +21,7 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
 
 
 -- |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 
@@ -30,17 +30,18 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
 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
   bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary
-  inside <- liftM (isInsideRect bnd px &&) $ (wg ^. baseProperties.isInside) wg px
+  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 -: (bX, bY))) childrenIds
+      hitChildren <- liftM concat $ mapM (getInsideId hMap px') childrenIds
       case hitChildren of
-           [] -> return [uid]
+           [] -> return [(uid, px')]
            _  -> return hitChildren
     else return []
 --TODO: Priority queue?