moved user event handling into UI/Callbacks.hs
This commit is contained in:
		
							
								
								
									
										101
									
								
								src/Main.hs
									
									
									
									
									
								
							
							
						
						
									
										101
									
								
								src/Main.hs
									
									
									
									
									
								
							@@ -55,11 +55,11 @@ import           Importer.IQM.Parser
 | 
				
			|||||||
testParser :: String -> IO ()
 | 
					testParser :: String -> IO ()
 | 
				
			||||||
testParser a = putStrLn . show  =<< parseIQM a
 | 
					testParser a = putStrLn . show  =<< parseIQM a
 | 
				
			||||||
{-do
 | 
					{-do
 | 
				
			||||||
		f <- B.readFile a
 | 
					        f <- B.readFile a
 | 
				
			||||||
		putStrLn "reading in:"
 | 
					        putStrLn "reading in:"
 | 
				
			||||||
		putStrLn $ show f
 | 
					        putStrLn $ show f
 | 
				
			||||||
		putStrLn "parsed:"
 | 
					        putStrLn "parsed:"
 | 
				
			||||||
		parseTest parseIQM f-}
 | 
					        parseTest parseIQM f-}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
--------------------------------------------------------------------------------
 | 
					--------------------------------------------------------------------------------
 | 
				
			||||||
 | 
					
 | 
				
			||||||
@@ -322,81 +322,18 @@ processEvents = do
 | 
				
			|||||||
 | 
					
 | 
				
			||||||
processEvent :: Event -> Pioneers ()
 | 
					processEvent :: Event -> Pioneers ()
 | 
				
			||||||
processEvent e = do
 | 
					processEvent e = do
 | 
				
			||||||
        env <- ask
 | 
					    eventCallback e
 | 
				
			||||||
        case eventData e of
 | 
					    -- env <- ask
 | 
				
			||||||
            Window _ winEvent ->
 | 
					    case SDL.eventData e of
 | 
				
			||||||
                case winEvent of
 | 
					         SDL.Window _ winEvent -> -- windowID event
 | 
				
			||||||
                    Closing ->
 | 
					            case winEvent of
 | 
				
			||||||
                            modify $ window.shouldClose .~ True
 | 
					                SDL.Closing ->
 | 
				
			||||||
                    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   ->
 | 
					 | 
				
			||||||
                        modify $ window.shouldClose .~ True
 | 
					                        modify $ window.shouldClose .~ True
 | 
				
			||||||
                    SDL.Left  ->
 | 
					                SDL.Resized {windowResizedTo=size} -> do
 | 
				
			||||||
                        modify $ aks.left  .~ (movement == KeyDown)
 | 
					                        modify $ (window . width .~ SDL.sizeWidth size)
 | 
				
			||||||
                    SDL.Right ->
 | 
					                               . (window . height .~ SDL.sizeHeight size)
 | 
				
			||||||
                        modify $ aks.right .~ (movement == KeyDown)
 | 
					                        adjustWindow
 | 
				
			||||||
                    SDL.Up    ->
 | 
					                SDL.SizeChanged ->
 | 
				
			||||||
                        modify $ aks.up    .~ (movement == KeyDown)
 | 
					                        adjustWindow
 | 
				
			||||||
                    SDL.Down  ->
 | 
					                _ -> return ()
 | 
				
			||||||
                        modify $ aks.down  .~ (movement == KeyDown)
 | 
					         _ -> return ()
 | 
				
			||||||
                    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]
 | 
					 | 
				
			||||||
 
 | 
				
			|||||||
@@ -2,25 +2,25 @@ module UI.Callbacks where
 | 
				
			|||||||
 | 
					
 | 
				
			||||||
 | 
					
 | 
				
			||||||
import qualified Graphics.Rendering.OpenGL.GL         as GL
 | 
					import qualified Graphics.Rendering.OpenGL.GL         as GL
 | 
				
			||||||
import           Control.Lens                         ((^.), (.~))
 | 
					import           Control.Lens                         ((^.), (.~), (%~))
 | 
				
			||||||
import           Control.Monad                        (liftM)
 | 
					import           Control.Monad                        (liftM, when, unless)
 | 
				
			||||||
import           Control.Monad.RWS.Strict             (get, modify)
 | 
					import           Control.Monad.RWS.Strict             (ask, get, modify)
 | 
				
			||||||
import           Control.Monad.Trans                  (liftIO)
 | 
					import           Control.Monad.Trans                  (liftIO)
 | 
				
			||||||
import qualified Data.HashMap.Strict                  as Map
 | 
					import qualified Data.HashMap.Strict                  as Map
 | 
				
			||||||
import           Data.List                            (foldl')
 | 
					import           Data.List                            (foldl')
 | 
				
			||||||
import           Data.Maybe
 | 
					import           Data.Maybe
 | 
				
			||||||
import           Foreign.Marshal.Array (pokeArray)
 | 
					import           Foreign.Marshal.Array (pokeArray)
 | 
				
			||||||
import           Foreign.Marshal.Alloc (allocaBytes)
 | 
					import           Foreign.Marshal.Alloc (allocaBytes)
 | 
				
			||||||
 | 
					import qualified Graphics.UI.SDL                      as SDL
 | 
				
			||||||
import           Render.Misc                          (genColorData)
 | 
					import           Render.Misc                          (genColorData)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
import Types
 | 
					import Types
 | 
				
			||||||
 | 
					import Render.Misc                                    (curb)
 | 
				
			||||||
import UI.UIBaseData
 | 
					import UI.UIBaseData
 | 
				
			||||||
import UI.UIClasses
 | 
					import UI.UIClasses
 | 
				
			||||||
import UI.UIOperations
 | 
					import UI.UIOperations
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					
 | 
				
			||||||
data Pixel = Pixel Int Int
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
 | 
					createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
 | 
				
			||||||
createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
 | 
					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 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
 | 
				
			||||||
@@ -45,19 +45,93 @@ getRoots = do
 | 
				
			|||||||
  let hMap = state ^. ui.uiMap
 | 
					  let hMap = state ^. ui.uiMap
 | 
				
			||||||
  return $ toGUIAnys hMap rootIds
 | 
					  return $ toGUIAnys hMap rootIds
 | 
				
			||||||
 | 
					
 | 
				
			||||||
testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w
 | 
					testMessage :: w -> Pixel -> Pioneers w
 | 
				
			||||||
testMessage w x y = do
 | 
					testMessage w (x, y) = do
 | 
				
			||||||
  liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
 | 
					  liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
 | 
				
			||||||
  return w
 | 
					  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.
 | 
					-- | Handler for UI-Inputs.
 | 
				
			||||||
--   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
 | 
					--   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
 | 
				
			||||||
clickHandler :: Pixel -> Pioneers ()
 | 
					clickHandler :: Pixel -> Pioneers ()
 | 
				
			||||||
clickHandler (Pixel x y) = do
 | 
					clickHandler pos@(x,y) = do
 | 
				
			||||||
  state <- get
 | 
					  state <- get
 | 
				
			||||||
  let hMap = state ^. ui.uiMap
 | 
					  let hMap = state ^. ui.uiMap
 | 
				
			||||||
  roots <- getRootIds
 | 
					  roots <- getRootIds
 | 
				
			||||||
  hits <- liftM concat $ mapM (getInsideId hMap x y) roots
 | 
					  hits <- liftM concat $ mapM (getInsideId hMap pos) roots
 | 
				
			||||||
  case hits of
 | 
					  case hits of
 | 
				
			||||||
       [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
 | 
					       [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
 | 
				
			||||||
       _  -> do
 | 
					       _  -> do
 | 
				
			||||||
@@ -70,8 +144,8 @@ clickHandler (Pixel x y) = do
 | 
				
			|||||||
                            ++ " at [" ++ show x ++ "," ++ show y ++ "]"
 | 
					                            ++ " at [" ++ show x ++ "," ++ show y ++ "]"
 | 
				
			||||||
           case w of
 | 
					           case w of
 | 
				
			||||||
                (GUIAnyB b h) -> do
 | 
					                (GUIAnyB b h) -> do
 | 
				
			||||||
                    (b', h') <- onMousePressed x y b h
 | 
					                    (b', h') <- onMousePressed pos b h
 | 
				
			||||||
                    (b'', h'') <- onMouseReleased x y b' h'
 | 
					                    (b'', h'') <- onMouseReleased pos b' h'
 | 
				
			||||||
                    return $ Just (uid, GUIAnyB b'' h'')
 | 
					                    return $ Just (uid, GUIAnyB b'' h'')
 | 
				
			||||||
                _ -> return Nothing
 | 
					                _ -> return Nothing
 | 
				
			||||||
           ) $ hits
 | 
					           ) $ hits
 | 
				
			||||||
@@ -85,7 +159,7 @@ clickHandler (Pixel x y) = do
 | 
				
			|||||||
-- | Handler for UI-Inputs.
 | 
					-- | Handler for UI-Inputs.
 | 
				
			||||||
--   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
 | 
					--   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
 | 
				
			||||||
alternateClickHandler :: Pixel -> Pioneers ()
 | 
					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
 | 
					-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
 | 
				
			||||||
 
 | 
				
			|||||||
@@ -9,6 +9,8 @@ import Data.Ix
 | 
				
			|||||||
-- |Unit of screen/window
 | 
					-- |Unit of screen/window
 | 
				
			||||||
type ScreenUnit = Int
 | 
					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,Show,Read,Bounded,Ix,Hashable)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
@@ -34,7 +36,7 @@ data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
 | 
				
			|||||||
 | 
					
 | 
				
			||||||
-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
 | 
					-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
 | 
				
			||||||
data ButtonHandler m w = ButtonHandler 
 | 
					data ButtonHandler m w = ButtonHandler 
 | 
				
			||||||
    { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) }
 | 
					    { _action :: (w -> Pixel -> m w) }
 | 
				
			||||||
instance Show (ButtonHandler m w) where
 | 
					instance Show (ButtonHandler m w) where
 | 
				
			||||||
  show _ = "ButtonHandler ***"
 | 
					  show _ = "ButtonHandler ***"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 
 | 
				
			|||||||
@@ -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 
 | 
					    --  The default implementations tests if the point is within the rectangle specified by the 
 | 
				
			||||||
    --  'getBoundary' function.
 | 
					    --  'getBoundary' function.
 | 
				
			||||||
    isInside :: ScreenUnit -- ^screen x coordinate
 | 
					    isInside :: Pixel  -- ^screen position
 | 
				
			||||||
                 -> ScreenUnit -- ^screen y coordinate
 | 
					             -> uiw    -- ^the parent widget
 | 
				
			||||||
                 -> uiw       -- ^the parent widget
 | 
					             -> m Bool
 | 
				
			||||||
                 -> m Bool
 | 
					    isInside (x',y') wg = do
 | 
				
			||||||
    isInside x' y' wg = do
 | 
					 | 
				
			||||||
        (x, y, w, h) <- getBoundary wg
 | 
					        (x, y, w, h) <- getBoundary wg
 | 
				
			||||||
        return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
 | 
					        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
 | 
					class Monad m => MouseHandler a m w where
 | 
				
			||||||
    -- |The function 'onMousePressed' is called when the primary button is pressed
 | 
					    -- |The function 'onMousePressed' is called when the primary button is pressed
 | 
				
			||||||
    --  while inside a screen coordinate within the widget ('isInside').
 | 
					    --  while inside a screen coordinate within the widget ('isInside').
 | 
				
			||||||
    onMousePressed :: ScreenUnit -- ^screen x coordinate 
 | 
					    onMousePressed :: Pixel -- ^screen position
 | 
				
			||||||
                   -> ScreenUnit -- ^screen y coordinate
 | 
					 | 
				
			||||||
                   -> w -- ^widget the event is invoked on
 | 
					                   -> w -- ^widget the event is invoked on
 | 
				
			||||||
                   -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
					                   -> 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
 | 
					    -- |The function 'onMouseReleased' is called when the primary button is released
 | 
				
			||||||
    --  while the pressing event occured within the widget ('isInside').
 | 
					    --  while the pressing event occured within the widget ('isInside').
 | 
				
			||||||
    --  
 | 
					    --  
 | 
				
			||||||
    --  Thus, the mouse is either within the widget or outside while still dragging.
 | 
					    --  Thus, the mouse is either within the widget or outside while still dragging.
 | 
				
			||||||
    onMouseReleased :: ScreenUnit -- ^screen x coordinate
 | 
					    onMouseReleased :: Pixel  -- ^screen position
 | 
				
			||||||
                    -> ScreenUnit  -- ^screen x coordinate
 | 
					 | 
				
			||||||
                    -> w -- ^wdiget the event is invoked on
 | 
					                    -> w -- ^wdiget the event is invoked on
 | 
				
			||||||
                    -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
					                    -> 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
 | 
					    -- |The function 'onMousePressed' is called when the secondary button is pressed
 | 
				
			||||||
    --  while inside a screen coordinate within the widget ('isInside').
 | 
					    --  while inside a screen coordinate within the widget ('isInside').
 | 
				
			||||||
    onMousePressedAlt :: ScreenUnit -- ^screen x coordinate 
 | 
					    onMousePressedAlt :: Pixel  -- ^screen position
 | 
				
			||||||
                   -> ScreenUnit -- ^screen y coordinate
 | 
					                      -> w -- ^widget the event is invoked on
 | 
				
			||||||
                   -> w -- ^widget the event is invoked on
 | 
					                      -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
				
			||||||
                   -> 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
 | 
					    -- |The function 'onMouseReleased' is called when the secondary button is released
 | 
				
			||||||
    --  while the pressing event occured within the widget ('isInside').
 | 
					    --  while the pressing event occured within the widget ('isInside').
 | 
				
			||||||
    --  
 | 
					    --  
 | 
				
			||||||
    --  Thus, the mouse is either within the widget or outside while still dragging.
 | 
					    --  Thus, the mouse is either within the widget or outside while still dragging.
 | 
				
			||||||
    onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate
 | 
					    onMouseReleasedAlt :: Pixel  -- ^screen position
 | 
				
			||||||
                       -> ScreenUnit  -- ^screen x coordinate
 | 
					 | 
				
			||||||
                       -> w -- ^wdiget the event is invoked on
 | 
					                       -> w -- ^wdiget the event is invoked on
 | 
				
			||||||
                       -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
					                       -> 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
 | 
					    -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
 | 
				
			||||||
    --  widget's space ('isInside').
 | 
					    --  widget's space ('isInside').
 | 
				
			||||||
    onMouseMove :: ScreenUnit -- ^screen x coordinate
 | 
					    onMouseMove :: Pixel  -- ^screen position
 | 
				
			||||||
                -> ScreenUnit -- ^screen y coordinate
 | 
					 | 
				
			||||||
                -> w -- ^widget the event is invoked on
 | 
					                -> w -- ^widget the event is invoked on
 | 
				
			||||||
                -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
					                -> 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
 | 
					    -- |The function 'onMouseMove' is invoked when the mouse enters the
 | 
				
			||||||
    --  widget's space ('isInside').
 | 
					    --  widget's space ('isInside').
 | 
				
			||||||
    onMouseEnter :: ScreenUnit -- ^screen x coordinate
 | 
					    onMouseEnter :: Pixel  -- ^screen position
 | 
				
			||||||
                 -> ScreenUnit -- ^screen y coordinate
 | 
					 | 
				
			||||||
                 -> w -- ^widget the event is invoked on
 | 
					                 -> w -- ^widget the event is invoked on
 | 
				
			||||||
                 -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
					                 -> 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
 | 
					    -- |The function 'onMouseMove' is invoked when the mouse leaves the
 | 
				
			||||||
    --  widget's space ('isInside').
 | 
					    --  widget's space ('isInside').
 | 
				
			||||||
    onMouseLeave :: ScreenUnit -- ^screen x coordinate
 | 
					    onMouseLeave :: Pixel  -- ^screen position
 | 
				
			||||||
                 -> ScreenUnit -- ^screen y coordinate
 | 
					 | 
				
			||||||
                 -> w -- ^widget the event is invoked on
 | 
					                 -> w -- ^widget the event is invoked on
 | 
				
			||||||
                 -> a -> m (w, a) -- ^widget after the event and the altered handler
 | 
					                 -> 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
 | 
					instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where
 | 
				
			||||||
    onMousePressed x y w (MouseHandlerSwitch h) = do
 | 
					    onMousePressed p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMousePressedAlt x y w h
 | 
					        (w', h') <- onMousePressedAlt p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
    onMouseReleased x y w (MouseHandlerSwitch h) = do
 | 
					    onMouseReleased p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMouseReleasedAlt x y w h
 | 
					        (w', h') <- onMouseReleasedAlt p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
    onMousePressedAlt x y w (MouseHandlerSwitch h) = do
 | 
					    onMousePressedAlt p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMousePressed x y w h
 | 
					        (w', h') <- onMousePressed p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
    onMouseReleasedAlt x y w (MouseHandlerSwitch h) = do
 | 
					    onMouseReleasedAlt p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMouseReleased x y w h
 | 
					        (w', h') <- onMouseReleased p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
    onMouseMove x y w (MouseHandlerSwitch h) = do
 | 
					    onMouseMove p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMouseMove x y w h
 | 
					        (w', h') <- onMouseMove p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
    onMouseEnter x y w (MouseHandlerSwitch h) = do
 | 
					    onMouseEnter p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMouseEnter x y w h
 | 
					        (w', h') <- onMouseEnter p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
    onMouseLeave x y w (MouseHandlerSwitch h) = do
 | 
					    onMouseLeave p w (MouseHandlerSwitch h) = do
 | 
				
			||||||
        (w', h') <- onMouseLeave x y w h
 | 
					        (w', h') <- onMouseLeave p w h
 | 
				
			||||||
        return (w', MouseHandlerSwitch h')
 | 
					        return (w', MouseHandlerSwitch h')
 | 
				
			||||||
 | 
					
 | 
				
			||||||
instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
 | 
					instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
 | 
				
			||||||
    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
 | 
					    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
 | 
				
			||||||
    onMousePressed _ _ wg h =
 | 
					    onMousePressed _ wg h =
 | 
				
			||||||
        return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
 | 
					        return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
 | 
					    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
 | 
				
			||||||
    --  call 'action' if inside the widget or
 | 
					    --  call 'action' if inside the widget or
 | 
				
			||||||
    --  set '_buttonstateIsDeferred' to false otherwise.
 | 
					    --  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
 | 
					        then do
 | 
				
			||||||
            wg' <- action wg x y
 | 
					            wg' <- action wg p
 | 
				
			||||||
            return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h)
 | 
					            return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h)
 | 
				
			||||||
        else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h)
 | 
					        else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h)
 | 
				
			||||||
    
 | 
					    
 | 
				
			||||||
    -- |Do nothing.
 | 
					    -- |Do nothing.
 | 
				
			||||||
    onMouseMove _ _ wg h = return (wg, h)
 | 
					    onMouseMove _ wg h = return (wg, h)
 | 
				
			||||||
    
 | 
					    
 | 
				
			||||||
    -- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and
 | 
					    -- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and
 | 
				
			||||||
    --  update dragging state (only drag if inside widget).
 | 
					    --  update dragging state (only drag if inside widget).
 | 
				
			||||||
    --  In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value
 | 
					    --  In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value
 | 
				
			||||||
    --   and set '_buttonstateIsFiring' to @False@. 
 | 
					    --   and set '_buttonstateIsFiring' to @False@. 
 | 
				
			||||||
    onMouseEnter _ _ wg h = return
 | 
					    onMouseEnter _ wg h = return
 | 
				
			||||||
        (updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s
 | 
					        (updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s
 | 
				
			||||||
                                    , _buttonstateIsDeferred = False
 | 
					                                    , _buttonstateIsDeferred = False
 | 
				
			||||||
                                    , _buttonstateIsReady = True
 | 
					                                    , _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).
 | 
					    --  update dragging state (only drag if inside widget).
 | 
				
			||||||
    --  In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
 | 
					    --  In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
 | 
				
			||||||
    --  and set '_buttonstateIsDeferred's' to @False@.
 | 
					    --  and set '_buttonstateIsDeferred's' to @False@.
 | 
				
			||||||
    onMouseLeave _ _ wg h = return
 | 
					    onMouseLeave _ wg h = return
 | 
				
			||||||
        (updateButtonState (\s -> s { _buttonstateIsFiring = False
 | 
					        (updateButtonState (\s -> s { _buttonstateIsFiring = False
 | 
				
			||||||
                                    , _buttonstateIsDeferred = _buttonstateIsFiring s
 | 
					                                    , _buttonstateIsDeferred = _buttonstateIsFiring s
 | 
				
			||||||
                                    , _buttonstateIsReady = False
 | 
					                                    , _buttonstateIsReady = False
 | 
				
			||||||
@@ -193,9 +185,9 @@ instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
 | 
				
			|||||||
    getChildren (GUIAnyC w) = getChildren w
 | 
					    getChildren (GUIAnyC w) = getChildren w
 | 
				
			||||||
    getChildren (GUIAnyP w) = getChildren w
 | 
					    getChildren (GUIAnyP w) = getChildren w
 | 
				
			||||||
    getChildren (GUIAnyB w _) = getChildren w
 | 
					    getChildren (GUIAnyB w _) = getChildren w
 | 
				
			||||||
    isInside x y (GUIAnyC w) = (isInside x y) w
 | 
					    isInside p (GUIAnyC w) = (isInside p) w
 | 
				
			||||||
    isInside x y (GUIAnyP w) = (isInside x y) w
 | 
					    isInside p (GUIAnyP w) = (isInside p) w
 | 
				
			||||||
    isInside x y (GUIAnyB w _) = (isInside x y) w
 | 
					    isInside p (GUIAnyB w _) = (isInside p) w
 | 
				
			||||||
    getPriority (GUIAnyC w) = getPriority w
 | 
					    getPriority (GUIAnyC w) = getPriority w
 | 
				
			||||||
    getPriority (GUIAnyP w) = getPriority w
 | 
					    getPriority (GUIAnyP w) = getPriority w
 | 
				
			||||||
    getPriority (GUIAnyB w _) = getPriority w
 | 
					    getPriority (GUIAnyB w _) = getPriority w
 | 
				
			||||||
 
 | 
				
			|||||||
@@ -32,16 +32,15 @@ toGUIAnys m = mapMaybe (flip Map.lookup m)
 | 
				
			|||||||
--  
 | 
					--  
 | 
				
			||||||
--  This function returns the widgets themselves unlike 'getInsideId'.
 | 
					--  This function returns the widgets themselves unlike 'getInsideId'.
 | 
				
			||||||
getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
 | 
					getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
 | 
				
			||||||
             -> ScreenUnit -- ^screen x coordinate
 | 
					             -> Pixel  -- ^screen position
 | 
				
			||||||
             -> ScreenUnit -- ^screen y coordinate
 | 
					 | 
				
			||||||
             -> GUIAny Pioneers  -- ^the parent widget
 | 
					             -> GUIAny Pioneers  -- ^the parent widget
 | 
				
			||||||
             -> Pioneers [GUIAny Pioneers]
 | 
					             -> Pioneers [GUIAny Pioneers]
 | 
				
			||||||
getInside hMap x' y' wg = do
 | 
					getInside hMap (x',y') wg = do
 | 
				
			||||||
  inside <- isInside x' y' wg
 | 
					  inside <- isInside (x',y') wg
 | 
				
			||||||
  if inside -- test inside parent's bounding box
 | 
					  if inside -- test inside parent's bounding box
 | 
				
			||||||
  then do
 | 
					  then do
 | 
				
			||||||
       childrenIds <- getChildren wg
 | 
					       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
 | 
					       case hitChildren of
 | 
				
			||||||
            [] -> return [wg]
 | 
					            [] -> return [wg]
 | 
				
			||||||
            _ -> return hitChildren
 | 
					            _ -> return hitChildren
 | 
				
			||||||
@@ -58,17 +57,16 @@ getInside hMap x' y' wg = do
 | 
				
			|||||||
--  
 | 
					--  
 | 
				
			||||||
--  This function returns the 'UIId's of the widgets unlike 'getInside'.
 | 
					--  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 (GUIAny Pioneers) -- ^map containing ui widgets
 | 
				
			||||||
            -> ScreenUnit -- ^screen x coordinate
 | 
					            -> Pixel  -- ^screen position
 | 
				
			||||||
            -> ScreenUnit -- ^screen y coordinate
 | 
					 | 
				
			||||||
            -> UIId  -- ^the parent widget
 | 
					            -> UIId  -- ^the parent widget
 | 
				
			||||||
            -> Pioneers [UIId]
 | 
					            -> Pioneers [UIId]
 | 
				
			||||||
getInsideId hMap x' y' uid = do
 | 
					getInsideId hMap (x',y') uid = do
 | 
				
			||||||
  let wg = toGUIAny hMap uid
 | 
					  let wg = toGUIAny hMap uid
 | 
				
			||||||
  inside <- isInside x' y' wg
 | 
					  inside <- isInside (x',y') wg
 | 
				
			||||||
  if inside -- test inside parent's bounding box
 | 
					  if inside -- test inside parent's bounding box
 | 
				
			||||||
    then do
 | 
					    then do
 | 
				
			||||||
      childrenIds <- getChildren wg
 | 
					      childrenIds <- getChildren wg
 | 
				
			||||||
      hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds
 | 
					      hitChildren <- liftM concat $ mapM (getInsideId hMap (x',y')) childrenIds
 | 
				
			||||||
      case hitChildren of
 | 
					      case hitChildren of
 | 
				
			||||||
           [] -> return [uid]
 | 
					           [] -> return [uid]
 | 
				
			||||||
           _  -> return hitChildren
 | 
					           _  -> return hitChildren
 | 
				
			||||||
 
 | 
				
			|||||||
		Reference in New Issue
	
	Block a user