using (and corrected) refined button handler invocation
TODO: "old" camera handler interferes with left mouse clicks/drags
This commit is contained in:
tpajenka
@ -103,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
|
||||
let pressed = state == SDL.Pressed
|
||||
modify $ mouse.isDown .~ pressed
|
||||
unless pressed $ do
|
||||
st <- get
|
||||
if st ^. mouse.isDragging then
|
||||
modify $ mouse.isDragging .~ False
|
||||
else
|
||||
clickHandler LeftButton (x, y)
|
||||
_ -> when (state == SDL.Released)
|
||||
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
|
||||
SDL.LeftButton -> do
|
||||
let pressed = state == SDL.Pressed
|
||||
modify $ mouse.isDown .~ pressed
|
||||
if pressed
|
||||
then mouseReleaseHandler LeftButton (x, y)
|
||||
else do
|
||||
st <- get
|
||||
if st ^. mouse.isDragging then
|
||||
modify $ mouse.isDragging .~ False
|
||||
else do
|
||||
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
|
||||
@ -138,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
|
||||
let target = toGUIAny hMap wui
|
||||
Just (wid, px') -> do
|
||||
let target = toGUIAny hMap wid
|
||||
target' <- case target ^. eventHandlers.(at MouseEvent) of
|
||||
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 ()
|
||||
|
||||
@ -162,85 +167,111 @@ 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
|
||||
state <- get
|
||||
case state ^. ui.uiButtonState.mouseCurrentWidget of
|
||||
Just (wui, px') -> do
|
||||
let target = toGUIAny (state ^. ui.uiMap) wui
|
||||
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 -> return ()
|
||||
mouseSwitchMouseActive px -- TODO leave current
|
||||
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
|
||||
|
||||
mouseSwitchMouseActive :: Pixel -> Pioneers ()
|
||||
mouseSwitchMouseActive px = do
|
||||
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 hMap px) roots
|
||||
hits <- liftM concat $ mapM (getInsideId px) roots
|
||||
leading <- getLeadingWidget hits
|
||||
case leading of
|
||||
Just (wui, px') -> do
|
||||
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'
|
||||
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 = do
|
||||
state <- get
|
||||
--liftIO $ print $ state ^. ui.uiButtonState
|
||||
case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget?
|
||||
Just (uiw, px') -> do
|
||||
let target = toGUIAny (state ^. ui.uiMap) uiw
|
||||
isIn <- (target ^. baseProperties.isInside) target (px -: px')
|
||||
if isIn == state ^. ui.uiButtonState.mouseInside -- > moving inside or outside
|
||||
then case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do target' <- fromJust (ma ^? onMouseMove) px' target
|
||||
modify $ ui.uiMap %~ Map.insert uiw target'
|
||||
Nothing -> return ()
|
||||
else if isIn -- && not mouseInside --> entering
|
||||
then 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 uiw target'
|
||||
Nothing -> return ()
|
||||
else -- not isIn && mouseInside --> leaving
|
||||
do modify $ ui.uiButtonState.mouseInside .~ False
|
||||
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do
|
||||
target_ <- fromJust (ma ^? onMouseLeave) (px -: px') target --TODO unsafe fromJust
|
||||
target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ -- TODO unsafe fromJust
|
||||
modify $ ui.uiMap %~ Map.insert uiw target'
|
||||
Nothing -> return ()
|
||||
if state ^. ui.uiButtonState.mousePressed <= 0 -- change mouse-active widget?
|
||||
then mouseSwitchMouseActive px
|
||||
else return ()
|
||||
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
|
||||
mouseSwitchMouseActive px
|
||||
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
|
||||
@ -252,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 ()
|
||||
|
||||
Reference in New Issue
Block a user