From 74fc3af20158274076977023cb6971cfbaa795e3 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Tue, 20 May 2014 20:34:05 +0200 Subject: [PATCH 1/6] haddock --- src/UI/Callbacks.hs | 2 +- src/UI/UIBase.hs | 96 +++++++++++++++++++++--------------------- src/UI/UIOperations.hs | 4 +- 3 files changed, 50 insertions(+), 52 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 31d5a73..459b1a1 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -311,7 +311,7 @@ prepareGUI = do modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset +copyGUI :: GL.TextureObject -> Pixel -- ^current view’s offset -> GUIWidget Pioneers -- ^the widget to draw -> Pioneers () copyGUI tex (vX, vY) widget = do diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index b2409e2..c6219b8 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -6,7 +6,7 @@ module UI.UIBase where import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses) import Control.Monad (liftM) import Data.Array -import Data.Bits (xor) +import Data.Bits (xor) import Data.Hashable import qualified Data.HashMap.Strict as Map import Data.Ix () @@ -24,7 +24,7 @@ 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'. +-- |Maps 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 (>:) #-} @@ -113,53 +113,51 @@ instance Hashable EventKey where -- TODO: generic deriving creates functions tha -- |A handler to react on certain events. data EventHandler m = - -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. + -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. + -- + -- All screen coordinates are widget-local coordinates. MouseHandler { -- |The function 'onMousePressed' is called when a button is pressed - -- while the widget is mouse-active. - -- - -- A widget becomes mouse-active if no other button is currently pressed and the mouse - -- coordinates are within the widget's extent ('isInside') until no button is pressed any - -- more. - _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 + -- while the button is mouse-active. + -- + -- The function returns the altered widget resulting from the button press + _onMousePress :: MouseButton -> Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseReleased' is called when a button is released -- while the widget is mouse-active. -- -- 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 returns the altered widget resulting from the button press + _onMouseRelease :: MouseButton -> Pixel -> GUIWidget m -> m (GUIWidget m) } | - -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. + -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. + -- + -- All screen coordinates are widget-local coordinates. MouseMotionHandler { -- |The function 'onMouseMove' is invoked when the mouse is moved inside the - -- widget's extent ('isInside') while no button is pressed or when the mouse is inside the - -- widget's extent while another button loses its mouse-active state. Triggered after + -- widget’s extent ('isInside') while no button is pressed or when the mouse is inside the + -- widget’s extent while another button loses its mouse-active state. Triggered after -- '_onMouseEnter'. - _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 returns the altered widget resulting from the button press + _onMouseMove :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseMove' is invoked when the mouse enters the - -- widget's extent ('isInside') or when the mouse is inside the - -- widget's extent while another button loses its mouse-active state.. - _onMouseEnter :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler + -- widget’s extent ('isInside') or when the mouse is inside the + -- widget’s extent while another button loses its mouse-active state. + -- + -- The function returns the altered widget resulting from the button press + _onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseLeave' is invoked when the mouse leaves the - -- widget's extent ('isInside') while no other widget is mouse-active. - _onMouseLeave :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler + -- widget’s extent ('isInside') while no other widget is mouse-active. + -- + -- The function returns the altered widget resulting from the button press + _onMouseLeave :: Pixel -> GUIWidget m -> m (GUIWidget m) } deriving () @@ -185,8 +183,8 @@ data GUIBaseProperties m = BaseProperties _boundary :: m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) , -- |The @_getChildren@ function returns all children associated with this widget. - -- - -- All children must be wholly inside the parent's bounding box specified by '_boundary'. + -- + -- All children must be wholly inside the parent’s bounding box specified by '_boundary'. _children :: m [UIId] , -- |The function @_isInside@ tests whether a point is inside the widget itself. @@ -195,9 +193,9 @@ data GUIBaseProperties m = BaseProperties -- -- The default implementations tests if the point is within the rectangle specified by the -- 'getBoundary' function. - _isInside :: GUIWidget m - -> Pixel -- ^local coordinates - -> m Bool + -- + -- The passed coordinates are widget-local coordinates. + _isInside :: GUIWidget m -> Pixel -> m Bool , -- |The @_getPriority@ function returns the priority score of a @GUIWidget@. -- A widget with a high score is more in the front than a low scored widget. @@ -223,12 +221,12 @@ $(makeLenses ''GUIWidget) $(makeLenses ''GUIBaseProperties) $(makeLenses ''GUIGraphics) +-- |Creates a default @MouseButtonState@. initialButtonState :: MouseButtonState initialButtonState = MouseButtonState False False {-# INLINE initialButtonState #-} --- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@ --- provided in the passed list. +-- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'. initialMouseState :: WidgetState initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)]) False (0, 0) @@ -237,21 +235,21 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta -- TODO: combined mouse handler -- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export --- |Creates a 'MouseHandler' that sets a widget's 'MouseButtonState' properties if present, +-- |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 'MouseButtonState's '_mouseIsDragging' to @True@. + -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@. press' b _ w = return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True - -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @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, +-- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present, -- only fully functional in conjunction with 'setMouseStateActions'. setMouseMotionStateActions :: (Monad m) => EventHandler m setMouseMotionStateActions = MouseMotionHandler move' enter' leave' @@ -259,7 +257,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave' -- |Updates mouse position. move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p - -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current + -- |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) @@ -268,7 +266,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave' . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred))) - -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current + -- |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) @@ -277,9 +275,9 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave' . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging))) -- TODO: make only fire if press started within widget --- |Creates a MouseHandler that reacts on mouse clicks. +-- |Creates a 'MouseHandler' that reacts on mouse clicks. -- --- Does /not/ update 'WidgetState MouseState'! +-- Does /not/ update the widget’s 'MouseState'! buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press -> EventHandler m buttonMouseActions a = MouseHandler press' release' @@ -290,9 +288,9 @@ buttonMouseActions a = MouseHandler press' release' if fire then a b w p else return w -- TODO: make only fire if press started within widget --- |Creates a MouseHandler that reacts on mouse clicks. +-- |Creates a 'MouseHandler' that reacts on mouse clicks. -- --- Does /not/ update 'WidgetState MouseState'! +-- Does /not/ update the widget’s 'MouseState'! buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press -> MouseButton -> EventHandler m buttonSingleMouseActions a btn = MouseHandler press' release' @@ -310,7 +308,7 @@ extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit extractExtent (_,_,w,h) = (w,h) {-# INLINABLE extractExtent #-} --- |Calculates whether a point's value exceed the given width and height. +-- |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) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 4f0ad2e..d790917 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -31,7 +31,7 @@ isInsideFast wg px = do -- |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. -- -- 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 @@ -46,7 +46,7 @@ getInsideId px uid = do (bX, bY, _, _) <- wg ^. baseProperties.boundary let px' = px -: (bX, bY) inside <- isInsideFast wg px' - if inside -- test inside parent's bounding box + if inside -- test inside parent’s bounding box then do childrenIds <- wg ^. baseProperties.children hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds From e72e8c933391da036bbd9e024ccb7e25c202d434 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Tue, 20 May 2014 20:38:02 +0200 Subject: [PATCH 2/6] more strictness to Types.hs: UIState --- src/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 1574357..3ea670e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -147,9 +147,9 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool - , _uiMap :: Map.HashMap UIId (GUIWidget Pioneers) - , _uiRoots :: [UIId] - , _uiButtonState :: UIButtonState + , _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers)) + , _uiRoots :: !([UIId]) + , _uiButtonState :: !UIButtonState } data State = State From 8a84e7ba952be4cfbcd659005b574a3578f980c5 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Wed, 21 May 2014 11:51:40 +0200 Subject: [PATCH 3/6] press/release handlers receive boolean as parameter to indicate if the click is inside widget --- src/UI/Callbacks.hs | 34 ++-------------------------------- src/UI/UIBase.hs | 29 +++++++++++++++++------------ 2 files changed, 19 insertions(+), 44 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 459b1a1..4231b33 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -141,7 +141,7 @@ eventCallback e = do _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] -mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers)) +mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers)) -> MouseButton -> Pixel -> Pioneers () mouseButtonHandler transFunc btn px = do state <- get @@ -151,7 +151,7 @@ mouseButtonHandler transFunc btn px = do Just (wid, px') -> do let target = toGUIAny hMap wid target' <- case target ^. eventHandlers.(at MouseEvent) of - Just ma -> transFunc ma btn (px -: px') target + Just ma -> transFunc ma btn (px -: px') (state ^. ui.uiButtonState.mouseInside) target Nothing -> return target modify $ ui.uiMap %~ Map.insert wid target' return () @@ -260,36 +260,6 @@ mouseMoveHandler px = 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 - roots <- getRootIds - 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 - state <- get - let w = toGUIAny (state ^. ui.uiMap) uid - short = w ^. baseProperties.shorthand - bound <- w ^. baseProperties.boundary - prio <- w ^. baseProperties.priority - 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' w' -- TODO unsafe fromJust - return $ Just (uid, w'') - Nothing -> return Nothing - ) hits - 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 () - - -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture -- --TODO: should be done asynchronously at one point. diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index c6219b8..efa3167 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -121,16 +121,23 @@ data EventHandler m = -- |The function 'onMousePressed' is called when a button is pressed -- while the button is mouse-active. -- - -- The function returns the altered widget resulting from the button press - _onMousePress :: MouseButton -> Pixel -> GUIWidget m -> m (GUIWidget m) + -- The boolean value indicates if the button press happened within the widget + -- ('_isInside'). + -- + -- The function returns the altered widget resulting from the button press + _onMousePress :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseReleased' is called when a button is released -- while the widget is mouse-active. -- -- Thus, the mouse is either within the widget or outside while still dragging. -- - -- The function returns the altered widget resulting from the button press - _onMouseRelease :: MouseButton -> Pixel -> GUIWidget m -> m (GUIWidget m) + -- + -- The boolean value indicates if the button release happened within the widget + -- ('_isInside'). + -- + -- The function returns the altered widget resulting from the button press + _onMouseRelease :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m) } | -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. @@ -241,11 +248,11 @@ setMouseStateActions :: (Monad m) => EventHandler m setMouseStateActions = MouseHandler press' release' where -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@. - press' b _ w = + press' b _ _ w = return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True -- |Change 'MouseButtonState'’s '_mouseIsDragging' and '_mouseIsDeferred' to @False@. - release' b _ w = + release' b _ _ w = return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~ (mouseIsDragging .~ False) . (mouseIsDeferred .~ False) @@ -282,10 +289,9 @@ buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GU -> EventHandler m buttonMouseActions a = MouseHandler press' release' where - press' _ _ = return + press' _ _ _ = return - release' b p w = do fire <- (w ^. baseProperties.isInside) w p - if fire then a b w p else return w + release' b p inside w = if inside then a b w p else return w -- TODO: make only fire if press started within widget -- |Creates a 'MouseHandler' that reacts on mouse clicks. @@ -295,10 +301,9 @@ buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m -> MouseButton -> EventHandler m buttonSingleMouseActions a btn = MouseHandler press' release' where - press' _ _ = return + press' _ _ _ = return - release' b p w = do fire <- liftM (b == btn &&) $ (w ^. baseProperties.isInside) w p - if fire then a w p else return w + release' b p inside w = if inside && b == btn then a w p else return w emptyGraphics :: (Monad m) => GUIGraphics m emptyGraphics = Graphics (return 3) From 03d99c5fcc9755dfae60aa04032a2aeba246c1fb Mon Sep 17 00:00:00 2001 From: tpajenka Date: Wed, 21 May 2014 14:03:28 +0200 Subject: [PATCH 4/6] bugfix mouse motion handler: handler has been invoked with wrong coordinates, motion handler is now also called while leaving while still mouse-active --- src/UI/Callbacks.hs | 6 ++++-- src/UI/UIBase.hs | 10 +++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 4231b33..4008e02 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -220,7 +220,9 @@ mouseSetLeaving wid px = do 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 + target_ <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust + target' <- if state ^. ui.uiButtonState.mousePressed <= 0 then return target_ + else fromJust (ma ^? onMouseMove) px target_ --TODO unsafe fromJust modify $ ui.uiMap %~ Map.insert wid target' Nothing -> return () @@ -236,7 +238,7 @@ mouseMoveHandler px = do 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 -: px') target modify $ ui.uiMap %~ Map.insert wid target' Nothing -> return () else if b then -- && not mouseInside --> entering diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index efa3167..5424900 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -124,7 +124,7 @@ data EventHandler m = -- The boolean value indicates if the button press happened within the widget -- ('_isInside'). -- - -- The function returns the altered widget resulting from the button press + -- The function returns the altered widget resulting from the button press. _onMousePress :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseReleased' is called when a button is released @@ -136,7 +136,7 @@ data EventHandler m = -- The boolean value indicates if the button release happened within the widget -- ('_isInside'). -- - -- The function returns the altered widget resulting from the button press + -- The function returns the altered widget resulting from the button press. _onMouseRelease :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m) } | @@ -148,9 +148,9 @@ data EventHandler m = -- |The function 'onMouseMove' is invoked when the mouse is moved inside the -- widget’s extent ('isInside') while no button is pressed or when the mouse is inside the -- widget’s extent while another button loses its mouse-active state. Triggered after - -- '_onMouseEnter'. + -- '_onMouseEnter' or '_onMouseLeave' (only if still mouse-active on leaving) if applicable. -- - -- The function returns the altered widget resulting from the button press + -- The function returns the altered widget resulting from the button press. _onMouseMove :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseMove' is invoked when the mouse enters the @@ -163,7 +163,7 @@ data EventHandler m = -- |The function 'onMouseLeave' is invoked when the mouse leaves the -- widget’s extent ('isInside') while no other widget is mouse-active. -- - -- The function returns the altered widget resulting from the button press + -- The function returns the altered widget resulting from the button press. _onMouseLeave :: Pixel -> GUIWidget m -> m (GUIWidget m) } deriving () From 9523e733c6678232eab9193f25c4d3c933457efe Mon Sep 17 00:00:00 2001 From: tpajenka Date: Wed, 21 May 2014 14:10:47 +0200 Subject: [PATCH 5/6] new UI-Widget type: Viewport, removed old hacked code (except mouse wheel) to handle camera movement and using viewport instead --- src/Main.hs | 3 +-- src/Types.hs | 3 +-- src/UI/Callbacks.hs | 41 +++++++++-------------------------------- src/UI/UIBase.hs | 44 +++++++++++++++++++++++++++++++++++++++++--- src/UI/UIWidgets.hs | 41 ++++++++++++++++++++++++++++++++++++++--- 5 files changed, 90 insertions(+), 42 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 3f5c5bc..49b6463 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -133,8 +133,7 @@ main = , _tessClockFactor = 0 } , _mouse = MouseState - { _isDown = False - , _isDragging = False + { _isDragging = False , _dragStartX = 0 , _dragStartY = 0 , _dragStartXAngle = 0 diff --git a/src/Types.hs b/src/Types.hs index 3ea670e..d572db8 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -60,8 +60,7 @@ data GameState = GameState } data MouseState = MouseState - { _isDown :: !Bool - , _isDragging :: !Bool + { _isDragging :: !Bool , _dragStartX :: !Double , _dragStartY :: !Double , _dragStartXAngle :: !Double diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 4008e02..e953e24 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -8,7 +8,7 @@ import Control.Monad (liftM, when, unless) import Control.Monad.RWS.Strict (ask, get, modify) import Control.Monad.Trans (liftIO) import qualified Data.HashMap.Strict as Map -import Data.List (foldl') +--import Data.List (foldl') import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) @@ -22,7 +22,7 @@ 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) +createGUI = (Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize , (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 ) @@ -101,38 +101,14 @@ eventCallback e = do _ -> return () SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel - do - state <- get - 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) + mouseMoveHandler (x, 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 - 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 () + 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 + do -- TODO: MouseWheelHandler state <- get let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' @@ -295,6 +271,7 @@ copyGUI tex (vX, vY) widget = do --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. color = case widget ^. baseProperties.shorthand of + "VWP" -> [0,128,128,30] "CNT" -> [255,0,0,128] "BTN" -> [255,255,0,255] "PNL" -> [128,128,128,128] diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 5424900..9453c7f 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -4,7 +4,7 @@ module UI.UIBase where import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses) -import Control.Monad (liftM) +import Control.Monad (join,liftM) import Data.Array import Data.Bits (xor) import Data.Hashable @@ -157,7 +157,7 @@ data EventHandler m = -- widget’s extent ('isInside') or when the mouse is inside the -- widget’s extent while another button loses its mouse-active state. -- - -- The function returns the altered widget resulting from the button press + -- The function returns the altered widget resulting from the button press. _onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseLeave' is invoked when the mouse leaves the @@ -239,7 +239,45 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta False (0, 0) {-# INLINE initialMouseState #-} --- TODO: combined mouse handler +-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions +-- of two handlers. Thereby, the resulting widget of the first handler is the input widget of the +-- second handler and all other parameters are the same for both function calls. +-- +-- If not both input handlers are of type @MouseHandler@ an error is raised. +combinedMouseHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m +combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) = + MouseHandler (comb p1 p2) (comb r1 r2) + where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside +combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two EventHandler" ++ + " with constructor MouseHandler" + +-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action +-- functions of two handlers. Thereby, the resulting widget of the second handler is the input +-- widget of the second handler and all other parameters are the same for both function calls. +-- +-- If not both input handlers are of type @MouseMotionHandler@ an error is raised. +combinedMouseMotionHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m +combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) = + MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2) + where comb h1 h2 px = join . liftM (h2 px) . h1 px +combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two EventHandler" ++ + " with constructor MouseMotionHandler" + +-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing. +-- It may be useful as construction kit. +-- +-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction +-- >>> emptyMouseHandler { _onMousePress = myPressFunction } +emptyMouseHandler :: (Monad m) => EventHandler m +emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return) + +-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing. +-- It may be useful as construction kit. +-- +-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction +-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction } +emptyMouseMotionHandler :: (Monad m) => EventHandler m +emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return) -- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export -- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present, diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index 4226e56..64c954f 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -2,10 +2,10 @@ module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where -import Control.Lens ((^.), (.~), (&)) +import Control.Lens ((^.), (.~), (%~), (&)) import Control.Monad ---import Control.Monad.IO.Class -- MonadIO -import Control.Monad.RWS.Strict (get) +-- import Control.Monad.IO.Class (liftIO) +import Control.Monad.RWS.Strict (get, modify) import Data.List import Data.Maybe import qualified Data.HashMap.Strict as Map @@ -43,3 +43,38 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN") emptyGraphics (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers + +createViewport :: MouseButton -- ^ button to drag with + -> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers +createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") + emptyGraphics + Map.empty -- widget states + (Map.fromList [(MouseEvent, viewportMouseAction) + ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers + where + viewportMouseAction :: EventHandler Pioneers + viewportMouseAction = + let press btn' (x, y) _ w = + do when (btn == btn') $ do + state <- get + modify $ mouse %~ (isDragging .~ True) + . (dragStartX .~ fromIntegral x) + . (dragStartY .~ fromIntegral y) + . (dragStartXAngle .~ (state ^. camera.xAngle)) + . (dragStartYAngle .~ (state ^. camera.yAngle)) + . (mousePosition.Types._x .~ fromIntegral x) + . (mousePosition.Types._y .~ fromIntegral y) + return w + release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False) + return w + in MouseHandler press release + + viewportMouseMotionAction :: EventHandler Pioneers + viewportMouseMotionAction = + let move (x, y) w = + do state <- get + when (state ^. mouse.isDragging) $ + modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x) + . (mousePosition.Types._y .~ fromIntegral y) + return w + in emptyMouseMotionHandler & onMouseMove .~ move \ No newline at end of file From c7ea247b70c4cce2554c7bfa3134c766eb52d203 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sat, 24 May 2014 13:47:47 +0200 Subject: [PATCH 6/6] introducing window resize event, main viewport resizing to actual window size --- src/Main.hs | 30 ++++++++---------- src/Types.hs | 1 + src/UI/Callbacks.hs | 46 ++++++++++++++++++--------- src/UI/UIBase.hs | 71 +++++++++++++++++++++++++++++------------- src/UI/UIOperations.hs | 41 ++++++++++++++++++++++-- src/UI/UIWidgets.hs | 22 +++++++++++-- 6 files changed, 153 insertions(+), 58 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 97ecde0..97ad62b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -45,7 +45,6 @@ import UI.Callbacks import Map.Graphics import Map.Creation (exportedMap) import Types -import qualified UI.UIBase as UI import Importer.IQM.Parser --import Data.Attoparsec.Char8 (parseTest) --import qualified Data.ByteString as B @@ -66,15 +65,18 @@ testParser a = print =<< parseIQM a -------------------------------------------------------------------------------- main :: IO () -main = +main = do + let initialWidth = 1024 + initialHeight = 600 SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute! - SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl -- we want openGL - ,SDL.WindowShown -- window should be visible - ,SDL.WindowResizable -- and resizable - ,SDL.WindowInputFocus -- focused (=> active) - ,SDL.WindowMouseFocus -- Mouse into it - --,WindowInputGrabbed-- never let go of input (KB/Mouse) - ] $ \window' -> do + SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight) + [SDL.WindowOpengl -- we want openGL + ,SDL.WindowShown -- window should be visible + ,SDL.WindowResizable -- and resizable + ,SDL.WindowInputFocus -- focused (=> active) + ,SDL.WindowMouseFocus -- Mouse into it + --,WindowInputGrabbed-- never let go of input (KB/Mouse) + ] $ \window' -> do SDL.withOpenGL window' $ do --Create Renderbuffer & Framebuffer @@ -114,7 +116,6 @@ main = let zDistClosest' = 2 zDistFarthest' = zDistClosest' + 10 --TODO: Move near/far/fov to state for runtime-changability & central storage - (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False , _down = False @@ -159,12 +160,7 @@ main = , _glFramebuffer = frameBuffer } , _game = game' - , _ui = UIState - { _uiHasChanged = True - , _uiMap = guiMap - , _uiRoots = guiRoots - , _uiButtonState = UI.UIButtonState 0 Nothing False - } + , _ui = createGUI initialWidth initialHeight } putStrLn "init done." @@ -243,7 +239,7 @@ run = do targetFrametime = 1.0/targetFramerate --targetFrametimeμs = targetFrametime * 1000000.0 now <- getCurrentTime - let diff = max 0.1 $ diffUTCTime now (state ^. io.clock) -- get time-diffs + let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"] ddiff = double diff SDL.setWindowTitle (env ^. windowObject) title diff --git a/src/Types.hs b/src/Types.hs index 0e1800c..2ed3da7 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -155,6 +155,7 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool , _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers)) + , _uiObserverEvents :: !(Map.HashMap EventKey [EventHandler Pioneers]) , _uiRoots :: !([UIId]) , _uiButtonState :: !UIButtonState } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index a13f7bb..62bf672 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -3,7 +3,7 @@ module UI.Callbacks where import qualified Graphics.Rendering.OpenGL.GL as GL -import Control.Lens ((^.), (.~), (%~), (^?), at) +import Control.Lens ((^.), (.~), (%~), (^?), at, ix) import Control.Monad (liftM, when, unless) import Control.Monad.RWS.Strict (ask, get, modify) import Control.Monad.Trans (liftIO) @@ -13,7 +13,7 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL -import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar) +import Control.Concurrent.STM.TVar (readTVar, writeTVar) import Control.Concurrent.STM (atomically) @@ -23,13 +23,19 @@ 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, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize - , (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]) +createGUI :: ScreenUnit -> ScreenUnit -> UIState +createGUI w h = UIState + { _uiHasChanged = True + , _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize + , (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) + ] + , _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])] + , _uiRoots = [UIId 0] + , _uiButtonState = UIButtonState 0 Nothing False + } getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers] getGUI = Map.elems @@ -69,9 +75,10 @@ eventCallback :: SDL.Event -> Pioneers () eventCallback e = do env <- ask case SDL.eventData e of - SDL.Window _ _ -> -- windowID event - -- TODO: resize GUI - return () + SDL.Window _ ev -> -- windowID event + case ev of + SDL.Resized (SDL.Size x y) -> windowResizeHandler x y + _ -> return () SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym -- need modifiers? use "keyModifiers key" to get them let aks = keyboard.arrowsPressed in @@ -125,7 +132,18 @@ eventCallback e = do _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] -mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers)) +windowResizeHandler :: ScreenUnit -> ScreenUnit -> Pioneers () +windowResizeHandler x y = do + state <- get + case state ^. ui.uiObserverEvents.(at WindowEvent) of + Just evs -> let handle :: EventHandler Pioneers -> Pioneers (EventHandler Pioneers) + handle (WindowHandler h _) = h x y + handle h = return h -- TODO: may log invalid event mapping + in do newEvs <- mapM handle evs + modify $ ui.uiObserverEvents.(ix WindowEvent) .~ newEvs + Nothing -> return () + +mouseButtonHandler :: (WidgetEventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers)) -> MouseButton -> Pixel -> Pioneers () mouseButtonHandler transFunc btn px = do state <- get @@ -279,7 +297,7 @@ copyGUI tex (vX, vY) widget = do --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. color = case widget ^. baseProperties.shorthand of - "VWP" -> [0,128,128,30] + "VWP" -> [0,128,128,0] "CNT" -> [255,0,0,128] "BTN" -> [255,255,0,255] "PNL" -> [128,128,128,128] diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 9453c7f..82d3955 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-} -- widget data is separated into several modules to avoid cyclic dependencies with the Type module -- TODO: exclude UIMouseState constructor from export? module UI.UIBase where @@ -87,7 +87,7 @@ data MouseButtonState = MouseButtonState -- ^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. +-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'. data WidgetState = -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'. MouseState @@ -101,18 +101,18 @@ data WidgetState = --- events --------------------------- --- |A key to reference a specific 'EventHandler'. -data EventKey = MouseEvent | MouseMotionEvent +-- |A key to reference a specific 'WidgetEventHandler'. +data WidgetEventKey = MouseEvent | MouseMotionEvent deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) -instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever +instance Hashable WidgetEventKey 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 = +-- |A handler to react on certain events. Corresponding key: 'WidgetEventKey'. +data WidgetEventHandler m = -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. -- -- All screen coordinates are widget-local coordinates. @@ -168,6 +168,34 @@ data EventHandler m = } deriving () +-- |A key to reference a specific 'EventHandler'. +data EventKey = WindowEvent | WidgetPositionEvent + 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 + + -- |A handler to react on certain events. Corresponding key: 'EventKey'. +data EventHandler (m :: * -> *) = + WindowHandler + { + -- |The function '_onWindowResize' is invoked when the global application window changes size. + -- + -- The input is the window’s new width and height in that order. + -- + -- The returned handler is resulting handler that may change by the event. Its type must + -- remain @WindowHandler@. + _onWindowResize :: ScreenUnit -> ScreenUnit -> m (EventHandler m) + , + -- |Unique id to identify an event instance. + _eventId :: UIId + } + +instance Eq (EventHandler m) where + WindowHandler _ id' == WindowHandler _ id'' = id' == id'' + _ == _ = False + --------------------------- --- widgets @@ -178,7 +206,7 @@ data GUIWidget m = Widget {_baseProperties :: GUIBaseProperties m ,_graphics :: GUIGraphics m ,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping - ,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key + ,_eventHandlers :: Map.HashMap WidgetEventKey (WidgetEventHandler m) -- no guarantee that data match key } -- |Base properties are fundamental settings of any 'GUIWidget'. @@ -217,13 +245,12 @@ data GUIBaseProperties m = BaseProperties -- |@GUIGraphics@ functions define the look of a 'GUIWidget'. -data GUIGraphics m = Graphics - {temp :: m Int} +data GUIGraphics (m :: * -> *) = Graphics $(makeLenses ''UIButtonState) $(makeLenses ''WidgetState) $(makeLenses ''MouseButtonState) -$(makeLenses ''EventHandler) +$(makeLenses ''WidgetEventHandler) $(makeLenses ''GUIWidget) $(makeLenses ''GUIBaseProperties) $(makeLenses ''GUIGraphics) @@ -244,11 +271,11 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta -- second handler and all other parameters are the same for both function calls. -- -- If not both input handlers are of type @MouseHandler@ an error is raised. -combinedMouseHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m +combinedMouseHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) = MouseHandler (comb p1 p2) (comb r1 r2) where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside -combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two EventHandler" ++ +combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two WidgetEventHandler" ++ " with constructor MouseHandler" -- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action @@ -256,11 +283,11 @@ combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two Eve -- widget of the second handler and all other parameters are the same for both function calls. -- -- If not both input handlers are of type @MouseMotionHandler@ an error is raised. -combinedMouseMotionHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m +combinedMouseMotionHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) = MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2) where comb h1 h2 px = join . liftM (h2 px) . h1 px -combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two EventHandler" ++ +combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two WidgetEventHandler" ++ " with constructor MouseMotionHandler" -- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing. @@ -268,7 +295,7 @@ combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only com -- -- >>> emptyMouseHandler & _onMousePress .~ myPressFunction -- >>> emptyMouseHandler { _onMousePress = myPressFunction } -emptyMouseHandler :: (Monad m) => EventHandler m +emptyMouseHandler :: (Monad m) => WidgetEventHandler m emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return) -- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing. @@ -276,13 +303,13 @@ emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return) -- -- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction -- >>> emptyMouseHandler { _onMouseMove = myMoveFunction } -emptyMouseMotionHandler :: (Monad m) => EventHandler m +emptyMouseMotionHandler :: (Monad m) => WidgetEventHandler m emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return) -- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export -- |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 :: (Monad m) => WidgetEventHandler m setMouseStateActions = MouseHandler press' release' where -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@. @@ -296,7 +323,7 @@ setMouseStateActions = MouseHandler press' release' -- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present, -- only fully functional in conjunction with 'setMouseStateActions'. -setMouseMotionStateActions :: (Monad m) => EventHandler m +setMouseMotionStateActions :: (Monad m) => WidgetEventHandler m setMouseMotionStateActions = MouseMotionHandler move' enter' leave' where -- |Updates mouse position. @@ -324,7 +351,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave' -- -- Does /not/ update the widget’s 'MouseState'! buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press - -> EventHandler m + -> WidgetEventHandler m buttonMouseActions a = MouseHandler press' release' where press' _ _ _ = return @@ -336,7 +363,7 @@ buttonMouseActions a = MouseHandler press' release' -- -- Does /not/ update the widget’s 'MouseState'! buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press - -> MouseButton -> EventHandler m + -> MouseButton -> WidgetEventHandler m buttonSingleMouseActions a btn = MouseHandler press' release' where press' _ _ _ = return @@ -344,7 +371,7 @@ buttonSingleMouseActions a btn = MouseHandler press' release' release' b p inside w = if inside && b == btn then a w p else return w emptyGraphics :: (Monad m) => GUIGraphics m -emptyGraphics = Graphics (return 3) +emptyGraphics = Graphics -- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'. extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index d790917..5824d3d 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -1,10 +1,12 @@ module UI.UIOperations where -import Control.Lens ((^.)) +import Control.Lens ((^.), (%~)) import Control.Monad (liftM) --import Control.Monad.IO.Class (liftIO) -import Control.Monad.RWS.Strict (get) +import Control.Monad.RWS.Strict (get, modify) import qualified Data.HashMap.Strict as Map +import Data.Hashable +--import qualified Data.List as L import Data.Maybe import Types @@ -29,6 +31,41 @@ isInsideFast wg px = do (_, _, w, h) <- wg ^. baseProperties.boundary liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px +-- |Adds an event to the given map. The new event is concatenated to present events. Does not test +-- if the map already contains the given element. +addEvent :: (Eq k, Hashable k) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v] +addEvent k v eventMap = Map.insertWith (++) k [v] eventMap + +-- |Adds an event to the global event map such that the event handler will be notified on occurrance. +registerEvent :: EventKey -> EventHandler Pioneers -> Pioneers () +registerEvent k v = modify $ ui.uiObserverEvents %~ addEvent k v + +-- |The 'deleteQualitative' function behaves like 'Data.List.deleteBy' but reports @True@ if the +-- list contained the relevant object. +deleteQualitative :: (a -> a -> Bool) -> a -> [a] -> ([a], Bool) +deleteQualitative _ _ [] = ([], False) +deleteQualitative eq x (y:ys) = if x `eq` y then (ys, True) else + let (zs, b) = deleteQualitative eq x ys + in (y:zs, b) + +-- |Removes the first occurrence of an event from the given map if it is within the event list of +-- the key. +removeEvent :: (Eq k, Hashable k, Eq v) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v] +removeEvent k v eventMap = + case Map.lookup k eventMap of + Just list -> case deleteQualitative (==) v list of + (_, False) -> eventMap + (ys, _) -> case ys of + [] -> Map.delete k eventMap + _ -> Map.insert k ys eventMap + Nothing -> Map.insert k [v] eventMap + + +-- |Adds an event to the global event map such that the event handler will be notified on occurrance. +deregisterEvent :: EventKey -> EventHandler Pioneers -> Pioneers () +deregisterEvent k v = modify $ ui.uiObserverEvents %~ removeEvent k v + + -- |The function 'getInsideId' returns child widgets that overlap with a -- specific screen position and the pixel’s local coordinates. diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index dcc6e58..9ab9215 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -13,6 +13,7 @@ import qualified Data.HashMap.Strict as Map import Types import UI.UIBase +import UI.UIOperations createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m @@ -53,7 +54,7 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") (Map.fromList [(MouseEvent, viewportMouseAction) ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers where - viewportMouseAction :: EventHandler Pioneers + viewportMouseAction :: WidgetEventHandler Pioneers viewportMouseAction = let press btn' (x, y) _ w = do when (btn == btn') $ do @@ -71,7 +72,7 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") return w in MouseHandler press release - viewportMouseMotionAction :: EventHandler Pioneers + viewportMouseMotionAction :: WidgetEventHandler Pioneers viewportMouseMotionAction = let move (x, y) w = do state <- get @@ -79,4 +80,19 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x) . (mousePosition.Types._y .~ fromIntegral y) return w - in emptyMouseMotionHandler & onMouseMove .~ move \ No newline at end of file + in emptyMouseMotionHandler & onMouseMove .~ move + +resizeToScreenHandler :: UIId -- ^id of a widget + -> EventHandler Pioneers +resizeToScreenHandler id' = WindowHandler resize (UIId 0) -- TODO: unique id + where resize :: ScreenUnit -> ScreenUnit -> Pioneers (EventHandler Pioneers) + resize w h = do + state <- get + let wg = toGUIAny (state ^. ui.uiMap) id' + (x, y, _, _) <- wg ^. baseProperties.boundary + let wg' = wg & baseProperties.boundary .~ return (x, y, w-x, h-y) + modify $ ui.uiMap %~ Map.insert id' wg' + return $ WindowHandler resize (UIId 0) + + + \ No newline at end of file