From 9523e733c6678232eab9193f25c4d3c933457efe Mon Sep 17 00:00:00 2001 From: tpajenka Date: Wed, 21 May 2014 14:10:47 +0200 Subject: [PATCH] new UI-Widget type: Viewport, removed old hacked code (except mouse wheel) to handle camera movement and using viewport instead --- src/Main.hs | 3 +-- src/Types.hs | 3 +-- src/UI/Callbacks.hs | 41 +++++++++-------------------------------- src/UI/UIBase.hs | 44 +++++++++++++++++++++++++++++++++++++++++--- src/UI/UIWidgets.hs | 41 ++++++++++++++++++++++++++++++++++++++--- 5 files changed, 90 insertions(+), 42 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 3f5c5bc..49b6463 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -133,8 +133,7 @@ main = , _tessClockFactor = 0 } , _mouse = MouseState - { _isDown = False - , _isDragging = False + { _isDragging = False , _dragStartX = 0 , _dragStartY = 0 , _dragStartXAngle = 0 diff --git a/src/Types.hs b/src/Types.hs index 3ea670e..d572db8 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -60,8 +60,7 @@ data GameState = GameState } data MouseState = MouseState - { _isDown :: !Bool - , _isDragging :: !Bool + { _isDragging :: !Bool , _dragStartX :: !Double , _dragStartY :: !Double , _dragStartXAngle :: !Double diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 4008e02..e953e24 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -8,7 +8,7 @@ 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.List (foldl') import Data.Maybe import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) @@ -22,7 +22,7 @@ import UI.UIOperations -- TODO: define GUI positions in a file createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId]) -createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0) +createGUI = (Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize , (UIId 1, createContainer (30, 215, 100, 80) [] 1) , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3) , (UIId 3, createContainer (80, 15, 130, 90) [] 4 ) @@ -101,38 +101,14 @@ eventCallback e = do _ -> return () SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel - do - state <- get - if state ^. mouse.isDown && not (state ^. mouse.isDragging) - then - modify $ (mouse.isDragging .~ True) - . (mouse.dragStartX .~ fromIntegral x) - . (mouse.dragStartY .~ fromIntegral y) - . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) - . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) - else mouseMoveHandler (x, y) - modify $ (mouse.mousePosition. Types._x .~ fromIntegral x) - . (mouse.mousePosition. Types._y .~ fromIntegral y) + mouseMoveHandler (x, y) SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt - do - case button of - SDL.LeftButton -> do - let pressed = state == SDL.Pressed - modify $ mouse.isDown .~ pressed - if pressed - then mouseReleaseHandler LeftButton (x, y) - else do - st <- get - if st ^. mouse.isDragging then - modify $ mouse.isDragging .~ False - else do - mousePressHandler LeftButton (x, y) - _ -> case state of - SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button - SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button - _ -> return () + case state of + SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button + SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button + _ -> return () SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll - do + do -- TODO: MouseWheelHandler state <- get let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist' @@ -295,6 +271,7 @@ copyGUI tex (vX, vY) widget = do --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. color = case widget ^. baseProperties.shorthand of + "VWP" -> [0,128,128,30] "CNT" -> [255,0,0,128] "BTN" -> [255,255,0,255] "PNL" -> [128,128,128,128] diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 5424900..9453c7f 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -4,7 +4,7 @@ module UI.UIBase where import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses) -import Control.Monad (liftM) +import Control.Monad (join,liftM) import Data.Array import Data.Bits (xor) import Data.Hashable @@ -157,7 +157,7 @@ data EventHandler m = -- widget’s extent ('isInside') or when the mouse is inside the -- widget’s extent while another button loses its mouse-active state. -- - -- The function returns the altered widget resulting from the button press + -- The function returns the altered widget resulting from the button press. _onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseLeave' is invoked when the mouse leaves the @@ -239,7 +239,45 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta False (0, 0) {-# INLINE initialMouseState #-} --- TODO: combined mouse handler +-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions +-- of two handlers. Thereby, the resulting widget of the first handler is the input widget of the +-- second handler and all other parameters are the same for both function calls. +-- +-- If not both input handlers are of type @MouseHandler@ an error is raised. +combinedMouseHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m +combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) = + MouseHandler (comb p1 p2) (comb r1 r2) + where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside +combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two EventHandler" ++ + " with constructor MouseHandler" + +-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action +-- functions of two handlers. Thereby, the resulting widget of the second handler is the input +-- widget of the second handler and all other parameters are the same for both function calls. +-- +-- If not both input handlers are of type @MouseMotionHandler@ an error is raised. +combinedMouseMotionHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m +combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) = + MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2) + where comb h1 h2 px = join . liftM (h2 px) . h1 px +combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two EventHandler" ++ + " with constructor MouseMotionHandler" + +-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing. +-- It may be useful as construction kit. +-- +-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction +-- >>> emptyMouseHandler { _onMousePress = myPressFunction } +emptyMouseHandler :: (Monad m) => EventHandler m +emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return) + +-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing. +-- It may be useful as construction kit. +-- +-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction +-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction } +emptyMouseMotionHandler :: (Monad m) => EventHandler m +emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return) -- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export -- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present, diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index 4226e56..64c954f 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -2,10 +2,10 @@ module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where -import Control.Lens ((^.), (.~), (&)) +import Control.Lens ((^.), (.~), (%~), (&)) import Control.Monad ---import Control.Monad.IO.Class -- MonadIO -import Control.Monad.RWS.Strict (get) +-- import Control.Monad.IO.Class (liftIO) +import Control.Monad.RWS.Strict (get, modify) import Data.List import Data.Maybe import qualified Data.HashMap.Strict as Map @@ -43,3 +43,38 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN") emptyGraphics (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers + +createViewport :: MouseButton -- ^ button to drag with + -> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers +createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") + emptyGraphics + Map.empty -- widget states + (Map.fromList [(MouseEvent, viewportMouseAction) + ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers + where + viewportMouseAction :: EventHandler Pioneers + viewportMouseAction = + let press btn' (x, y) _ w = + do when (btn == btn') $ do + state <- get + modify $ mouse %~ (isDragging .~ True) + . (dragStartX .~ fromIntegral x) + . (dragStartY .~ fromIntegral y) + . (dragStartXAngle .~ (state ^. camera.xAngle)) + . (dragStartYAngle .~ (state ^. camera.yAngle)) + . (mousePosition.Types._x .~ fromIntegral x) + . (mousePosition.Types._y .~ fromIntegral y) + return w + release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False) + return w + in MouseHandler press release + + viewportMouseMotionAction :: EventHandler Pioneers + viewportMouseMotionAction = + let move (x, y) w = + do state <- get + when (state ^. mouse.isDragging) $ + modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x) + . (mousePosition.Types._y .~ fromIntegral y) + return w + in emptyMouseMotionHandler & onMouseMove .~ move \ No newline at end of file