diff --git a/src/Main.hs b/src/Main.hs index a361524..d8b23b7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -103,6 +103,7 @@ main = far = 500 --far plane ratio = fromIntegral fbWidth / fromIntegral fbHeight frust = createFrustum fov near far ratio + (guiMap, guiRoots) = createGUI aks = ArrowKeyState { _up = False , _down = False @@ -174,6 +175,8 @@ main = } , _ui = UIState { _uiHasChanged = True + , _uiMap = guiMap + , _uiRoots = guiRoots } } diff --git a/src/Types.hs b/src/Types.hs index a251151..451c094 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -115,6 +115,7 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool , _uiMap :: Map.HashMap UIId (GUIAny Pioneers) + , _uiRoots :: [UIId] } data State = State diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 1e7f23b..bf01360 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -2,53 +2,85 @@ module UI.Callbacks where -import Control.Monad.Trans (liftIO) + +import qualified Graphics.Rendering.OpenGL.GL as GL +import Control.Lens ((^.), (.~)) +import Control.Monad (liftM) +import Control.Monad.RWS.Strict (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 Render.Misc (genColorData) + import Types import UI.UIBaseData import UI.UIClasses import UI.UIOperations -import qualified Graphics.Rendering.OpenGL.GL as GL -import Control.Lens ((^.), (.~), (%~)) -import Render.Misc (genColorData) -import Foreign.Marshal.Array (pokeArray) -import Foreign.Marshal.Alloc (allocaBytes) -import Control.Monad.RWS.Strict (get, liftIO, modify) - data Pixel = Pixel Int Int -getGUI :: [GUIAny] -getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1 - , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0 - [toGUIAny $ GUIContainer 0 80 100 200 [] 4 - ,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage - ] 3 - ] +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) + , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3) + , (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 ) + , (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage)) + ], [UIId 0]) + +getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers] +getGUI hmap = Map.elems hmap -testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w +getRootIds :: Pioneers [UIId] +getRootIds = do + state <- get + return $ state ^. ui.uiRoots + +getRoots :: Pioneers [GUIAny Pioneers] +getRoots = do + state <- get + rootIds <- getRootIds + let hMap = state ^. ui.uiMap + return $ toGUIAnys hMap rootIds + +testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w testMessage w x y = do - putStrLn ("\tclick on " ++ show x ++ "," ++ show y) - return w + liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y) + return w -- | 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) = case concatMap (isInside x y) getGUI of - [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] - hit -> liftIO $ do - _ <- sequence $ map (\w -> - case w of - (GUIAnyB b h) -> do - putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) - ++ " at ["++show x++","++show y++"]" - (b', h') <- onMousePressed x y b h - _ <- onMouseReleased x y b' h' - return () - _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w) - ++ " at ["++show x++","++show y++"]" - ) hit - return () +clickHandler (Pixel x y) = do + state <- get + let hMap = state ^. ui.uiMap + roots <- getRootIds + hits <- liftM concat $ mapM (getInsideId hMap x y) roots + case hits of + [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"] + _ -> do + changes <- sequence $ map (\uid -> do + let w = toGUIAny hMap uid + short <- getShorthand w + bound <- getBoundary w + prio <- getPriority w + liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio + ++ " 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' + return $ Just (uid, GUIAnyB b'' h'') + _ -> return Nothing + ) $ hits + let newMap :: Map.HashMap UIId (GUIAny Pioneers) + newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes + modify $ ui.uiMap .~ newMap + return () + -- | Handler for UI-Inputs. @@ -69,36 +101,40 @@ alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate pres prepareGUI :: Pioneers () prepareGUI = do state <- get + roots <- getRoots let tex = (state ^. gl.glHud.hudTexture) liftIO $ do -- bind texture - all later calls work on this one. GL.textureBinding GL.Texture2D GL.$= Just tex - mapM_ (copyGUI tex) getGUI + mapM_ (copyGUI tex) roots modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> GUIAny -> IO () +copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers () copyGUI tex widget = do - let (xoff, yoff, width, height) = getBoundary widget + (xoff, yoff, wWidth, wHeight) <- getBoundary widget + state <- get + let + hMap = state ^. ui.uiMap int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ... --temporary color here. lateron better some getData-function to --get a list of pixel-data or a texture. color = case widget of (GUIAnyC _) -> [255,0,0,128] (GUIAnyB _ _) -> [255,255,0,255] - (GUIAnyP _) -> [128,128,128,255] + (GUIAnyP _) -> [128,128,128,128] _ -> [255,0,255,255] - allocaBytes (width*height*4) $ \ptr -> do + liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do --copy data into C-Array - pokeArray ptr (genColorData (width*height) color) + pokeArray ptr (genColorData (wWidth*wHeight) color) GL.texSubImage2D GL.Texture2D 0 (GL.TexturePosition2D (int xoff) (int yoff)) - (GL.TextureSize2D (int width) (int height)) + (GL.TextureSize2D (int wWidth) (int wHeight)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr) - mapM_ (copyGUI tex) (getChildren widget) -copyGUI _ _ = return () + nextChildrenIds <- getChildren widget + mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. ---TODO: Maybe queues are better? +--TODO: Maybe queues are better? \ No newline at end of file diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index de7f78f..d4b3399 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -9,7 +9,7 @@ import Data.Ix type ScreenUnit = Int -newtype UIId = UId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) +newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) -- |The state of a clickable ui widget. data UIButtonState = UIButtonState @@ -35,7 +35,7 @@ data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show) data ButtonHandler m w = ButtonHandler { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) } instance Show (ButtonHandler m w) where - show _ = "ButtonHandler ***" + show _ = "ButtonHandler ***" -- |A collection data type that may hold any usable ui element. @m@ is a monad. data GUIAny m = GUIAnyC GUIContainer @@ -64,10 +64,10 @@ data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUni , _uiButtonState :: UIButtonState } deriving () instance Show GUIButton where - show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w) - ++ " _screenYB = " ++ show (_uiScreenYB w) - ++ " _widthB = " ++ show (_uiWidthB w) - ++ " _heightB = " ++ show (_uiHeightB w) - ++ " _priorityB = " ++ show (_uiScreenYB w) - ++ " _buttonState = " ++ show (_uiButtonState w) - ++ "}" + show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w) + ++ " _screenYB = " ++ show (_uiScreenYB w) + ++ " _widthB = " ++ show (_uiWidthB w) + ++ " _heightB = " ++ show (_uiHeightB w) + ++ " _priorityB = " ++ show (_uiScreenYB w) + ++ " _buttonState = " ++ show (_uiButtonState w) + ++ "}" diff --git a/src/UI/UIClasses.hs b/src/UI/UIClasses.hs index 09bc982..377e463 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIClasses.hs @@ -27,17 +27,17 @@ class (Monad m) => GUIWidget m uiw where getChildren :: uiw -> m [UIId] getChildren _ = return [] - -- |The function 'isInsideSelf' tests whether a point is inside the widget itself. + -- |The function 'isInside' tests whether a point is inside the widget itself. -- A screen position may be inside the bounding box of a widget but not considered part of the -- component. -- -- The default implementations tests if the point is within the rectangle specified by the -- 'getBoundary' function. - isInsideSelf :: ScreenUnit -- ^screen x coordinate + isInside :: ScreenUnit -- ^screen x coordinate -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget -> m Bool - isInsideSelf 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) @@ -193,9 +193,9 @@ instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where getChildren (GUIAnyC w) = getChildren w getChildren (GUIAnyP w) = getChildren w getChildren (GUIAnyB w _) = getChildren w - isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w - isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w - isInsideSelf x y (GUIAnyB w _) = (isInsideSelf x y) 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 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 a7b95a7..a6085d0 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -1,26 +1,79 @@ module UI.UIOperations where +import Control.Monad (liftM) import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Types import UI.UIBaseData import UI.UIClasses defaultUIState :: UIButtonState defaultUIState = UIButtonState False False False False False False ---TODO --- |The function 'isInside' tests whether a point is inside the widget or any child. --- 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 or 'Nothing' if the point neither hits any --- component nor the parent widget itself. -isInside :: ScreenUnit -- ^screen x coordinate - -> ScreenUnit -- ^screen y coordinate - -> UIId -- ^the parent widget - -> [UIId] -isInside x' y' wg = - case isInsideSelf x' y' wg of -- test inside parent's bounding box - False -> [] - True -> case concat $ map (isInside x' y') (getChildren wg) of - [] -> [toGUIAny wg] - l -> l +toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m +toGUIAny m uid = case Map.lookup uid m of + Just w -> w + Nothing -> error "map does not contain requested key" --TODO: better error handling +{-# INLINE toGUIAny #-} + +toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m] +toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids +{-# INLINE 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 (GUIAny Pioneers) -- ^map containing ui widgets + -> ScreenUnit -- ^screen x coordinate + -> ScreenUnit -- ^screen y coordinate + -> GUIAny Pioneers -- ^the parent widget + -> Pioneers [GUIAny Pioneers] +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) + 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. +-- +-- 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 '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 + -> UIId -- ^the parent widget + -> Pioneers [UIId] +getInsideId hMap x' y' uid = do + let wg = toGUIAny hMap uid + 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 + case hitChildren of + [] -> return [uid] + _ -> return hitChildren + else return [] +--TODO: Priority queue? + +