From 1898758eb5a98ddcf333862914a86e8755cf09ee Mon Sep 17 00:00:00 2001 From: tpajenka Date: Thu, 3 Apr 2014 20:05:49 +0200 Subject: [PATCH 1/2] basic gui working... somehow (no painting yet) --- src/UI/Callbacks.hs | 29 +++- src/UI/UITypes.hs | 359 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 364 insertions(+), 24 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 4218384..0b98744 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -9,14 +9,37 @@ import UI.UITypes data Pixel = Pixel Int Int getGUI :: [GUIAny] -getGUI = (GUIAny $ GUIContainer 0 0 120 80 [] 1):(GUIAny $ GUIContainer 50 60 300 700 [(GUIAny $ GUIContainer 55 65 200 400 [] 5)] 1):[] +getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1 + , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0 + [toGUIAny $ GUIContainer 0 80 100 200 [] 4 + ,GUIAnyB (GUIButton 50 400 200 175 2 (testMessage) defaultUIState) + ] 3 + ] + +testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w +testMessage w x y = do + putStrLn ("\tclick on " ++ show x ++ "," ++ show y) + return w -- | Handler for UI-Inputs. -- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... clickHandler :: Pixel -> Pioneers () -clickHandler (Pixel x y) = case concat $ map (isInside x y) getGUI of +clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] - hit -> liftIO $ putStrLn $ unwords $ foldl (++) ["hitting"] ([map (\w -> (show.getBoundary) w ++ ' ':(show.getPriority) w) hit]) + hit -> liftIO $ do + _ <- sequence $ map (\w -> + case w of + (GUIAnyB b) -> do + putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) + ++ " at ["++show x++","++show y++"]" + (b', _) <- onMousePressed x y b b + _ <- onMouseReleased x y b' b' + return () + _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) + ++ " at ["++show x++","++show y++"]" + ) hit + return () + -- | Handler for UI-Inputs. -- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ... diff --git a/src/UI/UITypes.hs b/src/UI/UITypes.hs index 8960f7b..12ba70c 100644 --- a/src/UI/UITypes.hs +++ b/src/UI/UITypes.hs @@ -1,16 +1,54 @@ -{-# LANGUAGE InstanceSigs, ExistentialQuantification #-} +{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} module UI.UITypes where +import Data.List +import Foreign.C (CFloat) +import Linear.Matrix (M44) -type IntScreen = Int +-- |Unit of screen/window +type ScreenUnit = Int -data GUIAny = forall wg. GUIWidget wg => GUIAny wg +-- |A viewport to an OpenGL scene. +data Viewport = Viewport + { _viewportXAngle :: !Double + , _viewportYAngle :: !Double + , _viewportZDist :: !Double + , _viewportFrustum :: !(M44 CFloat) + , _viewportPositionX :: !ScreenUnit -- ^x position in window + , _viewportPositionY :: !ScreenUnit -- ^y position in window + , _viewportWidth :: !ScreenUnit -- ^viewport width in window + , _viewportHeight :: !ScreenUnit -- ^viewport height in window + } deriving (Eq, Show) + +data UIState = UIState + { _uistateIsFiring :: Bool + -- ^firing if pressed but not confirmed + , _uistateIsFiringAlt :: Bool + -- ^firing if pressed but not confirmed (secondary mouse button) + , _uistateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component + , _uistateIsDeferredAlt :: Bool + -- ^deferred if e. g. dragging but outside component (secondary mouse button) + , _uistateIsReady :: Bool + -- ^ready if mouse is above component + , _uistateIsActivated :: Bool + -- ^in activated state (e. g. toggle button) + } deriving (Eq, Show) -class GUIWidget uiw where + +defaultUIState :: UIState +defaultUIState = UIState False False False False False False + +class GUIAnyMap w where + guiAnyMap :: (w -> b) -> GUIAny -> b + toGUIAny :: w -> GUIAny + fromGUIAny :: GUIAny -> w + + +class (GUIAnyMap uiw) => GUIWidget uiw where -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'. -- The bounding box wholly contains all children components. - getBoundary :: uiw -> (IntScreen, IntScreen, IntScreen ,IntScreen) -- ^@(x, y, width, height)@ in pixels (screen coordinates) + getBoundary :: uiw -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates) -- |The 'getChildren' function returns all children associated with this widget. -- @@ -19,9 +57,13 @@ class GUIWidget uiw where getChildren _ = [] -- |The function 'isInsideSelf' tests whether a point is inside the widget itself. - -- A screen position may be inside the bounding box of a widget but not considered part of the component. - isInsideSelf :: IntScreen -- ^screen x coordinate - -> IntScreen -- ^screen y coordinate + -- A screen position may be inside the bounding box of a widget but not considered part of the + -- component. + -- + -- The default implementations tests if the point is within the rectangle specified by the + -- 'getBoundary' function. + isInsideSelf :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget -> Bool isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg @@ -31,15 +73,15 @@ class GUIWidget uiw where -- 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 or 'Nothing' if the point neither hits any -- component nor the parent widget itself. - isInside :: IntScreen -- ^screen x coordinate - -> IntScreen -- ^screen y coordinate + isInside :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget -> [GUIAny] isInside x' y' wg = case isInsideSelf x' y' wg of -- test inside parent's bounding box False -> [] True -> case concat $ map (isInside x' y') (getChildren wg) of - [] -> [GUIAny wg] + [] -> [toGUIAny wg] l -> l --TODO: Priority queue? @@ -47,22 +89,297 @@ class GUIWidget uiw where -- A widget with a high score is more in the front than a low scored widget. getPriority :: uiw -> Int getPriority _ = 0 + + -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. + -- The shorthand should be unique for each instance. + getShorthand :: uiw -> String +class MouseHandler a w where + -- |The function 'onMousePressed' is called when the primary button is pressed + -- while inside a screen coordinate within the widget ('isInside'). + onMousePressed :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> w -- ^widget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMousePressed _ _ wg a = return (wg, a) + + -- |The function 'onMouseReleased' is called when the primary 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. + onMouseReleased :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen x coordinate + -> w -- ^wdiget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMouseReleased _ _ wg a = return (wg, a) + + -- |The function 'onMousePressed' is called when the secondary button is pressed + -- while inside a screen coordinate within the widget ('isInside'). + onMousePressedAlt :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> w -- ^widget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMousePressedAlt _ _ wg a = return (wg, a) + + -- |The function 'onMouseReleased' is called when the secondary 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. + onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen x coordinate + -> w -- ^wdiget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMouseReleasedAlt _ _ wg a = return (wg, a) + + -- |The function 'onMouseMove' is invoked when the mouse is moved inside the + -- widget's space ('isInside'). + onMouseMove :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> w -- ^widget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMouseMove _ _ wg a = return (wg, a) + + -- |The function 'onMouseMove' is invoked when the mouse enters the + -- widget's space ('isInside'). + onMouseEnter :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> w -- ^widget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMouseEnter _ _ wg a = return (wg, a) + + -- |The function 'onMouseMove' is invoked when the mouse leaves the + -- widget's space ('isInside'). + onMouseLeave :: ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> w -- ^widget the event is invoked on + -> a -> IO (w, a) -- ^widget after the event and the altered handler + onMouseLeave _ _ wg a = return (wg, a) + +-- |Switches primary and secondary mouse actions. +data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show) +instance Functor (MouseHandlerSwitch w) where + fmap :: (h1 -> h2) -> MouseHandlerSwitch w h1 -> MouseHandlerSwitch w h2 + fmap f (MouseHandlerSwitch h) = MouseHandlerSwitch (f h) +instance Monad (MouseHandlerSwitch w) where + (>>=) :: (MouseHandlerSwitch w h1) -> (h1 -> MouseHandlerSwitch w h2) -> MouseHandlerSwitch w h2 + (MouseHandlerSwitch h) >>= f = f h + return :: h -> MouseHandlerSwitch w h + return h = MouseHandlerSwitch h +instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where + onMousePressed x y w (MouseHandlerSwitch h) = do + (w', h') <- onMousePressedAlt x y w h + return (w', MouseHandlerSwitch h') + onMouseReleased x y w (MouseHandlerSwitch h) = do + (w', h') <- onMouseReleasedAlt x y w h + return (w', MouseHandlerSwitch h') + onMousePressedAlt x y w (MouseHandlerSwitch h) = do + (w', h') <- onMousePressed x y w h + return (w', MouseHandlerSwitch h') + onMouseReleasedAlt x y w (MouseHandlerSwitch h) = do + (w', h') <- onMouseReleased x y w h + return (w', MouseHandlerSwitch h') + onMouseMove x y w (MouseHandlerSwitch h) = do + (w', h') <- onMouseMove x y w h + return (w', MouseHandlerSwitch h') + onMouseEnter x y w (MouseHandlerSwitch h) = do + (w', h') <- onMouseEnter x y w h + return (w', MouseHandlerSwitch h') + onMouseLeave x y w (MouseHandlerSwitch h) = do + (w', h') <- onMouseLeave x y w h + return (w', MouseHandlerSwitch h') + + +-- !!Important: one handler can only handle one single widget!! +data ButtonHandler w = ButtonHandler + { _action :: (w -> ScreenUnit -> ScreenUnit -> IO w) + , _handlerState :: UIState + } +instance (Show w) => Show (ButtonHandler w) where + show (ButtonHandler _ w) = "ButtonHandler [" ++ show w ++ "] " ++ "[action]" +instance MouseHandler (ButtonHandler w) w where + -- |Change 'UIState's '_uistateIsFiring' to @True@. + onMousePressed _ _ wg h@(ButtonHandler _ s) = do + return (wg, h {_handlerState = s {_uistateIsFiring = True}}) + + -- |Change 'UIState's '_uistateIsFiring' to @False@ and + -- call 'action' if inside the widget or + -- set '_uistateIsDeferred' to false otherwise. + onMouseReleased x y wg h@(ButtonHandler f s) = if _uistateIsFiring s + then do + wg' <- f wg x y + return (wg', h {_handlerState = s {_uistateIsFiring = False}}) + else return (wg, h {_handlerState = s {_uistateIsDeferred = False}}) + + -- |Do nothing. + onMouseMove _ _ wg h = return (wg, h) + + -- |Set 'UIState's '_uistateIsReady' to @True@ and + -- update dragging state (only drag if inside widget). + -- In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value + -- and set '_uistateIsFiring' to @False@. + onMouseEnter _ _ wg h@(ButtonHandler _ s) = return + (wg, h {_handlerState = s { _uistateIsFiring = _uistateIsDeferred s + , _uistateIsDeferred = False + , _uistateIsReady = True + }}) + + -- |Set 'UIState's 'uistateIsReady' to @False@ and + -- update dragging state (only drag if inside widget). + -- In detail, change 'UIState's '_uistateIsFiring' to '_uistateIsDeferred's current value + -- and set '_uistateIsDeferred's' to @False@. + onMouseLeave _ _ wg h@(ButtonHandler _ s) = return + (wg, h {_handlerState = s { _uistateIsFiring = False + , _uistateIsDeferred = _uistateIsFiring s + , _uistateIsReady = False + }}) + + +data GUIAny = GUIAnyC GUIContainer + | GUIAnyP GUIPanel + | GUIAnyB GUIButton + deriving (Show) +instance GUIAnyMap GUIAny where + guiAnyMap f w = f w + toGUIAny = id + fromGUIAny = id instance GUIWidget GUIAny where - getBoundary (GUIAny wg) = getBoundary wg - isInsideSelf x y (GUIAny wg) = isInsideSelf x y wg - isInside x y (GUIAny wg) = isInside x y wg - getChildren (GUIAny wg) = getChildren wg - getPriority (GUIAny wg) = getPriority wg + getBoundary (GUIAnyC w) = getBoundary w + getBoundary (GUIAnyP w) = getBoundary w + getBoundary (GUIAnyB w) = getBoundary w + getChildren (GUIAnyC w) = getChildren w + getChildren (GUIAnyP w) = getChildren w + getChildren (GUIAnyB w) = getChildren w + isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w + isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w + isInsideSelf x y (GUIAnyB w) = (isInsideSelf x y) w + isInside x y (GUIAnyC w) = (isInside x y) w + isInside x y (GUIAnyP w) = (isInside x y) w + isInside x y (GUIAnyB w) = (isInside x y) w + getPriority (GUIAnyC w) = getPriority w + getPriority (GUIAnyP w) = getPriority w + getPriority (GUIAnyB w) = getPriority w + getShorthand (GUIAnyC w) = "A" ++ getShorthand w + getShorthand (GUIAnyP w) = "A" ++ getShorthand w + getShorthand (GUIAnyB w) = "A" ++ getShorthand w -data GUIContainer = GUIContainer {_screenX :: IntScreen, _screenY :: IntScreen - , _width :: IntScreen, _height :: IntScreen +-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a +-- functionality itself. +data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit + , _width :: ScreenUnit, _height :: ScreenUnit , _children :: [GUIAny] - , _priority :: Int} + , _priority :: Int + } deriving (Show) +instance GUIAnyMap GUIContainer where + guiAnyMap f (GUIAnyC c) = f c + guiAnyMap _ _ = error "invalid types in guiAnyMap" + toGUIAny cnt = GUIAnyC cnt + fromGUIAny (GUIAnyC cnt) = cnt + fromGUIAny _ = error "invalid GUIAny type" instance GUIWidget GUIContainer where - getBoundary :: GUIContainer -> (IntScreen, IntScreen, IntScreen ,IntScreen) + getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt) getChildren cnt = _children cnt - getPriority cnt = _priority cnt \ No newline at end of file + getPriority cnt = _priority cnt + getShorthand _ = "CNT" + +-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its +-- children components. +data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) +instance GUIAnyMap GUIPanel where + guiAnyMap f (GUIAnyP p) = f p + guiAnyMap _ _ = error "invalid types in guiAnyMap" + toGUIAny pnl = GUIAnyP pnl + fromGUIAny (GUIAnyP pnl) = pnl + fromGUIAny _ = error "invalid GUIAny type" +instance GUIWidget GUIPanel where + getBoundary pnl = case getChildren $ _panelContainer pnl of + [] -> getBoundary $ _panelContainer pnl + cs -> foldl1' determineSize $ map getBoundary cs + where + 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'') + + getChildren pnl = getChildren $ _panelContainer pnl + getPriority pnl = getPriority $ _panelContainer pnl + getShorthand _ = "PNL" + +-- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be +-- provided by an appropriate 'MouseHanlder'. +data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit + , _widthB :: ScreenUnit, _heightB :: ScreenUnit + , _priorityB :: Int + , _actionB :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton) + , _handlerStateB :: UIState + } deriving () + +instance Show GUIButton where + show w = "GUIButton {_screenXB = " ++ show (_screenXB w) + ++ " _screenYB = " ++ show (_screenYB w) + ++ " _widthB = " ++ show (_widthB w) + ++ " _heightB = " ++ show (_heightB w) + ++ " _priorityB = " ++ show (_screenYB w) + ++ " _actionB = " ++ "***" + ++ " _handlerStateB = " ++ show (_handlerStateB w) + ++ "}" +instance MouseHandler GUIButton GUIButton where + -- |Change 'UIState's '_uistateIsFiring' to @True@. + onMousePressed _ _ _ h = let + h' = h {_handlerStateB = (_handlerStateB h) {_uistateIsFiring = True}} + in return (h', h') + + -- |Change 'UIState's '_uistateIsFiring' to @False@ and + -- call '_actionB' if inside the widget or + -- set '_uistateIsDeferred' to false otherwise. + onMouseReleased x y wg h = + if _uistateIsFiring (_handlerStateB h) then do + wg' <- _actionB h wg x y + wg'' <- return wg' {_handlerStateB = (_handlerStateB wg') {_uistateIsFiring = False}} + return (wg'', wg'') + else let + wg' = wg {_handlerStateB = (_handlerStateB wg) {_uistateIsDeferred = False}} + in return (wg', wg') + + -- |Do nothing. + onMouseMove _ _ wg h = return (wg, h) + + -- |Set 'UIState's '_uistateIsReady' to @True@ and + -- update dragging state (only drag if inside widget). + -- In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value + -- and set '_uistateIsFiring' to @False@. + onMouseEnter _ _ _ h = let + s = _handlerStateB h + h' = h {_handlerStateB = s { _uistateIsFiring = _uistateIsDeferred s + , _uistateIsDeferred = False + , _uistateIsReady = True + }} + in return (h', h') + + -- |Set 'UIState's 'uistateIsReady' to @False@ and + -- update dragging state (only drag if inside widget). + -- In detail, change 'UIState's 'uistateIsFiring' to 'uistateIsDeferred's current value + -- and set 'uistateIsDeferred's' to @False@. + onMouseLeave _ _ _ h = let + s = _handlerStateB h + h' = h {_handlerStateB = s { _uistateIsFiring = False + , _uistateIsDeferred = _uistateIsFiring s + , _uistateIsReady = False + }} + in return (h', h') +instance GUIAnyMap GUIButton where + guiAnyMap f (GUIAnyB btn) = f btn + guiAnyMap _ _ = error "invalid types in guiAnyMap" + toGUIAny btn = GUIAnyB btn + fromGUIAny (GUIAnyB btn) = btn + fromGUIAny _ = error "invalid GUIAny type" +instance GUIWidget GUIButton where + getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) + getChildren _ = [] + getPriority btn = _priorityB btn + getShorthand _ = "BTN" \ No newline at end of file From d8967b1b4bc357f1c52b68aa098bbeb094a96082 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Fri, 4 Apr 2014 15:47:16 +0200 Subject: [PATCH 2/2] refined button handling --- src/UI/Callbacks.hs | 8 +-- src/UI/UITypes.hs | 165 ++++++++++++++++++-------------------------- 2 files changed, 71 insertions(+), 102 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 0b98744..a512a54 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -12,7 +12,7 @@ getGUI :: [GUIAny] getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1 , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0 [toGUIAny $ GUIContainer 0 80 100 200 [] 4 - ,GUIAnyB (GUIButton 50 400 200 175 2 (testMessage) defaultUIState) + ,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage ] 3 ] @@ -29,11 +29,11 @@ clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of hit -> liftIO $ do _ <- sequence $ map (\w -> case w of - (GUIAnyB b) -> do + (GUIAnyB b h) -> do putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) ++ " at ["++show x++","++show y++"]" - (b', _) <- onMousePressed x y b b - _ <- onMouseReleased x y b' b' + (b', h') <- onMousePressed x y b h + _ <- onMouseReleased x y b' h' return () _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) ++ " at ["++show x++","++show y++"]" diff --git a/src/UI/UITypes.hs b/src/UI/UITypes.hs index 12ba70c..7a2a14c 100644 --- a/src/UI/UITypes.hs +++ b/src/UI/UITypes.hs @@ -21,23 +21,23 @@ data Viewport = Viewport , _viewportHeight :: !ScreenUnit -- ^viewport height in window } deriving (Eq, Show) -data UIState = UIState - { _uistateIsFiring :: Bool +data UIButtonState = UIButtonState + { _buttonstateIsFiring :: Bool -- ^firing if pressed but not confirmed - , _uistateIsFiringAlt :: Bool + , _buttonstateIsFiringAlt :: Bool -- ^firing if pressed but not confirmed (secondary mouse button) - , _uistateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component - , _uistateIsDeferredAlt :: Bool + , _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component + , _buttonstateIsDeferredAlt :: Bool -- ^deferred if e. g. dragging but outside component (secondary mouse button) - , _uistateIsReady :: Bool + , _buttonstateIsReady :: Bool -- ^ready if mouse is above component - , _uistateIsActivated :: Bool + , _buttonstateIsActivated :: Bool -- ^in activated state (e. g. toggle button) } deriving (Eq, Show) -defaultUIState :: UIState -defaultUIState = UIState False False False False False False +defaultUIState :: UIButtonState +defaultUIState = UIButtonState False False False False False False class GUIAnyMap w where guiAnyMap :: (w -> b) -> GUIAny -> b @@ -94,6 +94,16 @@ class (GUIAnyMap uiw) => GUIWidget uiw where -- The shorthand should be unique for each instance. getShorthand :: uiw -> String +-- |A 'GUIClickable' represents a widget with a 'UIButtonState'. +-- +-- Minimal complete definition: 'getButtonState' and either 'updateButtonState' or 'setButtonState'. +class GUIClickable w where + updateButtonState :: (UIButtonState -> UIButtonState) -> w -> w + updateButtonState f w = setButtonState (f $ getButtonState w) w + setButtonState :: UIButtonState -> w -> w + setButtonState s = updateButtonState (\_ -> s) + getButtonState :: w -> UIButtonState + class MouseHandler a w where -- |The function 'onMousePressed' is called when the primary button is pressed -- while inside a screen coordinate within the widget ('isInside'). @@ -191,52 +201,52 @@ instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where -- !!Important: one handler can only handle one single widget!! data ButtonHandler w = ButtonHandler - { _action :: (w -> ScreenUnit -> ScreenUnit -> IO w) - , _handlerState :: UIState - } -instance (Show w) => Show (ButtonHandler w) where - show (ButtonHandler _ w) = "ButtonHandler [" ++ show w ++ "] " ++ "[action]" -instance MouseHandler (ButtonHandler w) w where - -- |Change 'UIState's '_uistateIsFiring' to @True@. - onMousePressed _ _ wg h@(ButtonHandler _ s) = do - return (wg, h {_handlerState = s {_uistateIsFiring = True}}) + { _action :: (w -> ScreenUnit -> ScreenUnit -> IO w) } +instance Show (ButtonHandler w) where + show _ = "ButtonHandler ***" +instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where + -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. + onMousePressed _ _ wg h = do + return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) - -- |Change 'UIState's '_uistateIsFiring' to @False@ and + -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and -- call 'action' if inside the widget or - -- set '_uistateIsDeferred' to false otherwise. - onMouseReleased x y wg h@(ButtonHandler f s) = if _uistateIsFiring s + -- set '_buttonstateIsDeferred' to false otherwise. + onMouseReleased x y wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg then do - wg' <- f wg x y - return (wg', h {_handlerState = s {_uistateIsFiring = False}}) - else return (wg, h {_handlerState = s {_uistateIsDeferred = False}}) + wg' <- action wg x y + return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h) + else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h) -- |Do nothing. onMouseMove _ _ wg h = return (wg, h) - -- |Set 'UIState's '_uistateIsReady' to @True@ and + -- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and -- update dragging state (only drag if inside widget). - -- In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value - -- and set '_uistateIsFiring' to @False@. - onMouseEnter _ _ wg h@(ButtonHandler _ s) = return - (wg, h {_handlerState = s { _uistateIsFiring = _uistateIsDeferred s - , _uistateIsDeferred = False - , _uistateIsReady = True - }}) + -- In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value + -- and set '_buttonstateIsFiring' to @False@. + onMouseEnter _ _ wg h = return + (updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s + , _buttonstateIsDeferred = False + , _buttonstateIsReady = True + }) wg + , h) - -- |Set 'UIState's 'uistateIsReady' to @False@ and + -- |Set 'UIButtonState's 'buttonstateIsReady' to @False@ and -- update dragging state (only drag if inside widget). - -- In detail, change 'UIState's '_uistateIsFiring' to '_uistateIsDeferred's current value - -- and set '_uistateIsDeferred's' to @False@. - onMouseLeave _ _ wg h@(ButtonHandler _ s) = return - (wg, h {_handlerState = s { _uistateIsFiring = False - , _uistateIsDeferred = _uistateIsFiring s - , _uistateIsReady = False - }}) + -- In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value + -- and set '_buttonstateIsDeferred's' to @False@. + onMouseLeave _ _ wg h = return + (updateButtonState (\s -> s { _buttonstateIsFiring = False + , _buttonstateIsDeferred = _buttonstateIsFiring s + , _buttonstateIsReady = False + }) wg + , h) data GUIAny = GUIAnyC GUIContainer | GUIAnyP GUIPanel - | GUIAnyB GUIButton + | GUIAnyB GUIButton (ButtonHandler GUIButton) deriving (Show) instance GUIAnyMap GUIAny where guiAnyMap f w = f w @@ -246,22 +256,22 @@ instance GUIAnyMap GUIAny where instance GUIWidget GUIAny where getBoundary (GUIAnyC w) = getBoundary w getBoundary (GUIAnyP w) = getBoundary w - getBoundary (GUIAnyB w) = getBoundary w + getBoundary (GUIAnyB w _) = getBoundary w getChildren (GUIAnyC w) = getChildren w getChildren (GUIAnyP w) = getChildren w - getChildren (GUIAnyB w) = getChildren w + getChildren (GUIAnyB w _) = getChildren w isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w - isInsideSelf x y (GUIAnyB w) = (isInsideSelf x y) w + isInsideSelf x y (GUIAnyB w _) = (isInsideSelf x y) w isInside x y (GUIAnyC w) = (isInside x y) w isInside x y (GUIAnyP w) = (isInside x y) w - isInside x y (GUIAnyB w) = (isInside x y) w + isInside x y (GUIAnyB w _) = (isInside x y) w getPriority (GUIAnyC w) = getPriority w getPriority (GUIAnyP w) = getPriority w - getPriority (GUIAnyB w) = getPriority w + getPriority (GUIAnyB w _) = getPriority w getShorthand (GUIAnyC w) = "A" ++ getShorthand w getShorthand (GUIAnyP w) = "A" ++ getShorthand w - getShorthand (GUIAnyB w) = "A" ++ getShorthand w + getShorthand (GUIAnyB w _) = "A" ++ getShorthand w -- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a -- functionality itself. @@ -315,8 +325,8 @@ instance GUIWidget GUIPanel where data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit , _widthB :: ScreenUnit, _heightB :: ScreenUnit , _priorityB :: Int - , _actionB :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton) - , _handlerStateB :: UIState + , _buttonState :: UIButtonState + , _buttonAction :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton) } deriving () instance Show GUIButton where @@ -325,59 +335,18 @@ instance Show GUIButton where ++ " _widthB = " ++ show (_widthB w) ++ " _heightB = " ++ show (_heightB w) ++ " _priorityB = " ++ show (_screenYB w) - ++ " _actionB = " ++ "***" - ++ " _handlerStateB = " ++ show (_handlerStateB w) + ++ " _buttonState = " ++ show (_buttonState w) + ++ " _buttonAction = " ++ "***" ++ "}" -instance MouseHandler GUIButton GUIButton where - -- |Change 'UIState's '_uistateIsFiring' to @True@. - onMousePressed _ _ _ h = let - h' = h {_handlerStateB = (_handlerStateB h) {_uistateIsFiring = True}} - in return (h', h') - - -- |Change 'UIState's '_uistateIsFiring' to @False@ and - -- call '_actionB' if inside the widget or - -- set '_uistateIsDeferred' to false otherwise. - onMouseReleased x y wg h = - if _uistateIsFiring (_handlerStateB h) then do - wg' <- _actionB h wg x y - wg'' <- return wg' {_handlerStateB = (_handlerStateB wg') {_uistateIsFiring = False}} - return (wg'', wg'') - else let - wg' = wg {_handlerStateB = (_handlerStateB wg) {_uistateIsDeferred = False}} - in return (wg', wg') - - -- |Do nothing. - onMouseMove _ _ wg h = return (wg, h) - - -- |Set 'UIState's '_uistateIsReady' to @True@ and - -- update dragging state (only drag if inside widget). - -- In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value - -- and set '_uistateIsFiring' to @False@. - onMouseEnter _ _ _ h = let - s = _handlerStateB h - h' = h {_handlerStateB = s { _uistateIsFiring = _uistateIsDeferred s - , _uistateIsDeferred = False - , _uistateIsReady = True - }} - in return (h', h') - - -- |Set 'UIState's 'uistateIsReady' to @False@ and - -- update dragging state (only drag if inside widget). - -- In detail, change 'UIState's 'uistateIsFiring' to 'uistateIsDeferred's current value - -- and set 'uistateIsDeferred's' to @False@. - onMouseLeave _ _ _ h = let - s = _handlerStateB h - h' = h {_handlerStateB = s { _uistateIsFiring = False - , _uistateIsDeferred = _uistateIsFiring s - , _uistateIsReady = False - }} - in return (h', h') instance GUIAnyMap GUIButton where - guiAnyMap f (GUIAnyB btn) = f btn + guiAnyMap f (GUIAnyB btn _) = f btn guiAnyMap _ _ = error "invalid types in guiAnyMap" - toGUIAny btn = GUIAnyB btn - fromGUIAny (GUIAnyB btn) = btn + toGUIAny btn = GUIAnyB btn $ ButtonHandler $ _buttonAction btn + fromGUIAny (GUIAnyB btn _) = btn fromGUIAny _ = error "invalid GUIAny type" +instance GUIClickable GUIButton where + getButtonState = _buttonState + updateButtonState f btn = btn {_buttonState = f $ _buttonState btn} instance GUIWidget GUIButton where getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) getChildren _ = []