From e292633ce487c7096078f20cc518acd404a4a8a9 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sat, 3 May 2014 22:40:49 +0200 Subject: [PATCH] widget coordinates are now local (offset based on parent component) --- src/UI/Callbacks.hs | 36 +++++++++++++++++++----------------- src/UI/UIBase.hs | 26 +++++++++++++++++++++++++- src/UI/UIOperations.hs | 38 +++++++------------------------------- src/UI/UIWidgets.hs | 10 ++-------- 4 files changed, 53 insertions(+), 57 deletions(-) diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 7d71021..aa02b9d 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -19,13 +19,13 @@ import Types import UI.UIWidgets 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) - , (UIId 1, createContainer (20, 50, 120, 80) [] 1) - , (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3) - , (UIId 3, createContainer (100, 140, 130, 200) [] 4 ) - , (UIId 4, createButton (30, 200, 60, 175) 2 testMessage) + , (UIId 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 ) + , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage) ], [UIId 0]) getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers] @@ -89,12 +89,12 @@ eventCallback e = do modify $ aks.down .~ (movement == SDL.KeyDown) SDL.KeypadPlus -> when (movement == SDL.KeyDown) $ do - modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1)) + 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))) + modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1)) state <- get liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] _ -> @@ -104,13 +104,13 @@ eventCallback e = do state <- get when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ modify $ (mouse.isDragging .~ True) - . (mouse.dragStartX .~ (fromIntegral x)) - . (mouse.dragStartY .~ (fromIntegral y)) + . (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)) + 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 @@ -122,7 +122,7 @@ eventCallback e = do modify $ mouse.isDragging .~ False else clickHandler LeftButton (x, y) - _ -> do when (state == SDL.Released) + _ -> when (state == SDL.Released) $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll do @@ -181,12 +181,14 @@ prepareGUI = do liftIO $ do -- bind texture - all later calls work on this one. GL.textureBinding GL.Texture2D GL.$= Just tex - mapM_ (copyGUI tex) roots + mapM_ (copyGUI tex (0, 0)) roots modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers () -copyGUI tex widget = do +copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset + -> GUIWidget Pioneers -- ^the widget to draw + -> Pioneers () +copyGUI tex (vX, vY) widget = do (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary state <- get let @@ -205,11 +207,11 @@ copyGUI tex widget = do GL.texSubImage2D GL.Texture2D 0 - (GL.TexturePosition2D (int xoff) (int yoff)) + (GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff))) (GL.TextureSize2D (int wWidth) (int wHeight)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr) nextChildrenIds <- widget ^. baseProperties.children - mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds + mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. --TODO: Maybe queues are better? \ No newline at end of file diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 0ba8094..ed2ea37 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -17,6 +17,31 @@ type ScreenUnit = Int -- | @x@ and @y@ position on screen. type Pixel = (ScreenUnit, ScreenUnit) +-- |Combines two tuples element-wise. Designed for use with 'Pixel'. +merge :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) +merge f (x, y) (x', y') = (f x x', f y y') +{-# INLINABLE merge #-} + +-- |Maps the over the elements of a tuple. Designed for use with 'Pixel'. +(>:) :: (a -> b) -> (a, a) -> (b, b) +f >: (x, y) = (f x, f y) +{-# INLINABLE (>:) #-} + +-- |Adds two numeric tuples component-wise. +(+:) :: (Num a) => (a, a) -> (a, a) -> (a, a) +(+:) = merge (+) +{-# INLINABLE (+:) #-} + +-- |Calculates the component-wise difference between two tuples. +(-:) :: (Num a) => (a, a) -> (a, a) -> (a, a) +(-:) = merge (-) +{-# INLINABLE (-:) #-} + +-- |Multiplies two numeric tuples component-wise. +(*:) :: (Num a) => (a, a) -> (a, a) -> (a, a) +(*:) = merge (*) +{-# INLINABLE (*:) #-} + newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read) data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2 @@ -229,4 +254,3 @@ debugShowWidget' (Widget base mouse _) = do let short = base ^. shorthand return $ concat [short,"| boundary:", show bnd, ", children:", show chld, ",priority:",show prio, maybe "" (const ", with mouse handler") mouse] - diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 940c3e9..eafb1b5 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -8,41 +8,18 @@ import Data.Maybe import Types import UI.UIBase +-- TODO: test GUI function to scan for overlapping widgets + toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m) -{-# INLINE toGUIAny #-} +{-# INLINABLE toGUIAny #-} toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m] toGUIAnys m = mapMaybe (`Map.lookup` m) -{-# INLINE toGUIAnys #-} +{-# INLINABLE toGUIAnys #-} -- TODO: check for missing components? --- |The function 'getInside' returns child widgets that overlap with a specific --- screen position. --- --- A screen position may be inside the bounding box of a widget but not --- considered part of the component. The function returns all hit widgets that --- have no hit children, which may be the input widget itself, --- or @[]@ if the point does not hit the widget. --- --- This function returns the widgets themselves unlike 'getInsideId'. -getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets - -> Pixel -- ^screen position - -> GUIWidget Pioneers -- ^the parent widget - -> Pioneers [GUIWidget Pioneers] -getInside hMap px wg = do - inside <- (wg ^. baseProperties.isInside) wg px - if inside -- test inside parent's bounding box - then do - childrenIds <- wg ^. baseProperties.children - hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds) - case hitChildren of - [] -> return [wg] - _ -> return hitChildren - else return [] ---TODO: Priority queue? - -- |The function 'getInsideId' returns child widgets that overlap with a -- specific screen position. -- @@ -50,19 +27,18 @@ getInside hMap px wg = do -- considered part of the component. The function returns all hit widgets that -- have no hit children, which may be the input widget itself, -- or @[]@ if the point does not hit the widget. --- --- This function returns the 'UIId's of the widgets unlike 'getInside'. getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets -> Pixel -- ^screen position -> UIId -- ^the parent widget -> Pioneers [UIId] getInsideId hMap px uid = do let wg = toGUIAny hMap uid - inside <- (wg ^. baseProperties.isInside) wg px + bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary + inside <- liftM (isInsideRect bnd px &&) $ (wg ^. baseProperties.isInside) wg px if inside -- test inside parent's bounding box then do childrenIds <- wg ^. baseProperties.children - hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds + hitChildren <- liftM concat $ mapM (getInsideId hMap (px -: (bX, bY))) childrenIds case hitChildren of [] -> return [uid] _ -> return hitChildren diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index a2ae296..7f19dba 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -29,17 +29,11 @@ createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & bounda autosize' = do state <- get let hmap = state ^. ui . uiMap - -- TODO: local coordinates determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) - determineSize' (x, y, w, h) (x', y', w', h') = - let x'' = if x' < x then x' else x - y'' = if y' < y then y' else y - w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x'' - h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y'' - in (x'', y'', w'', h'') + determineSize' (x, y, w, h) (x', y', w', h') = (x, y, max w (x' + w'), max h (y' + h')) case chld of [] -> return bnd - cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs + cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m