diff --git a/src/Main.hs b/src/Main.hs index 5187e3d..0a7e867 100644 --- a/src/Main.hs +++ b/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"] diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 1f77d10..31d5a73 100644 --- a/src/UI/Callbacks.hs +++ b/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 - 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 @@ -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 - 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 -- 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 () diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 9ecf55e..b2409e2 100644 --- a/src/UI/UIBase.hs +++ b/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@. diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 5c54f27..4f0ad2e 100644 --- a/src/UI/UIOperations.hs +++ b/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 - -> Pixel -- ^screen position +getInsideId :: Pixel -- ^parent’s local coordinates -> UIId -- ^the parent widget -> Pioneers [(UIId, Pixel)] -getInsideId hMap px uid = do - let wg = toGUIAny hMap uid - bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary +getInsideId px uid = do + state <- get + 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 \ No newline at end of file