From 5be37f64531cec12639bc72e9708b9d38249551b Mon Sep 17 00:00:00 2001 From: tpajenka Date: Thu, 1 May 2014 20:31:15 +0200 Subject: [PATCH] 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