diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 7d71021..e49b4b1 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -2,7 +2,7 @@ module UI.Callbacks where import qualified Graphics.Rendering.OpenGL.GL as GL -import Control.Lens ((^.), (.~), (%~)) +import Control.Lens ((^.), (.~), (%~), (^?), at) import Control.Monad (liftM, when, unless) import Control.Monad.RWS.Strict (ask, get, modify) import Control.Monad.Trans (liftIO) @@ -19,13 +19,13 @@ import Types import UI.UIWidgets import UI.UIOperations - +-- TODO: define GUI positions in a file createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId]) createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0) - , (UIId 1, createContainer (20, 50, 120, 80) [] 1) - , (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3) - , (UIId 3, createContainer (100, 140, 130, 200) [] 4 ) - , (UIId 4, createButton (30, 200, 60, 175) 2 testMessage) + , (UIId 1, createContainer (30, 215, 100, 80) [] 1) + , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3) + , (UIId 3, createContainer (80, 15, 130, 90) [] 4 ) + , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage) ], [UIId 0]) getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers] @@ -89,12 +89,12 @@ eventCallback e = do modify $ aks.down .~ (movement == SDL.KeyDown) SDL.KeypadPlus -> when (movement == SDL.KeyDown) $ do - modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1)) + modify $ gl.glMap.stateTessellationFactor %~ (min 5) . (+1) state <- get liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] SDL.KeypadMinus -> when (movement == SDL.KeyDown) $ do - modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1))) + modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1)) state <- get liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] _ -> @@ -104,13 +104,13 @@ eventCallback e = do state <- get when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ modify $ (mouse.isDragging .~ True) - . (mouse.dragStartX .~ (fromIntegral x)) - . (mouse.dragStartY .~ (fromIntegral y)) + . (mouse.dragStartX .~ fromIntegral x) + . (mouse.dragStartY .~ fromIntegral y) . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) - modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) - . (mouse.mousePosition. Types._y .~ (fromIntegral 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 case button of SDL.LeftButton -> do @@ -122,13 +122,13 @@ eventCallback e = do modify $ mouse.isDragging .~ False else clickHandler LeftButton (x, y) - _ -> do when (state == SDL.Released) + _ -> when (state == SDL.Released) $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do state <- get let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in - modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist') + modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] @@ -145,19 +145,19 @@ 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 prio <- w ^. baseProperties.priority - liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio - ++ " at [" ++ show x ++ "," ++ show y ++ "]" - case w ^. mouseActions of - Just ma -> do w' <- (ma ^. onMousePress) btn pos w - w'' <- (ma ^. onMouseRelease) btn pos w' + 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 return $ Just (uid, w'') Nothing -> return Nothing - ) $ hits + ) hits let newMap :: Map.HashMap UIId (GUIWidget Pioneers) newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes modify $ ui.uiMap .~ newMap @@ -177,16 +177,18 @@ prepareGUI :: Pioneers () prepareGUI = do state <- get roots <- getRoots - let tex = (state ^. gl.glHud.hudTexture) + let tex = state ^. gl.glHud.hudTexture liftIO $ do -- bind texture - all later calls work on this one. GL.textureBinding GL.Texture2D GL.$= Just tex - mapM_ (copyGUI tex) roots + mapM_ (copyGUI tex (0, 0)) roots modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers () -copyGUI tex widget = do +copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset + -> GUIWidget Pioneers -- ^the widget to draw + -> Pioneers () +copyGUI tex (vX, vY) widget = do (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary state <- get let @@ -205,11 +207,11 @@ copyGUI tex widget = do GL.texSubImage2D GL.Texture2D 0 - (GL.TexturePosition2D (int xoff) (int yoff)) + (GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff))) (GL.TextureSize2D (int wWidth) (int wHeight)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr) nextChildrenIds <- widget ^. baseProperties.children - mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds + mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. --TODO: Maybe queues are better? \ No newline at end of file diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 0ba8094..0c31527 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -3,12 +3,14 @@ -- TODO: exclude UIMouseState constructor from export? module UI.UIBase where -import Control.Lens ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses) +import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses) import Control.Monad (liftM) import Data.Array +import Data.Bits (xor) import Data.Hashable +import qualified Data.HashMap.Strict as Map import Data.Ix () -import Data.Maybe +-- import Data.Maybe import GHC.Generics (Generic) -- |Unit of screen/window @@ -17,48 +19,145 @@ type ScreenUnit = Int -- | @x@ and @y@ position on screen. type Pixel = (ScreenUnit, ScreenUnit) +-- |Combines two tuples element-wise. Designed for use with 'Pixel'. +merge :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) +merge f (x, y) (x', y') = (f x x', f y y') +{-# INLINABLE merge #-} + +-- |Maps the over the elements of a tuple. Designed for use with 'Pixel'. +(>:) :: (a -> b) -> (a, a) -> (b, b) +f >: (x, y) = (f x, f y) +{-# INLINABLE (>:) #-} + +-- |Adds two numeric tuples component-wise. +(+:) :: (Num a) => (a, a) -> (a, a) -> (a, a) +(+:) = merge (+) +{-# INLINABLE (+:) #-} + +-- |Calculates the component-wise difference between two tuples. +(-:) :: (Num a) => (a, a) -> (a, a) -> (a, a) +(-:) = merge (-) +{-# INLINABLE (-:) #-} + +-- |Multiplies two numeric tuples component-wise. +(*:) :: (Num a) => (a, a) -> (a, a) -> (a, a) +(*:) = 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) +-- |Mouse buttons processed by the program. data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2 deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) -instance Hashable MouseButton +instance Hashable MouseButton where -- TODO: generic deriving creates functions that run forever + hash = fromEnum + hashWithSalt salt x = (salt * 16777619) `xor` hash x -firstButton :: MouseButton -firstButton = LeftButton +--------------------------- +--- widget state +--------------------------- +-- |A key to reference a specific type of 'WidgetState'. +data WidgetStateKey = MouseStateKey + deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) + +instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever + hash = fromEnum + hashWithSalt salt x = (salt * 16777619) `xor` hash x -lastButton :: MouseButton -lastButton = MiddleButton - --- |The button dependant state of a 'UIMouseState'. -data UIMouseStateSingle = MouseStateSingle - { _mouseIsFiring :: Bool -- ^firing if pressed but not confirmed +-- |The button dependant state of a 'MouseState'. +data MouseButtonState = MouseButtonState + { _mouseIsDragging :: Bool -- ^firing if pressed but not confirmed , _mouseIsDeferred :: Bool -- ^deferred if e. g. dragging but outside component } deriving (Eq, Show) + +-- |An applied state a widget may take, depending on its usage and event handlers. +data WidgetState = + -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'. + MouseState + { _mouseStates :: Array MouseButton MouseButtonState + , _mouseIsReady :: Bool -- ^ready if mouse is above component + , _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component + } + deriving (Eq, Show) --- |The state of a clickable ui widget. -data UIMouseState = MouseState - { _mouseStates :: Array MouseButton UIMouseStateSingle - , _mouseIsReady :: Bool -- ^ready if mouse is above component - } deriving (Eq, Show) +--------------------------- +--- events +--------------------------- + +-- |A key to reference a specific 'EventHandler'. +data EventKey = MouseEvent | MouseMotionEvent + deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) + +instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever + hash = fromEnum + hashWithSalt salt x = (salt * 16777619) `xor` hash x + +--- event handlers + +-- |A handler to react on certain events. +data EventHandler m = + -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. + MouseHandler + { + -- |The function 'onMousePressed' is called when a button is pressed + -- while inside a screen coordinate within the widget ('isInside'). + _onMousePress :: MouseButton -- ^the pressed button + -> Pixel -- ^screen position + -> GUIWidget m -- ^widget the event is invoked on + -> m (GUIWidget m) -- ^widget after the event and the possibly altered mouse handler + , + -- |The function 'onMouseReleased' is called when a button is released + -- while the pressing event occured within the widget ('isInside'). + -- + -- Thus, the mouse is either within the widget or outside while still dragging. + _onMouseRelease :: MouseButton -- ^the released button + -> Pixel -- ^screen position + -> Bool -- ^@True@ if the event occured inside the widget + -> GUIWidget m -- ^widget the event is invoked on + -> m (GUIWidget m) -- ^widget after the event and the altered handler + } + | + -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. + MouseMotionHandler + { + -- |The function 'onMouseMove' is invoked when the mouse is moved inside the + -- widget's space ('isInside'). + _onMouseMove :: Pixel -- ^screen position + -> GUIWidget m -- ^widget the event is invoked on + -> m (GUIWidget m) -- ^widget after the event and the altered handler + , + -- |The function 'onMouseMove' is invoked when the mouse enters the + -- widget's space ('isInside'). + _onMouseEnter :: Pixel -- ^screen position + -> GUIWidget m -- ^widget the event is invoked on + -> m (GUIWidget m) -- ^widget after the event and the altered handler + , + -- |The function 'onMouseMove' is invoked when the mouse leaves the + -- widget's space ('isInside'). + _onMouseLeave :: Pixel -- ^screen position + -> GUIWidget m -- ^widget the event is invoked on + -> m (GUIWidget m) -- ^widget after the event and the altered handler + } + deriving () --- |Switches primary and secondary mouse actions. --- "monad type" "widget type" "original handler" -data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show) - --- |A 'UI.UIClasses.MouseHandler' with button behaviour. -data ButtonHandler m w = ButtonHandler - { _action :: w -> Pixel -> m w } -instance Show (ButtonHandler m w) where - show _ = "ButtonHandler ***" +--------------------------- +--- widgets +--------------------------- -- |A @GUIWidget@ is a visual object the HUD is composed of. data GUIWidget m = Widget {_baseProperties :: GUIBaseProperties m - ,_mouseActions :: Maybe (GUIMouseActions m) ,_graphics :: GUIGraphics m + ,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping + ,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key } -- |Base properties are fundamental settings of any 'GUIWidget'. @@ -93,46 +192,6 @@ data GUIBaseProperties m = BaseProperties _shorthand :: String } --- |Mouse actions control the functionality of a 'GUIWidget' on mouse events. -data GUIMouseActions m = MouseActions - { - -- |The @_mouseState@ function returns the current mouse state of a widget. - _mouseState :: UIMouseState - , - -- |The function 'onMousePressed' is called when a button is pressed - -- while inside a screen coordinate within the widget ('isInside'). - _onMousePress :: MouseButton -- ^the pressed button - -> Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the possibly altered mouse handler - , - -- |The function 'onMouseReleased' is called when a button is released - -- while the pressing event occured within the widget ('isInside'). - -- - -- Thus, the mouse is either within the widget or outside while still dragging. - _onMouseRelease :: MouseButton -- ^the released button - -> Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler - , - -- |The function 'onMouseMove' is invoked when the mouse is moved inside the - -- widget's space ('isInside'). - _onMouseMove :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler - , - -- |The function 'onMouseMove' is invoked when the mouse enters the - -- widget's space ('isInside'). - _onMouseEnter :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler - , - -- |The function 'onMouseMove' is invoked when the mouse leaves the - -- widget's space ('isInside'). - _onMouseLeave :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler - } -- |@GUIGraphics@ functions define the look of a 'GUIWidget'. @@ -140,93 +199,112 @@ data GUIMouseActions m = MouseActions data GUIGraphics m = Graphics {temp :: m Int} -$(makeLenses ''UIMouseState) -$(makeLenses ''UIMouseStateSingle) +$(makeLenses ''WidgetStateKey) +$(makeLenses ''WidgetState) +$(makeLenses ''MouseButtonState) +$(makeLenses ''EventKey) +$(makeLenses ''EventHandler) $(makeLenses ''GUIWidget) $(makeLenses ''GUIBaseProperties) -$(makeLenses ''GUIMouseActions) $(makeLenses ''GUIGraphics) -initialMouseStateS :: UIMouseStateSingle -initialMouseStateS = MouseStateSingle False False -{-# INLINE initialMouseStateS #-} +initialButtonState :: MouseButtonState +initialButtonState = MouseButtonState False False +{-# INLINE initialButtonState #-} -- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@ -- provided in the passed list. -initialMouseState :: UIMouseState -initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)]) - False +initialMouseState :: WidgetState +initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)]) + False (0, 0) {-# INLINE initialMouseState #-} -emptyMouseAction :: (Monad m) => GUIMouseActions m -emptyMouseAction = MouseActions initialMouseState empty'' empty'' empty' empty' empty' - where empty' _ = return - empty'' _ _ = return - -- TODO: combined mouse handler --- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export --- |Creates a @GUIMouseActions@ handler that enables button clicks. --- --- The action is peformed right before the button state change. -buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press - -> GUIMouseActions m -buttonMouseActions a = MouseActions initialMouseState press' release' move' enter' leave' +-- |Creates a 'MouseHandler' that sets a widget's 'MouseButtonState' properties if present, +-- only fully functional in conjunction with 'setMouseMotionStateActions'. +setMouseStateActions :: (Monad m) => EventHandler m +setMouseStateActions = MouseHandler press' release' where - -- |Change 'UIMouseState's '_mouseIsFiring' to @True@. + -- |Change 'MouseButtonState's '_mouseIsDragging' to @True@. press' b _ w = - return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True + return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True - -- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and - -- call action if '_mouseIsFiring' was @True@. - release' b p w = - let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly - in do w' <- if fire - then a b w p - else return w - return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~ - (mouseIsFiring .~ False) . (mouseIsDeferred .~ False) + -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@. + release' b _ _ w = + return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~ + (mouseIsDragging .~ False) . (mouseIsDeferred .~ False) + +-- |Creates a 'MouseHandler' that sets a widget's 'WidgetState MouseState' properties if present, +-- only fully functional in conjunction with 'setMouseStateActions'. +setMouseMotionStateActions :: (Monad m) => EventHandler m +setMouseMotionStateActions = MouseMotionHandler move' enter' leave' + where + -- |Updates mouse position. + move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p - -- |Do nothing. - move' _ = return - - -- |Set 'UIMouseState's '_mouseIsReady' to @True@ and - -- update dragging state (only drag if inside widget). - -- In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value - -- and set '_mouseIsFiring' to @False@. - enter' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ True) - .(mouseStates.mapped %~ (mouseIsDeferred .~ False) - -- following line executed BEFORE above line - .(\sState -> sState & mouseIsFiring .~ not (sState ^. mouseIsDeferred))) + -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current + -- value and sets '_mouseIsDragging' to @False@. + enter' p w = return $ w & widgetStates.(ix MouseStateKey) + %~ (mouseIsReady .~ True) . (mousePixel .~ p) + . (mouseStates.mapped %~ (mouseIsDeferred .~ False) + -- following line executed BEFORE above line + . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred))) - -- |Set 'UIMouseState's 'buttonstateIsReady' to @False@ and - -- update dragging state (only drag if inside widget). - -- In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value - -- and set '_buttonstateIsDeferred's' to @False@. - leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False) - .(mouseStates.mapped %~ (mouseIsFiring .~ False) - -- following line executed BEFORE above line - .(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring))) + -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current + -- value and sets '_mouseIsDeferred' to @False@. + leave' p w = return $ w & widgetStates.(ix MouseStateKey) + %~ (mouseIsReady .~ False) . (mousePixel .~ p) + . (mouseStates.mapped %~ (mouseIsDragging .~ False) + -- following line executed BEFORE above line + . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging))) + + +-- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export +-- |Creates a MouseHandler that reacts on mouse clicks. +-- +-- Does /not/ update 'WidgetState MouseState'! +buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press + -> EventHandler m +buttonMouseActions a = MouseHandler press' release' + where + press' _ _ = return + + release' b p isIn w = + if isIn + then a b w p + else return w 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)) + (\w p -> liftM (flip isInsideExtent p . extractExtent) (w ^. baseProperties.boundary)) -- isInside (return prio) short debugShowWidget' :: (Monad m) => GUIWidget m -> m String -debugShowWidget' (Widget base mouse _) = do +debugShowWidget' (Widget base _ _ handler) = do bnd <- base ^. boundary chld <- base ^. children prio <- base ^. priority let short = base ^. shorthand return $ concat [short,"| boundary:", show bnd, ", children:", show chld, - ",priority:",show prio, maybe "" (const ", with mouse handler") mouse] - + ",priority:",show prio, maybe "" (const ", with mouse handler") (Map.lookup MouseEvent handler)] diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 940c3e9..a0908a5 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -8,63 +8,40 @@ import Data.Maybe import Types import UI.UIBase +-- TODO: test GUI function to scan for overlapping widgets + toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m) -{-# INLINE toGUIAny #-} +{-# INLINABLE toGUIAny #-} toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m] toGUIAnys m = mapMaybe (`Map.lookup` m) -{-# INLINE toGUIAnys #-} +{-# INLINABLE toGUIAnys #-} -- TODO: check for missing components? --- |The function 'getInside' returns child widgets that overlap with a specific --- screen position. --- --- 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 --- have no hit children, which may be the input widget itself, --- or @[]@ if the point does not hit the widget. --- --- This function returns the widgets themselves unlike 'getInsideId'. -getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets - -> Pixel -- ^screen position - -> GUIWidget Pioneers -- ^the parent widget - -> Pioneers [GUIWidget Pioneers] -getInside hMap px wg = do - inside <- (wg ^. baseProperties.isInside) wg px - if inside -- test inside parent's bounding box - then do - childrenIds <- wg ^. baseProperties.children - hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds) - case hitChildren of - [] -> return [wg] - _ -> return hitChildren - else return [] ---TODO: Priority queue? - -- |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 -- have no hit children, which may be the input widget itself, -- or @[]@ if the point does not hit the widget. --- --- This function returns the 'UIId's of the widgets unlike 'getInside'. 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 - inside <- (wg ^. baseProperties.isInside) wg px + let wg = toGUIAny hMap uid + bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary + 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) childrenIds + hitChildren <- liftM concat $ mapM (getInsideId hMap px') childrenIds case hitChildren of - [] -> return [uid] + [] -> return [(uid, px')] _ -> return hitChildren else return [] --TODO: Priority queue? diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index a2ae296..4226e56 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -16,33 +16,30 @@ import UI.UIBase createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT") - Nothing - emptyGraphics + emptyGraphics + Map.empty -- widget states + Map.empty -- event handlers createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize') - Nothing - emptyGraphics + emptyGraphics + Map.empty -- widget states + Map.empty -- event handlers where autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) autosize' = do state <- get let hmap = state ^. ui . uiMap - -- TODO: local coordinates determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) - determineSize' (x, y, w, h) (x', y', w', h') = - let x'' = if x' < x then x' else x - y'' = if y' < y then y' else y - w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x'' - h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y'' - in (x'', y'', w'', h'') + determineSize' (x, y, w, h) (x', y', w', h') = (x, y, max w (x' + w'), max h (y' + h')) case chld of [] -> return bnd - cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs + cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN") - (Just $ buttonMouseActions action) - emptyGraphics + emptyGraphics + (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states + (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers