Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

using (and corrected) refined button handler invocation

Browse Source 
TODO: "old" camera handler interferes with left mouse clicks/drags
This commit is contained in:
tpajenka
2014-05-15 22:08:43 +02:00
parent c17852d8e1
commit 271497be81
3 changed files with 146 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files

138
src/UI/Callbacks.hs
View File

@@ -103,28 +103,34 @@ eventCallback e = do
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
do do
state <- get state <- get
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ if state ^. mouse.isDown && not (state ^. mouse.isDragging)
then
modify $ (mouse.isDragging .~ True) 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.dragStartXAngle .~ (state ^. camera.xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
else mouseMoveHandler (x, y)
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 SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
do
case button of 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
then mouseReleaseHandler LeftButton (x, y)
else do
st <- get st <- get
if st ^. mouse.isDragging then if st ^. mouse.isDragging then
modify $ mouse.isDragging .~ False modify $ mouse.isDragging .~ False
else else do
clickHandler LeftButton (x, y) mousePressHandler LeftButton (x, y)
_ -> when (state == SDL.Released) _ -> case state of
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button 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 SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do do
state <- get state <- get
@@ -138,17 +144,16 @@ eventCallback e = do
mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers)) mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
-> MouseButton -> Pixel -> Pioneers () -> MouseButton -> Pixel -> Pioneers ()
mouseButtonHandler transFunc btn px = do mouseButtonHandler transFunc btn px = do
modify $ ui.uiButtonState %~ (mousePressed %~ (+1)) -- TODO: what happens if released outside window? not reset properly?
state <- get state <- get
let hMap = state ^. ui.uiMap let hMap = state ^. ui.uiMap
currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget
case currentWidget of 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 target' <- case target ^. eventHandlers.(at MouseEvent) of
Just ma -> transFunc ma btn (px -: px') target Just ma -> transFunc ma btn (px -: px') target
Nothing -> return target Nothing -> return target
modify $ ui.uiMap %~ Map.insert wui target' modify $ ui.uiMap %~ Map.insert wid target'
return () return ()
Nothing -> return () Nothing -> return ()
@@ -162,85 +167,111 @@ mouseReleaseHandler btn px = do
modify $ ui.uiButtonState %~ (mousePressed %~ flip (-) 1) -- TODO: what happens if pressed outside window? not set properly? modify $ ui.uiButtonState %~ (mousePressed %~ flip (-) 1) -- TODO: what happens if pressed outside window? not set properly?
mouseButtonHandler (\ma -> fromJust (ma ^? onMouseRelease)) btn px mouseButtonHandler (\ma -> fromJust (ma ^? onMouseRelease)) btn px
state <- get state <- get
unless (state ^. ui.uiButtonState.mousePressed > 0) $ do
case state ^. ui.uiButtonState.mouseCurrentWidget of case state ^. ui.uiButtonState.mouseCurrentWidget of
Just (wui, px') -> do Just (wid, px') -> do
let target = toGUIAny (state ^. ui.uiMap) wui 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? target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do Just ma -> do
target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
Nothing -> return target Nothing -> return target
modify $ ui.uiMap %~ Map.insert wui target' modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return () Nothing -> return ()
mouseSwitchMouseActive px -- TODO leave current mouseSetMouseActive px -- TODO leave current
mouseSwitchMouseActive :: Pixel -> Pioneers () mouseSetMouseActiveTargeted :: (UIId, Pixel) -- ^ (target widget, local coorinates)
mouseSwitchMouseActive px = do -> Pixel -- ^ global coordinates
-> Pioneers ()
mouseSetMouseActiveTargeted (wid, px') px = do
state <- get state <- get
--liftIO $ putStrLn $ "new target: " ++ show wid
let hMap = state ^. ui.uiMap 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 roots <- getRootIds
hits <- liftM concat $ mapM (getInsideId hMap px) roots hits <- liftM concat $ mapM (getInsideId px) roots
leading <- getLeadingWidget hits leading <- getLeadingWidget hits
case leading of case leading of
Just (wui, px') -> do Just hit -> mouseSetMouseActiveTargeted hit px
let target = toGUIAny hMap wui
modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Just (wui, 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 wui target'
Nothing -> modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Nothing) . (mouseInside .~ False) 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 :: Pixel -> Pioneers ()
mouseMoveHandler px = do mouseMoveHandler px = do
state <- get state <- get
--liftIO $ print $ state ^. ui.uiButtonState
case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget? case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget?
Just (uiw, px') -> do Just (wid, px') -> do
let target = toGUIAny (state ^. ui.uiMap) uiw let target = toGUIAny (state ^. ui.uiMap) wid
isIn <- (target ^. baseProperties.isInside) target (px -: px') inTest <- isHittingChild (px -: px') target
if isIn == state ^. ui.uiButtonState.mouseInside -- > moving inside or outside case inTest of
then case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? 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' target
modify $ ui.uiMap %~ Map.insert uiw target' modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return () Nothing -> return ()
else if isIn -- && not mouseInside --> entering else if b then -- && not mouseInside --> entering
then do modify $ ui.uiButtonState.mouseInside .~ True do modify $ ui.uiButtonState.mouseInside .~ True
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do Just ma -> do
target_ <- fromJust (ma ^? onMouseEnter) (px -: px') target --TODO unsafe fromJust target_ <- fromJust (ma ^? onMouseEnter) (px -: px') target --TODO unsafe fromJust
target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ --TODO unsafe fromJust target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ --TODO unsafe fromJust
modify $ ui.uiMap %~ Map.insert uiw target' modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return () Nothing -> return ()
else -- not isIn && mouseInside --> leaving else -- not b && mouseInside --> leaving
do modify $ ui.uiButtonState.mouseInside .~ False do mouseSetLeaving wid (px -: px')
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? when (state ^. ui.uiButtonState.mousePressed <= 0) -- change mouse-active widget?
Just ma -> do $ mouseSetMouseActive px
target_ <- fromJust (ma ^? onMouseLeave) (px -: px') target --TODO unsafe fromJust
target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ -- TODO unsafe fromJust Right childHit -> do
modify $ ui.uiMap %~ Map.insert uiw target' mouseSetLeaving wid (px -: px')
Nothing -> return () when (state ^. ui.uiButtonState.mousePressed <= 0) -- change mouse-active widget?
if state ^. ui.uiButtonState.mousePressed <= 0 -- change mouse-active widget? $ mouseSetMouseActiveTargeted childHit px
then mouseSwitchMouseActive px
else return ()
Nothing -> do Nothing -> do
mouseSwitchMouseActive px mouseSetMouseActive px
-- | Handler for UI-Inputs. -- | Handler for UI-Inputs.
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... -- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
clickHandler :: MouseButton -> Pixel -> Pioneers () clickHandler :: MouseButton -> Pixel -> Pioneers ()
clickHandler btn pos@(x,y) = do clickHandler btn pos@(x,y) = do
state <- get
let hMap = state ^. ui.uiMap
roots <- getRootIds roots <- getRootIds
hits <- liftM concat $ mapM (getInsideId hMap pos) roots hits <- liftM concat $ mapM (getInsideId pos) roots
case hits of case hits of
[] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"] [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
_ -> do _ -> do
changes <- mapM (\(uid, pos') -> do changes <- mapM (\(uid, pos') -> do
let w = toGUIAny hMap uid state <- get
let w = toGUIAny (state ^. ui.uiMap) uid
short = w ^. baseProperties.shorthand short = w ^. baseProperties.shorthand
bound <- w ^. baseProperties.boundary bound <- w ^. baseProperties.boundary
prio <- w ^. baseProperties.priority prio <- w ^. baseProperties.priority
@@ -252,7 +283,8 @@ clickHandler btn pos@(x,y) = do
return $ Just (uid, w'') return $ Just (uid, w'')
Nothing -> return Nothing Nothing -> return Nothing
) hits ) 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 newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
modify $ ui.uiMap .~ newMap modify $ ui.uiMap .~ newMap
return () return ()

2
src/UI/UIBase.hs
View File

@@ -196,7 +196,7 @@ data GUIBaseProperties m = BaseProperties
-- The default implementations tests if the point is within the rectangle specified by the -- The default implementations tests if the point is within the rectangle specified by the
-- 'getBoundary' function. -- 'getBoundary' function.
_isInside :: GUIWidget m _isInside :: GUIWidget m
-> Pixel -- ^screen position -> Pixel -- ^local coordinates
-> m Bool -> m Bool
, ,
-- |The @_getPriority@ function returns the priority score of a @GUIWidget@. -- |The @_getPriority@ function returns the priority score of a @GUIWidget@.

46
src/UI/UIOperations.hs
View File

@@ -2,6 +2,8 @@ module UI.UIOperations where
import Control.Lens ((^.)) import Control.Lens ((^.))
import Control.Monad (liftM) import Control.Monad (liftM)
--import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get)
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import Data.Maybe import Data.Maybe
@@ -19,6 +21,14 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
{-# INLINABLE toGUIAnys #-} {-# INLINABLE toGUIAnys #-}
-- TODO: check for missing components? -- 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 -- |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.
@@ -27,27 +37,49 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
-- considered part of the component. The function returns all hit widgets that -- considered part of the component. The function returns all hit widgets that
-- have no hit children, which may be the input widget itself, -- have no hit children, which may be the input widget itself,
-- or @[]@ if the point does not hit the widget. -- 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 -> UIId -- ^the parent widget
-> Pioneers [(UIId, Pixel)] -> 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) 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 if inside -- test inside parent's bounding box
then do then do
childrenIds <- wg ^. baseProperties.children childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInsideId hMap px') childrenIds hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds
case hitChildren of case hitChildren of
[] -> return [(uid, px')] [] -> return [(uid, px')]
_ -> return hitChildren _ -> return hitChildren
else return [] else return []
--TODO: Priority queue? --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 getLeadingWidget :: [(UIId, Pixel)] -- ^widgets and their screen positions
-> Pioneers (Maybe (UIId, Pixel)) -- ^the leading widget -> Pioneers (Maybe (UIId, Pixel)) -- ^the leading widget
getLeadingWidget [] = return Nothing getLeadingWidget [] = return Nothing
getLeadingWidget (x:_) = return $ Just x 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