From ca51c23650df5f445fcde47c67bfda56df49add2 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Fri, 2 May 2014 01:28:40 +0200 Subject: [PATCH] restructured GUI widgets' data representation from class type/instance-based to function-based advantage: single constructor for any widget type, no branching necessary --- src/Types.hs | 2 +- src/UI/Callbacks.hs | 100 ++++++++-------- src/UI/UIBaseData.hs | 252 ++++++++++++++++++++++++++++++++-------- src/UI/UIClasses.hs | 257 +++++------------------------------------ src/UI/UIOperations.hs | 44 ++++--- 5 files changed, 308 insertions(+), 347 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 115796a..f5e88a4 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -135,7 +135,7 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool - , _uiMap :: Map.HashMap UIId (GUIAny Pioneers) + , _uiMap :: Map.HashMap UIId (GUIWidget Pioneers) , _uiRoots :: [UIId] } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 7dc663d..d2805c3 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -9,27 +9,27 @@ import Control.Monad.Trans (liftIO) import qualified Data.HashMap.Strict as Map import Data.List (foldl') import Data.Maybe -import Foreign.Marshal.Array (pokeArray) -import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (pokeArray) +import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL import Render.Misc (genColorData) import Types -import Render.Misc (curb) +import Render.Misc (curb) -- TODO: necessary import ? import UI.UIBaseData import UI.UIClasses import UI.UIOperations -createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId]) -createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0) - , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1) - , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3) - , (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 ) - , (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage)) +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 0]) -getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers] +getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers] getGUI = Map.elems {-# INLINE getGUI #-} @@ -38,23 +38,36 @@ getRootIds = do state <- get return $ state ^. ui.uiRoots -getRoots :: Pioneers [GUIAny Pioneers] +getRoots :: Pioneers [GUIWidget Pioneers] getRoots = do state <- get rootIds <- getRootIds let hMap = state ^. ui.uiMap return $ toGUIAnys hMap rootIds -testMessage :: w -> Pixel -> Pioneers w -testMessage w (x, y) = do - liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y) +testMessage :: MouseButton -> w -> Pixel -> Pioneers w +testMessage btn w (x, y) = do + case btn of + LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y) + RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y) + MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y) + MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y) + MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y) return w +transformButton :: SDL.MouseButton -> Maybe MouseButton +transformButton SDL.LeftButton = Just LeftButton +transformButton SDL.RightButton = Just RightButton +transformButton SDL.MiddleButton = Just MiddleButton +transformButton SDL.MouseX1 = Just MouseX1 +transformButton SDL.MouseX2 = Just MouseX2 +transformButton _ = Nothing + eventCallback :: SDL.Event -> Pioneers () eventCallback e = do env <- ask case SDL.eventData e of - SDL.Window _ winEvent -> -- windowID event + SDL.Window _ _ -> -- windowID event -- TODO: resize GUI return () SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym @@ -109,11 +122,9 @@ eventCallback e = do if st ^. mouse.isDragging then modify $ mouse.isDragging .~ False else - clickHandler (x, y) - SDL.RightButton -> do - when (state == SDL.Released) $ alternateClickHandler (x, y) - _ -> - return () + clickHandler LeftButton (x, y) + _ -> do when (state == SDL.Released) + $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do state <- get @@ -122,46 +133,38 @@ eventCallback e = do -- there is more (joystic, touchInterface, ...), but currently ignored SDL.Quit -> modify $ window.shouldClose .~ True _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] - + -- | Handler for UI-Inputs. -- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... -clickHandler :: Pixel -> Pioneers () -clickHandler pos@(x,y) = do +clickHandler :: MouseButton -> Pixel -> Pioneers () +clickHandler btn pos@(x,y) = do state <- get let hMap = state ^. ui.uiMap roots <- getRootIds hits <- liftM concat $ mapM (getInsideId hMap pos) roots case hits of - [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] + [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"] _ -> do changes <- mapM (\uid -> do let w = toGUIAny hMap uid - short <- getShorthand w - bound <- getBoundary w - prio <- getPriority w + 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 of - (GUIAnyB b h) -> do - (b', h') <- onMousePressed pos b h - (b'', h'') <- onMouseReleased pos b' h' - return $ Just (uid, GUIAnyB b'' h'') - _ -> return Nothing + case w ^. mouseActions of + Just ma -> do w' <- (ma ^. onMousePress) btn pos w + w'' <- (ma ^. onMouseRelease) btn pos w' + return $ Just (uid, w'') + Nothing -> return Nothing ) $ hits - let newMap :: Map.HashMap UIId (GUIAny Pioneers) + let newMap :: Map.HashMap UIId (GUIWidget Pioneers) newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes modify $ ui.uiMap .~ newMap return () - --- | Handler for UI-Inputs. --- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ... -alternateClickHandler :: Pixel -> Pioneers () -alternateClickHandler (x,y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"] - - -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture -- --TODO: should be done asynchronously at one point. @@ -183,19 +186,20 @@ prepareGUI = do modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers () +copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers () copyGUI tex widget = do - (xoff, yoff, wWidth, wHeight) <- getBoundary widget + (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary state <- get let hMap = state ^. ui.uiMap int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ... --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. - color = case widget of - (GUIAnyC _) -> [255,0,0,128] - (GUIAnyB _ _) -> [255,255,0,255] - (GUIAnyP _) -> [128,128,128,128] + color = case widget ^. baseProperties.shorthand of + "CNT" -> [255,0,0,128] + "BTN" -> [255,255,0,255] + "PNL" -> [128,128,128,128] + _ -> [255,0,255,255] liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do --copy data into C-Array pokeArray ptr (genColorData (wWidth*wHeight) color) @@ -205,7 +209,7 @@ copyGUI tex widget = do (GL.TexturePosition2D (int xoff) (int yoff)) (GL.TextureSize2D (int wWidth) (int wHeight)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr) - nextChildrenIds <- getChildren widget + nextChildrenIds <- widget ^. baseProperties.children mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index b620a24..8e05170 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -1,10 +1,15 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-} -- data and classes are separated into several modules to avoid cyclic dependencies with the Type module - +-- TODO: exclude UIMouseState constructor module UI.UIBaseData where -import Data.Hashable -import Data.Ix +import Control.Lens ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses) +import Control.Monad (liftM) +import Data.Array +import Data.Hashable +import Data.Ix () +import Data.Maybe +import GHC.Generics (Generic) -- |Unit of screen/window type ScreenUnit = Int @@ -12,21 +17,30 @@ type ScreenUnit = Int -- | @x@ and @y@ position on screen. type Pixel = (ScreenUnit, ScreenUnit) -newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) +newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read) + +data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2 + deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) + +instance Hashable MouseButton + +firstButton :: MouseButton +firstButton = LeftButton + +lastButton :: MouseButton +lastButton = MiddleButton + +-- |The button dependant state of a 'UIMouseState'. +data UIMouseStateSingle = MouseStateSingle + { _mouseIsFiring :: Bool -- ^firing if pressed but not confirmed + , _mouseIsDeferred :: Bool + -- ^deferred if e. g. dragging but outside component + } deriving (Eq, Show) -- |The state of a clickable ui widget. -data UIButtonState = UIButtonState - { _buttonstateIsFiring :: Bool - -- ^firing if pressed but not confirmed - , _buttonstateIsFiringAlt :: Bool - -- ^firing if pressed but not confirmed (secondary mouse button) - , _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component - , _buttonstateIsDeferredAlt :: Bool - -- ^deferred if e. g. dragging but outside component (secondary mouse button) - , _buttonstateIsReady :: Bool - -- ^ready if mouse is above component - , _buttonstateIsActivated :: Bool - -- ^in activated state (e. g. toggle button) +data UIMouseState = MouseState + { _mouseStates :: Array MouseButton UIMouseStateSingle + , _mouseIsReady :: Bool -- ^ready if mouse is above component } deriving (Eq, Show) @@ -36,41 +50,183 @@ 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) } + { _action :: w -> Pixel -> m w } instance Show (ButtonHandler m w) where show _ = "ButtonHandler ***" --- |A collection data type that may hold any usable ui element. @m@ is a monad. -data GUIAny m = GUIAnyC GUIContainer - | GUIAnyP GUIPanel - | GUIAnyB GUIButton (ButtonHandler m GUIButton) - deriving (Show) +-- |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 + } + +-- |Base properties are fundamental settings of any 'GUIWidget'. +-- They mostly control positioning and widget hierarchy. +data GUIBaseProperties m = BaseProperties + { + -- |The @_getBoundary@ function gives the outer extents of the @GUIWidget@. + -- The bounding box wholly contains all children components. + _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'. + _children :: m [UIId] + , + -- |The function @_isInside@ 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. + -- + -- The default implementations tests if the point is within the rectangle specified by the + -- 'getBoundary' function. + _isInside :: GUIWidget m + -> Pixel -- ^screen position + -> 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. + _priority :: m Int + , + -- |The @_getShorthand@ function returns a descriptive 'String' mainly for debuggin prupose. + -- The shorthand should be unique for each instance. + _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 + } --- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a --- functionality itself. -data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit - , _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit - , _uiChildren :: [UIId] - , _uiPriority :: Int - } deriving (Show) +-- |@GUIGraphics@ functions define the look of a 'GUIWidget'. --- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its --- children components. -data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) +data GUIGraphics m = Graphics + {temp :: m Int} + +$(makeLenses ''UIMouseState) +$(makeLenses ''UIMouseStateSingle) +$(makeLenses ''GUIWidget) +$(makeLenses ''GUIBaseProperties) +$(makeLenses ''GUIMouseActions) +$(makeLenses ''GUIGraphics) + +initialMouseStateS :: UIMouseStateSingle +initialMouseStateS = MouseStateSingle False False +{-# INLINE initialMouseStateS #-} + +-- |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 +{-# 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' + where + -- |Change 'UIMouseState's '_mouseIsFiring' to @True@. + press' b _ w = + return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ 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) + + -- |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))) + + + -- |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))) + +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) + +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)) + (return prio) short + +debugShowWidget' :: (Monad m) => GUIWidget m -> m String +debugShowWidget' (Widget base mouse _) = 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] --- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be --- provided by an appropriate 'MouseHanlder'. -data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit - , _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit - , _uiPriorityB :: Int - , _uiButtonState :: UIButtonState - } deriving () -instance Show GUIButton where - show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w) - ++ " _screenYB = " ++ show (_uiScreenYB w) - ++ " _widthB = " ++ show (_uiWidthB w) - ++ " _heightB = " ++ show (_uiHeightB w) - ++ " _priorityB = " ++ show (_uiScreenYB w) - ++ " _buttonState = " ++ show (_uiButtonState w) - ++ "}" diff --git a/src/UI/UIClasses.hs b/src/UI/UIClasses.hs index c0cc37d..b9eab18 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIClasses.hs @@ -1,8 +1,8 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} -module UI.UIClasses where +module UI.UIClasses (module UI.UIClasses, module UI.UIBaseData) where -import Control.Lens ((^.)) +import Control.Lens ((^.), (.~), (&)) import Control.Monad --import Control.Monad.IO.Class -- MonadIO import Control.Monad.RWS.Strict (get) @@ -10,234 +10,39 @@ import Data.List import Data.Maybe import qualified Data.HashMap.Strict as Map -import qualified Types as T +import Types import UI.UIBaseData -class GUIAnyMap m w where - guiAnyMap :: (w -> b) -> GUIAny m -> b - -class (Monad m) => GUIWidget m uiw where - -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'. - -- The bounding box wholly contains all children components. - getBoundary :: uiw -> 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 'getBoundary'. - getChildren :: uiw -> m [UIId] - getChildren _ = return [] +createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m +createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT") + Nothing + emptyGraphics - -- |The function 'isInside' 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. - -- - -- The default implementations tests if the point is within the rectangle specified by the - -- 'getBoundary' function. - isInside :: Pixel -- ^screen position - -> uiw -- ^the parent widget - -> m Bool - isInside (x',y') wg = do - (x, y, w, h) <- getBoundary wg - return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) - -- |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. - getPriority :: uiw -> m Int - getPriority _ = return 0 - - -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. - -- The shorthand should be unique for each instance. - getShorthand :: uiw -> m 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 Monad m => MouseHandler a m w where - -- |The function 'onMousePressed' is called when the primary button is pressed - -- while inside a screen coordinate within the widget ('isInside'). - onMousePressed :: Pixel -- ^screen position - -> w -- ^widget the event is invoked on - -> a -> m (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 :: Pixel -- ^screen position - -> w -- ^wdiget the event is invoked on - -> a -> m (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 :: Pixel -- ^screen position - -> w -- ^widget the event is invoked on - -> a -> m (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 :: Pixel -- ^screen position - -> w -- ^wdiget the event is invoked on - -> a -> m (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 :: Pixel -- ^screen position - -> w -- ^widget the event is invoked on - -> a -> m (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 :: Pixel -- ^screen position - -> w -- ^widget the event is invoked on - -> a -> m (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 :: Pixel -- ^screen position - -> w -- ^widget the event is invoked on - -> a -> m (w, a) -- ^widget after the event and the altered handler - onMouseLeave _ wg a = return (wg, a) - -instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where - onMousePressed p w (MouseHandlerSwitch h) = do - (w', h') <- onMousePressedAlt p w h - return (w', MouseHandlerSwitch h') - onMouseReleased p w (MouseHandlerSwitch h) = do - (w', h') <- onMouseReleasedAlt p w h - return (w', MouseHandlerSwitch h') - onMousePressedAlt p w (MouseHandlerSwitch h) = do - (w', h') <- onMousePressed p w h - return (w', MouseHandlerSwitch h') - onMouseReleasedAlt p w (MouseHandlerSwitch h) = do - (w', h') <- onMouseReleased p w h - return (w', MouseHandlerSwitch h') - onMouseMove p w (MouseHandlerSwitch h) = do - (w', h') <- onMouseMove p w h - return (w', MouseHandlerSwitch h') - onMouseEnter p w (MouseHandlerSwitch h) = do - (w', h') <- onMouseEnter p w h - return (w', MouseHandlerSwitch h') - onMouseLeave p w (MouseHandlerSwitch h) = do - (w', h') <- onMouseLeave p w h - return (w', MouseHandlerSwitch h') - -instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where - -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. - onMousePressed _ wg h = - return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) - - -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and - -- call 'action' if inside the widget or - -- set '_buttonstateIsDeferred' to false otherwise. - onMouseReleased p wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg - then do - wg' <- action wg p - 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 'UIButtonState's '_buttonstateIsReady' to @True@ and - -- update dragging state (only drag if inside widget). - -- 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 'UIButtonState's 'buttonstateIsReady' to @False@ and - -- update dragging state (only drag if inside widget). - -- 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) - -instance (Monad m) => GUIAnyMap m (GUIAny m) where - guiAnyMap f w = f w - -instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where - 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 - isInside p (GUIAnyC w) = (isInside p) w - isInside p (GUIAnyP w) = (isInside p) w - isInside p (GUIAnyB w _) = (isInside p) w - getPriority (GUIAnyC w) = getPriority w - getPriority (GUIAnyP w) = getPriority w - getPriority (GUIAnyB w _) = getPriority w - getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str } - getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str } - getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str } - -instance (Monad m) => GUIAnyMap m GUIContainer where - guiAnyMap f (GUIAnyC c) = f c - guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance (Monad m) => GUIWidget m GUIContainer where - getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) - getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt) - getChildren cnt = return $ _uiChildren cnt - getPriority cnt = return $ _uiPriority cnt - getShorthand _ = return $ "CNT" - -instance GUIAnyMap m GUIPanel where - guiAnyMap f (GUIAnyP p) = f p - guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance GUIWidget T.Pioneers GUIPanel where - getBoundary pnl = do +createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers +createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize') + Nothing + emptyGraphics + where + autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) + autosize' = do state <- get - let hmap = state ^. T.ui . T.uiMap - case _uiChildren $ _panelContainer pnl of - [] -> getBoundary $ _panelContainer pnl - cs -> do - let widgets = catMaybes $ map (flip Map.lookup hmap) cs - foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets - 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 _ = return $ "PNL" + 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'') + case chld of + [] -> return bnd + cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs + foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets -instance (Monad m) => GUIAnyMap m GUIButton where - guiAnyMap f (GUIAnyB btn _) = f btn - guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance GUIClickable GUIButton where - getButtonState = _uiButtonState - updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn} -instance (Monad m) => GUIWidget m GUIButton where - getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn) - getChildren _ = return [] - getPriority btn = return $ _uiPriorityB btn - getShorthand _ = return "BTN" \ No newline at end of file +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 diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 3c62325..d9492e0 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -1,23 +1,19 @@ module UI.UIOperations where -import Control.Monad (liftM) -import qualified Data.HashMap.Strict as Map +import Control.Lens ((^.)) +import Control.Monad (liftM) +import qualified Data.HashMap.Strict as Map import Data.Maybe import Types import UI.UIBaseData -import UI.UIClasses -defaultUIState :: UIButtonState -defaultUIState = UIButtonState False False False False False False -{-# INLINE defaultUIState #-} - -toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m +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 #-} -toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m] -toGUIAnys m = mapMaybe (flip Map.lookup m) +toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m] +toGUIAnys m = mapMaybe (`Map.lookup` m) {-# INLINE toGUIAnys #-} -- TODO: check for missing components? @@ -31,19 +27,19 @@ toGUIAnys m = mapMaybe (flip Map.lookup m) -- or @[]@ if the point does not hit the widget. -- -- This function returns the widgets themselves unlike 'getInsideId'. -getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets - -> Pixel -- ^screen position - -> GUIAny Pioneers -- ^the parent widget - -> Pioneers [GUIAny Pioneers] -getInside hMap (x',y') wg = do - inside <- isInside (x',y') wg +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 <- getChildren wg - hitChildren <- liftM concat $ mapM (getInside hMap (x',y')) (toGUIAnys hMap childrenIds) + childrenIds <- wg ^. baseProperties.children + hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds) case hitChildren of [] -> return [wg] - _ -> return hitChildren + _ -> return hitChildren else return [] --TODO: Priority queue? @@ -56,17 +52,17 @@ getInside hMap (x',y') wg = do -- or @[]@ if the point does not hit the widget. -- -- This function returns the 'UIId's of the widgets unlike 'getInside'. -getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets +getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets -> Pixel -- ^screen position -> UIId -- ^the parent widget -> Pioneers [UIId] -getInsideId hMap (x',y') uid = do +getInsideId hMap px uid = do let wg = toGUIAny hMap uid - inside <- isInside (x',y') wg + inside <- (wg ^. baseProperties.isInside) wg px if inside -- test inside parent's bounding box then do - childrenIds <- getChildren wg - hitChildren <- liftM concat $ mapM (getInsideId hMap (x',y')) childrenIds + childrenIds <- wg ^. baseProperties.children + hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds case hitChildren of [] -> return [uid] _ -> return hitChildren