diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index d21da85..e49b4b1 100644 --- a/src/UI/Callbacks.hs +++ b/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 diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index dc38f19..0c31527 100644 --- a/src/UI/UIBase.hs +++ b/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 diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index eafb1b5..a0908a5 100644 --- a/src/UI/UIOperations.hs +++ b/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 + 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?