Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

moved user event handling into UI/Callbacks.hs

Browse Source
This commit is contained in:
tpajenka 2014-05-01 20:31:15 +02:00
parent a3fe5a1d8b
commit 5be37f6453
5 changed files with 159 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
src/Main.hs
View File

@ -322,81 +322,18 @@ processEvents = do
processEvent :: Event -> Pioneers ()
processEvent e = do
env <- ask
case eventData e of
Window _ winEvent ->
eventCallback e
-- env <- ask
case SDL.eventData e of
SDL.Window _ winEvent -> -- windowID event
case winEvent of
Closing ->
SDL.Closing ->
modify $ window.shouldClose .~ True
Resized {windowResizedTo=size} -> do
modify $ (window . width .~ sizeWidth size)
. (window . height .~ sizeHeight size)
SDL.Resized {windowResizedTo=size} -> do
modify $ (window . width .~ SDL.sizeWidth size)
. (window . height .~ SDL.sizeHeight size)
adjustWindow
SizeChanged ->
SDL.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 ->
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]
_ -> return ()
_ -> return ()

98
src/UI/Callbacks.hs
View File

@ -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

4
src/UI/UIBaseData.hs
View File

@ -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 ***"

86
src/UI/UIClasses.hs
View File

@ -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
isInside :: Pixel -- ^screen position
-> uiw -- ^the parent widget
-> m Bool
isInside x' y' wg = do
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
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)
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

18
src/UI/UIOperations.hs
View File

@ -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