From a3fe5a1d8b7a18a46dac92f9dd7469d4d06aef47 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Thu, 1 May 2014 19:12:01 +0200 Subject: [PATCH 1/4] compiler warning and HLint remarks --- src/UI/Callbacks.hs | 6 +++--- src/UI/UIOperations.hs | 7 +++---- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 58e2e59..5afe011 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -30,7 +30,8 @@ createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [ ], [UIId 0]) getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers] -getGUI hmap = Map.elems hmap +getGUI = Map.elems +{-# INLINE getGUI #-} getRootIds :: Pioneers [UIId] getRootIds = do @@ -60,7 +61,7 @@ clickHandler (Pixel x y) = do case hits of [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] _ -> do - changes <- sequence $ map (\uid -> do + changes <- mapM (\uid -> do let w = toGUIAny hMap uid short <- getShorthand w bound <- getBoundary w @@ -121,7 +122,6 @@ copyGUI tex widget = do (GUIAnyC _) -> [255,0,0,128] (GUIAnyB _ _) -> [255,255,0,255] (GUIAnyP _) -> [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) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index a6085d0..fd02aaa 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -10,15 +10,14 @@ 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 m uid = case Map.lookup uid m of - Just w -> w - Nothing -> error "map does not contain requested key" --TODO: better error handling +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 ids = mapMaybe (flip Map.lookup m) ids +toGUIAnys m = mapMaybe (flip Map.lookup m) {-# INLINE toGUIAnys #-} -- TODO: check for missing components? From 5be37f64531cec12639bc72e9708b9d38249551b Mon Sep 17 00:00:00 2001 From: tpajenka Date: Thu, 1 May 2014 20:31:15 +0200 Subject: [PATCH 2/4] moved user event handling into UI/Callbacks.hs --- src/Main.hs | 101 ++++++++--------------------------------- src/UI/Callbacks.hs | 98 ++++++++++++++++++++++++++++++++++----- src/UI/UIBaseData.hs | 4 +- src/UI/UIClasses.hs | 94 ++++++++++++++++++-------------------- src/UI/UIOperations.hs | 18 ++++---- 5 files changed, 159 insertions(+), 156 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 935f2ec..41c77dd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -55,11 +55,11 @@ import Importer.IQM.Parser testParser :: String -> IO () testParser a = putStrLn . show =<< parseIQM a {-do - f <- B.readFile a - putStrLn "reading in:" - putStrLn $ show f - putStrLn "parsed:" - parseTest parseIQM f-} + f <- B.readFile a + putStrLn "reading in:" + putStrLn $ show f + putStrLn "parsed:" + parseTest parseIQM f-} -------------------------------------------------------------------------------- @@ -322,81 +322,18 @@ processEvents = do processEvent :: Event -> Pioneers () processEvent e = do - env <- ask - case eventData e of - Window _ winEvent -> - case winEvent of - Closing -> - modify $ window.shouldClose .~ True - Resized {windowResizedTo=size} -> do - modify $ (window . width .~ sizeWidth size) - . (window . height .~ sizeHeight size) - adjustWindow - SizeChanged -> - adjustWindow - _ -> - return () - --liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e] - Keyboard movement _ _{-isRepeated-} key -> --up/down window(ignored) true/false actualKey - -- need modifiers? use "keyModifiers key" to get them - let aks = keyboard.arrowsPressed in - case keyScancode key of - SDL.R -> - liftIO $ do - r <- getRenderer $ env ^. windowObject - putStrLn $ unwords ["Renderer: ",show r] - Escape -> + eventCallback e + -- env <- ask + case SDL.eventData e of + SDL.Window _ winEvent -> -- windowID event + case winEvent of + SDL.Closing -> modify $ window.shouldClose .~ True - SDL.Left -> - modify $ aks.left .~ (movement == KeyDown) - SDL.Right -> - modify $ aks.right .~ (movement == KeyDown) - SDL.Up -> - modify $ aks.up .~ (movement == KeyDown) - SDL.Down -> - modify $ aks.down .~ (movement == KeyDown) - SDL.KeypadPlus -> - when (movement == KeyDown) $ do - modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1)) - state <- get - liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] - SDL.KeypadMinus -> - when (movement == KeyDown) $ do - modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1))) - state <- get - liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] - _ -> - return () - MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do - state <- get - when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ - modify $ (mouse.isDragging .~ True) - . (mouse.dragStartX .~ (fromIntegral x)) - . (mouse.dragStartY .~ (fromIntegral y)) - . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) - . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) - - modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) - . (mouse.mousePosition. Types._y .~ (fromIntegral y)) - MouseButton _ _{-mouseId-} button state (SDL.Position x y) -> - case button of - LeftButton -> do - let pressed = state == Pressed - modify $ mouse.isDown .~ pressed - unless pressed $ do - st <- get - if st ^. mouse.isDragging then - modify $ mouse.isDragging .~ False - else - clickHandler (UI.Callbacks.Pixel x y) - RightButton -> do - when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y) - _ -> - return () - MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do - state <- get - let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in - modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist') - Quit -> modify $ window.shouldClose .~ True - -- there is more (joystic, touchInterface, ...), but currently ignored - _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] + SDL.Resized {windowResizedTo=size} -> do + modify $ (window . width .~ SDL.sizeWidth size) + . (window . height .~ SDL.sizeHeight size) + adjustWindow + SDL.SizeChanged -> + adjustWindow + _ -> return () + _ -> return () diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 5afe011..7dc663d 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -2,25 +2,25 @@ module UI.Callbacks where import qualified Graphics.Rendering.OpenGL.GL as GL -import Control.Lens ((^.), (.~)) -import Control.Monad (liftM) -import Control.Monad.RWS.Strict (get, modify) +import Control.Lens ((^.), (.~), (%~)) +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.Maybe 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 UI.UIBaseData import UI.UIClasses import UI.UIOperations -data Pixel = Pixel Int Int - 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) @@ -45,19 +45,93 @@ getRoots = do let hMap = state ^. ui.uiMap return $ toGUIAnys hMap rootIds -testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w -testMessage w x y = do +testMessage :: w -> Pixel -> Pioneers w +testMessage w (x, y) = do liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y) return w +eventCallback :: SDL.Event -> Pioneers () +eventCallback e = do + env <- ask + case SDL.eventData e of + SDL.Window _ winEvent -> -- windowID event + -- TODO: resize GUI + return () + SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym + -- need modifiers? use "keyModifiers key" to get them + let aks = keyboard.arrowsPressed in + case SDL.keyScancode key of + SDL.R -> + liftIO $ do + r <- SDL.getRenderer $ env ^. windowObject + putStrLn $ unwords ["Renderer: ",show r] + SDL.Escape -> + modify $ window.shouldClose .~ True + SDL.Left -> + modify $ aks.left .~ (movement == SDL.KeyDown) + SDL.Right -> + modify $ aks.right .~ (movement == SDL.KeyDown) + SDL.Up -> + modify $ aks.up .~ (movement == SDL.KeyDown) + SDL.Down -> + modify $ aks.down .~ (movement == SDL.KeyDown) + SDL.KeypadPlus -> + when (movement == SDL.KeyDown) $ do + modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1)) + state <- get + liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] + SDL.KeypadMinus -> + when (movement == SDL.KeyDown) $ do + modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1))) + state <- get + liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] + _ -> + return () + SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel + do + state <- get + when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ + modify $ (mouse.isDragging .~ True) + . (mouse.dragStartX .~ (fromIntegral x)) + . (mouse.dragStartY .~ (fromIntegral y)) + . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) + . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) + + modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) + . (mouse.mousePosition. Types._y .~ (fromIntegral y)) + SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt + case button of + SDL.LeftButton -> do + let pressed = state == SDL.Pressed + modify $ mouse.isDown .~ pressed + unless pressed $ do + st <- get + if st ^. mouse.isDragging then + modify $ mouse.isDragging .~ False + else + clickHandler (x, y) + SDL.RightButton -> do + when (state == SDL.Released) $ alternateClickHandler (x, y) + _ -> + return () + SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll + do + state <- get + let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in + modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist') + -- 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 (Pixel x y) = do +clickHandler pos@(x,y) = do state <- get let hMap = state ^. ui.uiMap roots <- getRootIds - hits <- liftM concat $ mapM (getInsideId hMap x y) roots + hits <- liftM concat $ mapM (getInsideId hMap pos) roots case hits of [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] _ -> do @@ -70,8 +144,8 @@ clickHandler (Pixel x y) = do ++ " at [" ++ show x ++ "," ++ show y ++ "]" case w of (GUIAnyB b h) -> do - (b', h') <- onMousePressed x y b h - (b'', h'') <- onMouseReleased x y b' h' + (b', h') <- onMousePressed pos b h + (b'', h'') <- onMouseReleased pos b' h' return $ Just (uid, GUIAnyB b'' h'') _ -> return Nothing ) $ hits @@ -85,7 +159,7 @@ clickHandler (Pixel x y) = do -- | Handler for UI-Inputs. -- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ... alternateClickHandler :: Pixel -> Pioneers () -alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"] +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 diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index c21008f..b620a24 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -9,6 +9,8 @@ import Data.Ix -- |Unit of screen/window 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) @@ -34,7 +36,7 @@ data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show) -- |A 'UI.UIClasses.MouseHandler' with button behaviour. data ButtonHandler m w = ButtonHandler - { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) } + { _action :: (w -> Pixel -> m w) } instance Show (ButtonHandler m w) where show _ = "ButtonHandler ***" diff --git a/src/UI/UIClasses.hs b/src/UI/UIClasses.hs index 377e463..c0cc37d 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIClasses.hs @@ -33,11 +33,10 @@ class (Monad m) => GUIWidget m uiw where -- -- The default implementations tests if the point is within the rectangle specified by the -- 'getBoundary' function. - isInside :: ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate - -> uiw -- ^the parent widget - -> m Bool - isInside x' y' wg = do + 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) @@ -63,109 +62,102 @@ class GUIClickable w where 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 :: ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate + 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) + 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 + 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) + 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 -> m (w, a) -- ^widget after the event and the altered handler - onMousePressedAlt _ _ wg a = return (wg, a) + 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 :: ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen x coordinate + 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) + 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 + 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) + 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 + 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) + 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 + 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) + onMouseLeave _ wg a = return (wg, a) instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where - onMousePressed x y w (MouseHandlerSwitch h) = do - (w', h') <- onMousePressedAlt x y w h + onMousePressed p w (MouseHandlerSwitch h) = do + (w', h') <- onMousePressedAlt p w h return (w', MouseHandlerSwitch h') - onMouseReleased x y w (MouseHandlerSwitch h) = do - (w', h') <- onMouseReleasedAlt x y w h + onMouseReleased p w (MouseHandlerSwitch h) = do + (w', h') <- onMouseReleasedAlt p w h return (w', MouseHandlerSwitch h') - onMousePressedAlt x y w (MouseHandlerSwitch h) = do - (w', h') <- onMousePressed x y w h + onMousePressedAlt p w (MouseHandlerSwitch h) = do + (w', h') <- onMousePressed p w h return (w', MouseHandlerSwitch h') - onMouseReleasedAlt x y w (MouseHandlerSwitch h) = do - (w', h') <- onMouseReleased x y w h + onMouseReleasedAlt p w (MouseHandlerSwitch h) = do + (w', h') <- onMouseReleased p w h return (w', MouseHandlerSwitch h') - onMouseMove x y w (MouseHandlerSwitch h) = do - (w', h') <- onMouseMove x y w h + onMouseMove p w (MouseHandlerSwitch h) = do + (w', h') <- onMouseMove p w h return (w', MouseHandlerSwitch h') - onMouseEnter x y w (MouseHandlerSwitch h) = do - (w', h') <- onMouseEnter x y w h + onMouseEnter p w (MouseHandlerSwitch h) = do + (w', h') <- onMouseEnter p w h return (w', MouseHandlerSwitch h') - onMouseLeave x y w (MouseHandlerSwitch h) = do - (w', h') <- onMouseLeave x y w 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 = + 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 x y wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg + onMouseReleased p wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg then do - wg' <- action wg x y + 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) + 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 + onMouseEnter _ wg h = return (updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s , _buttonstateIsDeferred = False , _buttonstateIsReady = True @@ -176,7 +168,7 @@ instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where -- 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 + onMouseLeave _ wg h = return (updateButtonState (\s -> s { _buttonstateIsFiring = False , _buttonstateIsDeferred = _buttonstateIsFiring s , _buttonstateIsReady = False @@ -193,9 +185,9 @@ instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where getChildren (GUIAnyC w) = getChildren w getChildren (GUIAnyP w) = getChildren w getChildren (GUIAnyB w _) = getChildren 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 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 diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index fd02aaa..3c62325 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -32,16 +32,15 @@ toGUIAnys m = mapMaybe (flip Map.lookup m) -- -- This function returns the widgets themselves unlike 'getInsideId'. getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets - -> ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate + -> Pixel -- ^screen position -> GUIAny Pioneers -- ^the parent widget -> Pioneers [GUIAny Pioneers] -getInside hMap x' y' wg = do - inside <- isInside x' y' wg +getInside hMap (x',y') wg = do + inside <- isInside (x',y') wg if inside -- test inside parent's bounding box then do childrenIds <- getChildren wg - hitChildren <- liftM concat $ mapM (getInside hMap x' y') (toGUIAnys hMap childrenIds) + hitChildren <- liftM concat $ mapM (getInside hMap (x',y')) (toGUIAnys hMap childrenIds) case hitChildren of [] -> return [wg] _ -> return hitChildren @@ -58,17 +57,16 @@ getInside hMap x' y' wg = do -- -- This function returns the 'UIId's of the widgets unlike 'getInside'. getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets - -> ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate + -> Pixel -- ^screen position -> UIId -- ^the parent widget -> Pioneers [UIId] -getInsideId hMap x' y' uid = do +getInsideId hMap (x',y') uid = do let wg = toGUIAny hMap uid - inside <- isInside x' y' wg + inside <- isInside (x',y') wg if inside -- test inside parent's bounding box then do childrenIds <- getChildren wg - hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds + hitChildren <- liftM concat $ mapM (getInsideId hMap (x',y')) childrenIds case hitChildren of [] -> return [uid] _ -> return hitChildren From ca51c23650df5f445fcde47c67bfda56df49add2 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Fri, 2 May 2014 01:28:40 +0200 Subject: [PATCH 3/4] 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 From ad0e569537f0103323bbdb6d9bd500230a226418 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sat, 3 May 2014 14:51:24 +0200 Subject: [PATCH 4/4] renamed modules after restructuring UI data --- src/Types.hs | 2 +- src/UI/Callbacks.hs | 7 +++---- src/UI/{UIBaseData.hs => UIBase.hs} | 6 +++--- src/UI/UIOperations.hs | 2 +- src/UI/{UIClasses.hs => UIWidgets.hs} | 4 ++-- 5 files changed, 10 insertions(+), 11 deletions(-) rename src/UI/{UIBaseData.hs => UIBase.hs} (98%) rename src/UI/{UIClasses.hs => UIWidgets.hs} (96%) diff --git a/src/Types.hs b/src/Types.hs index f5e88a4..87726b7 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -12,7 +12,7 @@ import Control.Monad.RWS.Strict (RWST) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types -import UI.UIBaseData +import UI.UIBase --Static Read-Only-State diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index d2805c3..7d71021 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -12,12 +12,11 @@ import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) import qualified Graphics.UI.SDL as SDL -import Render.Misc (genColorData) + +import Render.Misc (curb,genColorData) import Types -import Render.Misc (curb) -- TODO: necessary import ? -import UI.UIBaseData -import UI.UIClasses +import UI.UIWidgets import UI.UIOperations diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBase.hs similarity index 98% rename from src/UI/UIBaseData.hs rename to src/UI/UIBase.hs index 8e05170..0ba8094 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBase.hs @@ -1,7 +1,7 @@ {-# 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 +-- 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 import Control.Lens ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses) import Control.Monad (liftM) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index d9492e0..940c3e9 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -6,7 +6,7 @@ import qualified Data.HashMap.Strict as Map import Data.Maybe import Types -import UI.UIBaseData +import UI.UIBase toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m) diff --git a/src/UI/UIClasses.hs b/src/UI/UIWidgets.hs similarity index 96% rename from src/UI/UIClasses.hs rename to src/UI/UIWidgets.hs index b9eab18..a2ae296 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIWidgets.hs @@ -1,6 +1,6 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} -module UI.UIClasses (module UI.UIClasses, module UI.UIBaseData) where +module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where import Control.Lens ((^.), (.~), (&)) import Control.Monad @@ -11,7 +11,7 @@ import Data.Maybe import qualified Data.HashMap.Strict as Map import Types -import UI.UIBaseData +import UI.UIBase createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m