finished storing ui widgets into a HashMap and referencing them by UIId.

Additionally, widgets functions now use the Pioneers monad.
Branch is compiling again and works.

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

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

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]
+createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
-getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1
+createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
-         , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0
+                          , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
-             [toGUIAny $ GUIContainer  0 80 100 200 [] 4
+                          , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
-             ,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage
+                          , (UIId 3, GUIAnyC $ GUIContainer  100 140 130 200 [] 4 )
-             ] 3
+                          , (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)
+  liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
-    return w
+  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
+clickHandler (Pixel x y) = do
-    [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
+  state <- get
-    hit -> liftIO $ do
+  let hMap = state ^. ui.uiMap
-        _ <- sequence $ map (\w ->
+  roots <- getRootIds
-            case w of
+  hits <- liftM concat $ mapM (getInsideId hMap x y) roots
-                 (GUIAnyB b h) -> do
+  case hits of
-                      putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
+       [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
-                          ++ " at ["++show x++","++show y++"]"
+       _  -> do
-                      (b', h') <- onMousePressed x y b h
+         changes <- sequence $ map (\uid -> do
-                      _ <- onMouseReleased x y b' h'
+           let w = toGUIAny hMap uid
-                      return ()
+           short <- getShorthand w
-                 _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
+           bound <- getBoundary w
-                          ++ " at ["++show x++","++show y++"]"
+           prio <- getPriority w
-            ) hit
+           liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
-        return ()
+                            ++ " 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)
+                        nextChildrenIds <- getChildren widget
-copyGUI _ _ = return ()
+                        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?

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)
+  show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w)
-                    ++ " _screenYB = " ++ show (_uiScreenYB w)
+        ++ " _screenYB = " ++ show (_uiScreenYB w)
-                    ++ " _widthB = " ++ show (_uiWidthB w)
+        ++ " _widthB = " ++ show (_uiWidthB w)
-                    ++ " _heightB = " ++ show (_uiHeightB w)
+        ++ " _heightB = " ++ show (_uiHeightB w)
-                    ++ " _priorityB = " ++ show (_uiScreenYB w)
+        ++ " _priorityB = " ++ show (_uiScreenYB w)
-                    ++ " _buttonState = " ++ show (_uiButtonState w)
+        ++ " _buttonState = " ++ show (_uiButtonState w)
-                    ++ "}"
+        ++ "}"

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
+    isInside x y (GUIAnyC w) = (isInside x y) w
-    isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w
+    isInside x y (GUIAnyP w) = (isInside x y) w
-    isInsideSelf x y (GUIAnyB w _) = (isInsideSelf 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

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
+toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m
--- |The function 'isInside' tests whether a point is inside the widget or any child.
+toGUIAny m uid = case Map.lookup uid m of
---  A screen position may be inside the bounding box of a widget but not considered part of the component.
+                     Just w  -> w
---  The function returns all hit widgets that have no hit children or 'Nothing' if the point neither hits any
+                     Nothing -> error "map does not contain requested key" --TODO: better error handling
---  component nor the parent widget itself.
+{-# INLINE toGUIAny #-}
-isInside :: ScreenUnit -- ^screen x coordinate
+
-         -> ScreenUnit -- ^screen y coordinate
+toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m]
-         -> UIId       -- ^the parent widget
+toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
-         -> [UIId]
+{-# INLINE toGUIAnys #-}
-isInside x' y' wg =
+-- TODO: check for missing components?
-    case isInsideSelf x' y' wg of -- test inside parent's bounding box
+
-        False -> []
+
-        True -> case concat $ map (isInside x' y') (getChildren wg) of
+-- |The function 'getInside' returns child widgets that overlap with a specific
-            [] -> [toGUIAny wg]
+--  screen position.
-            l  -> l
+--  
+--  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?
+
+