noise entfernt

deps/getDeps.sh

@@ -14,7 +14,7 @@ fi
 
 if [[ $install -eq 0 ]]
 then
-	sudo apt-get install libsdl2-dev libsdl2-ttf-dev
+	sudo apt-get install libsdl2-dev libsdl2-ttf-dev libsdl2-image-dev libsdl2-mixer-dev
 fi
 
 
@@ -38,6 +38,25 @@ else
 	cd ..
 fi
 
+if [ ! -d "hsSDL2-mixer" ]
+then
+	git clone https://github.com/jdeseno/hs-sdl2-mixer hsSDL2-mixer
+else
+	cd hsSDL2-mixer
+	git pull
+	cd ..
+fi
+
+if [ ! -d "hsSDL2-image" ]
+then
+	git clone https://github.com/jdeseno/hs-sdl2-image hsSDL2-image
+else
+	cd hsSDL2-image
+	git pull
+	cd ..
+fi
+
+
 echo "trying to build"
 
 cabal install haddock
@@ -51,7 +70,7 @@ cabal install --only-dependencies
 cabal build
 cd ..
 
-for t in "hsSDL2-ttf"
+for t in "hsSDL2-ttf" "hsSDL2-mixer" "hsSDL2-image"
 do
 	echo "building ${t}.."
 	cd "${t}"

shaders/map/tessEval.shader

@@ -133,7 +133,7 @@ void main()
     float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal));
     float standout = i0+i1+i2;
     tePosition = tePosition+tessNormal*standout;
-    vec3 tmp = tePosition+1*snoise(tePosition/20);
+    vec3 tmp = tePosition;//+clamp(tePosition,0,0.05)*snoise(tePosition/2);
     tePosition = vec3(tePosition.x, tmp.y, tePosition.z);
     gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1);
     fogDist = gl_Position.z;

src/Main.hs

@@ -336,81 +336,18 @@ processEvents = do
 
 processEvent :: Event -> Pioneers ()
 processEvent e = do
-        env <- ask
+    eventCallback e
-        case eventData e of
+    -- env <- ask
-            Window _ winEvent ->
+    case SDL.eventData e of
+         SDL.Window _ winEvent -> -- windowID event
             case winEvent of
-                    Closing ->
+                SDL.Closing ->
                         modify $ window.shouldClose .~ True
-                    Resized {windowResizedTo=size} -> do
+                SDL.Resized {windowResizedTo=size} -> do
-                            modify $ (window . width .~ sizeWidth size)
+                        modify $ (window . width .~ SDL.sizeWidth size)
-                                   . (window . height .~ sizeHeight size)
+                               . (window . height .~ SDL.sizeHeight size)
                         adjustWindow
-                    SizeChanged ->
+                SDL.SizeChanged ->
                         adjustWindow
-                    _ ->
+                _ -> return ()
-                        return ()
+         _ -> 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
-                    SDL.Left  ->
-                        modify $ aks.left  .~ (movement == KeyDown)
-                    SDL.Right ->
-                        modify $ aks.right .~ (movement == KeyDown)
-                    SDL.Up    ->
-                        modify $ aks.up    .~ (movement == KeyDown)
-                    SDL.Down  ->
-                        modify $ aks.down  .~ (movement == KeyDown)
-                    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]

src/Types.hs

@@ -13,8 +13,8 @@ import Control.Monad.RWS.Strict (RWST)
 import Control.Lens
 import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
 import Render.Types
-import UI.UIBaseData
 import Importer.IQM.Types
+import UI.UIBase
 
 data Coord3D a = Coord3D a a a
 
@@ -147,7 +147,7 @@ data GLState = GLState
 
 data UIState = UIState
     { _uiHasChanged        :: !Bool
-    , _uiMap               :: Map.HashMap UIId (GUIAny Pioneers)
+    , _uiMap               :: Map.HashMap UIId (GUIWidget Pioneers)
     , _uiRoots             :: [UIId]
     }
 

src/UI/Callbacks.hs

@@ -2,91 +2,168 @@ module UI.Callbacks where
 
 
 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 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 qualified Graphics.UI.SDL                      as SDL
 
+
+import Render.Misc                                    (curb,genColorData)
 import Types
-import UI.UIBaseData
+import UI.UIWidgets
-import UI.UIClasses
 import UI.UIOperations
 
 
-data Pixel = Pixel Int Int
+createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
-
+createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
-createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
+                          , (UIId 1, createContainer (20, 50, 120, 80) [] 1)
-createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
+                          , (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3)
-                          , (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
+                          , (UIId 3, createContainer (100, 140, 130, 200) [] 4 )
-                          , (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
+                          , (UIId 4, createButton (30, 200, 60, 175) 2 testMessage)
-                          , (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 :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
-getGUI hmap = Map.elems hmap
+getGUI = Map.elems
+{-# INLINE getGUI #-}
 
 getRootIds :: Pioneers [UIId]
 getRootIds = do
   state <- get
   return $ state ^. ui.uiRoots
 
-getRoots :: Pioneers [GUIAny Pioneers]
+getRoots :: Pioneers [GUIWidget Pioneers]
 getRoots = do
   state <- get
   rootIds <- getRootIds
   let hMap = state ^. ui.uiMap
   return $ toGUIAnys hMap rootIds
 
-testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w
+testMessage :: MouseButton -> w -> Pixel -> Pioneers w
-testMessage w x y = do
+testMessage btn w (x, y) = do
-  liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
+  case btn of
+       LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y)
+       RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y)
+       MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y)
+       MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y)
+       MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y)
   return w
 
+transformButton :: SDL.MouseButton -> Maybe MouseButton
+transformButton SDL.LeftButton = Just LeftButton
+transformButton SDL.RightButton = Just RightButton
+transformButton SDL.MiddleButton = Just MiddleButton
+transformButton SDL.MouseX1 = Just MouseX1
+transformButton SDL.MouseX2 = Just MouseX2
+transformButton _ = Nothing
+
+eventCallback :: SDL.Event -> Pioneers ()
+eventCallback e = do
+        env <- ask
+        case SDL.eventData e of
+            SDL.Window _ _ -> -- 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 LeftButton (x, y)
+                    _ -> do when (state == SDL.Released)
+                                $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
+            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.
 --   Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
-clickHandler :: Pixel -> Pioneers ()
+clickHandler :: MouseButton -> Pixel -> Pioneers ()
-clickHandler (Pixel x y) = do
+clickHandler btn pos@(x,y) = do
   state <- get
   let hMap = state ^. ui.uiMap
   roots <- getRootIds
-  hits <- liftM concat $ mapM (getInsideId hMap x y) roots
+  hits <- liftM concat $ mapM (getInsideId hMap pos) roots
   case hits of
-       [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
+       [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
        _  -> do
-         changes <- sequence $ map (\uid -> do
+         changes <- mapM (\uid -> do
            let w = toGUIAny hMap uid
-           short <- getShorthand w
+               short = w ^. baseProperties.shorthand
-           bound <- getBoundary w
+           bound <- w ^. baseProperties.boundary
-           prio <- getPriority w
+           prio <- w ^. baseProperties.priority
            liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
                             ++ " at [" ++ show x ++ "," ++ show y ++ "]"
-           case w of
+           case w ^. mouseActions of
-                (GUIAnyB b h) -> do
+                Just ma -> do w'  <- (ma ^. onMousePress) btn pos w
-                    (b', h') <- onMousePressed x y b h
+                              w'' <- (ma ^. onMouseRelease) btn pos w'
-                    (b'', h'') <- onMouseReleased x y b' h'
+                              return $ Just (uid, w'')
-                    return $ Just (uid, GUIAnyB b'' h'')
+                Nothing  -> return Nothing
-                _ -> return Nothing
            ) $ hits
-         let newMap :: Map.HashMap UIId (GUIAny Pioneers)
+         let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
              newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
          modify $ ui.uiMap .~ newMap
          return ()
          
 
-
--- | Handler for UI-Inputs.
---   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
-alternateClickHandler :: Pixel -> Pioneers ()
-alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"]
-
-
 -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
 --
 --TODO: should be done asynchronously at one point.
@@ -108,19 +185,19 @@ prepareGUI = do
                 modify $ ui.uiHasChanged .~ False
 
 --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
-copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers ()
+copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers ()
 copyGUI tex widget = do
-                        (xoff, yoff, wWidth, wHeight) <- getBoundary widget
+                        (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
                         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
+                            color = case widget ^. baseProperties.shorthand of
-                                (GUIAnyC _)   -> [255,0,0,128]
+                                "CNT" -> [255,0,0,128]
-                                (GUIAnyB _ _) -> [255,255,0,255]
+                                "BTN" -> [255,255,0,255]
-                                (GUIAnyP _)   -> [128,128,128,128]
+                                "PNL" -> [128,128,128,128]
                                 _     -> [255,0,255,255]
                         liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
                                 --copy data into C-Array
@@ -131,7 +208,7 @@ copyGUI tex widget = do
                                         (GL.TexturePosition2D (int xoff) (int yoff))
                                         (GL.TextureSize2D (int wWidth) (int wHeight))
                                         (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
-                        nextChildrenIds <- getChildren widget
+                        nextChildrenIds <- widget ^. baseProperties.children
                         mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
 
 --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.

src/UI/UIBase.hs

@@ -0,0 +1,232 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
+-- widget data is separated into several modules to avoid cyclic dependencies with the Type module
+-- TODO: exclude UIMouseState constructor from export?
+module UI.UIBase where
+
+import           Control.Lens             ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses)
+import           Control.Monad            (liftM)
+import           Data.Array
+import           Data.Hashable
+import           Data.Ix                  ()
+import           Data.Maybe
+import           GHC.Generics (Generic)
+
+-- |Unit of screen/window
+type ScreenUnit = Int
+
+-- | @x@ and @y@ position on screen. 
+type Pixel = (ScreenUnit, ScreenUnit)
+
+newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
+
+data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
+
+instance Hashable MouseButton
+
+firstButton :: MouseButton
+firstButton = LeftButton
+
+lastButton :: MouseButton
+lastButton = MiddleButton
+
+-- |The button dependant state of a 'UIMouseState'.
+data UIMouseStateSingle = MouseStateSingle
+    { _mouseIsFiring      :: Bool -- ^firing if pressed but not confirmed
+    , _mouseIsDeferred    :: Bool
+      -- ^deferred if e. g. dragging but outside component
+    } deriving (Eq, Show)
+
+-- |The state of a clickable ui widget.
+data UIMouseState = MouseState
+    { _mouseStates :: Array MouseButton UIMouseStateSingle
+    , _mouseIsReady       :: Bool -- ^ready if mouse is above component
+    } deriving (Eq, Show)
+
+
+-- |Switches primary and secondary mouse actions.
+--  "monad type" "widget type" "original handler"
+data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
+
+-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
+data ButtonHandler m w = ButtonHandler 
+    { _action :: w -> Pixel -> m w }
+instance Show (ButtonHandler m w) where
+  show _ = "ButtonHandler ***"
+
+-- |A @GUIWidget@ is a visual object the HUD is composed of. 
+data GUIWidget m = Widget
+    {_baseProperties :: GUIBaseProperties m
+    ,_mouseActions :: Maybe (GUIMouseActions m)
+    ,_graphics :: GUIGraphics m
+    }
+
+-- |Base properties are fundamental settings of any 'GUIWidget'.
+--  They mostly control positioning and widget hierarchy.
+data GUIBaseProperties m = BaseProperties
+    {
+    -- |The @_getBoundary@ function gives the outer extents of the @GUIWidget@.
+    --  The bounding box wholly contains all children components.
+    _boundary :: m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
+    ,
+    -- |The @_getChildren@ function returns all children associated with this widget.
+    --
+    --  All children must be wholly inside the parent's bounding box specified by '_boundary'.
+    _children :: m [UIId]
+    ,
+    -- |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.
+    _isInside :: GUIWidget m
+              -> Pixel  -- ^screen position
+              -> m Bool
+    ,
+    -- |The @_getPriority@ function returns the priority score of a @GUIWidget@.
+    --  A widget with a high score is more in the front than a low scored widget.
+    _priority :: m Int
+    ,
+    -- |The @_getShorthand@ function returns a descriptive 'String' mainly for debuggin prupose.
+    --  The shorthand should be unique for each instance.
+    _shorthand :: String
+    }
+
+-- |Mouse actions control the functionality of a 'GUIWidget' on mouse events. 
+data GUIMouseActions m = MouseActions
+    {
+    -- |The @_mouseState@ function returns the current mouse state of a widget.
+    _mouseState :: UIMouseState
+    ,
+    -- |The function 'onMousePressed' is called when a button is pressed
+    --  while inside a screen coordinate within the widget ('isInside').
+    _onMousePress :: MouseButton       -- ^the pressed button
+                  -> Pixel             -- ^screen position
+                  -> GUIWidget m       -- ^widget the event is invoked on
+                  -> m (GUIWidget m)   -- ^widget after the event and the possibly altered mouse handler
+    ,
+    -- |The function 'onMouseReleased' is called when a button is released
+    --  while the pressing event occured within the widget ('isInside').
+    --  
+    --  Thus, the mouse is either within the widget or outside while still dragging.
+    _onMouseRelease :: MouseButton       -- ^the released button
+                    -> Pixel             -- ^screen position
+                    -> GUIWidget m       -- ^widget the event is invoked on
+                    -> m (GUIWidget m)   -- ^widget after the event and the altered handler
+    ,
+    -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
+    --  widget's space ('isInside').
+    _onMouseMove :: Pixel             -- ^screen position
+                 -> GUIWidget m       -- ^widget the event is invoked on
+                 -> m (GUIWidget m)   -- ^widget after the event and the altered handler
+    ,
+    -- |The function 'onMouseMove' is invoked when the mouse enters the
+    --  widget's space ('isInside').
+    _onMouseEnter :: Pixel           -- ^screen position
+                  -> GUIWidget m     -- ^widget the event is invoked on
+                  -> m (GUIWidget m) -- ^widget after the event and the altered handler
+    ,
+    -- |The function 'onMouseMove' is invoked when the mouse leaves the
+    --  widget's space ('isInside').
+    _onMouseLeave :: Pixel           -- ^screen position
+                  -> GUIWidget m     -- ^widget the event is invoked on
+                  -> m (GUIWidget m) -- ^widget after the event and the altered handler
+    }
+
+
+-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
+
+data GUIGraphics m = Graphics 
+    {temp :: m Int}
+
+$(makeLenses ''UIMouseState)
+$(makeLenses ''UIMouseStateSingle)
+$(makeLenses ''GUIWidget)
+$(makeLenses ''GUIBaseProperties)
+$(makeLenses ''GUIMouseActions)
+$(makeLenses ''GUIGraphics)
+
+initialMouseStateS :: UIMouseStateSingle
+initialMouseStateS = MouseStateSingle False False
+{-# INLINE initialMouseStateS #-}
+
+-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
+--  provided in the passed list.
+initialMouseState :: UIMouseState
+initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)])
+                               False
+{-# INLINE initialMouseState #-}
+
+emptyMouseAction :: (Monad m) => GUIMouseActions m
+emptyMouseAction = MouseActions initialMouseState empty'' empty'' empty' empty' empty'
+    where empty' _ = return
+          empty'' _ _ = return
+
+-- TODO: combined mouse handler
+
+-- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
+-- |Creates a @GUIMouseActions@ handler that enables button clicks.
+-- 
+--  The action is peformed right before the button state change.
+buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
+                                -> GUIMouseActions m
+buttonMouseActions a = MouseActions initialMouseState press' release' move' enter' leave'
+  where 
+    -- |Change 'UIMouseState's '_mouseIsFiring' to @True@.
+    press' b _ w =
+        return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True
+
+    -- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and
+    --  call action if '_mouseIsFiring' was @True@.
+    release' b p w =
+      let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly
+      in do w' <- if fire
+                  then a b w p
+                  else return w
+            return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~
+                (mouseIsFiring .~ False) . (mouseIsDeferred .~ False)
+    
+    -- |Do nothing.
+    move' _ = return
+    
+    -- |Set 'UIMouseState's '_mouseIsReady' to @True@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value
+    --  and set '_mouseIsFiring' to @False@. 
+    enter' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ True)
+                        .(mouseStates.mapped %~ (mouseIsDeferred .~ False)
+                            -- following line executed BEFORE above line
+                            .(\sState -> sState & mouseIsFiring .~ not (sState ^. mouseIsDeferred)))
+   
+    
+    -- |Set 'UIMouseState's 'buttonstateIsReady' to @False@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
+    --  and set '_buttonstateIsDeferred's' to @False@.
+    leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False)
+                        .(mouseStates.mapped %~ (mouseIsFiring .~ False)
+                            -- following line executed BEFORE above line
+                            .(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
+
+emptyGraphics :: (Monad m) => GUIGraphics m
+emptyGraphics = Graphics (return 3)
+
+isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
+isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
+
+rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
+rectangularBase bnd chld prio short =
+    BaseProperties (return bnd) (return chld)
+                   (\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary))
+                   (return prio) short
+
+debugShowWidget' :: (Monad m) => GUIWidget m -> m String
+debugShowWidget' (Widget base mouse _) = do
+    bnd <- base ^. boundary
+    chld <- base ^. children
+    prio <- base ^. priority
+    let short = base ^. shorthand
+    return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
+                    ",priority:",show prio, maybe "" (const ", with mouse handler") mouse]
+    

src/UI/UIBaseData.hs

@@ -1,74 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
--- data and classes are separated into several modules to avoid cyclic dependencies with the Type module
-
-module UI.UIBaseData where
-
-import Data.Hashable
-import Data.Ix
-
--- |Unit of screen/window
-type ScreenUnit = Int
-
-
-newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
-
--- |The state of a clickable ui widget.
-data UIButtonState = UIButtonState
-    { _buttonstateIsFiring      :: Bool
-    -- ^firing if pressed but not confirmed 
-    , _buttonstateIsFiringAlt   :: Bool
-    -- ^firing if pressed but not confirmed (secondary mouse button)
-    , _buttonstateIsDeferred    :: Bool -- ^ deferred if e. g. dragging but outside component
-    , _buttonstateIsDeferredAlt :: Bool
-    -- ^deferred if e. g. dragging but outside component (secondary mouse button)
-    , _buttonstateIsReady       :: Bool
-    -- ^ready if mouse is above component
-    , _buttonstateIsActivated   :: Bool
-    -- ^in activated state (e. g. toggle button)
-    } deriving (Eq, Show)
-
-
--- |Switches primary and secondary mouse actions.
---  "monad type" "widget type" "original handler"
-data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
-
--- |A 'UI.UIClasses.MouseHandler' with button behaviour.
-data ButtonHandler m w = ButtonHandler 
-    { _action :: (w -> ScreenUnit -> ScreenUnit -> m w) }
-instance Show (ButtonHandler m w) where
-  show _ = "ButtonHandler ***"
-
--- |A collection data type that may hold any usable ui element. @m@ is a monad.
-data GUIAny m = GUIAnyC GUIContainer
-              | GUIAnyP GUIPanel
-              | GUIAnyB GUIButton (ButtonHandler m GUIButton)
-              deriving (Show)
-
-
--- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
---  functionality itself.
-data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit
-                                 , _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit
-                                 , _uiChildren :: [UIId]
-                                 , _uiPriority :: Int
-                                 } deriving (Show)
-
--- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
---  children components.
-data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
-    
--- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be
---  provided by an appropriate 'MouseHanlder'.
-data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit
-                           , _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit
-                           , _uiPriorityB :: Int
-                           , _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)
-        ++ "}"

src/UI/UIClasses.hs

@@ -1,251 +0,0 @@
-{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
-
-module UI.UIClasses where
-
-import           Control.Lens                         ((^.))
-import           Control.Monad
---import           Control.Monad.IO.Class -- MonadIO
-import           Control.Monad.RWS.Strict             (get)
-import           Data.List
-import           Data.Maybe
-import qualified Data.HashMap.Strict as Map
-
-import qualified Types as T
-import UI.UIBaseData
-
-class GUIAnyMap m w where
-    guiAnyMap :: (w -> b) -> GUIAny m -> b
-    
-class (Monad m) => GUIWidget m uiw where
-    -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
-    --  The bounding box wholly contains all children components.
-    getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
-
-    -- |The 'getChildren' function returns all children associated with this widget.
-    --
-    --  All children must be wholly inside the parent's bounding box specified by 'getBoundary'.
-    getChildren :: uiw -> m [UIId]
-    getChildren _ = return []
-
-    -- |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.
-    isInside :: ScreenUnit -- ^screen x coordinate
-                 -> ScreenUnit -- ^screen y coordinate
-                 -> uiw       -- ^the parent widget
-                 -> m Bool
-    isInside x' y' wg = do
-        (x, y, w, h) <- getBoundary wg
-        return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
-
-    -- |The 'getPriority' function returns the priority score of a 'GUIWidget'.
-    --  A widget with a high score is more in the front than a low scored widget.
-    getPriority :: uiw -> m Int
-    getPriority _ = return 0
-    
-    -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
-    --  The shorthand should be unique for each instance.
-    getShorthand :: uiw -> m String
-
--- |A 'GUIClickable' represents a widget with a 'UIButtonState'.
--- 
---  Minimal complete definition: 'getButtonState' and either 'updateButtonState' or 'setButtonState'.
-class GUIClickable w where
-    updateButtonState :: (UIButtonState -> UIButtonState) -> w -> w
-    updateButtonState f w = setButtonState (f $ getButtonState w) w
-    setButtonState :: UIButtonState -> w -> w
-    setButtonState s = updateButtonState (\_ -> s)
-    getButtonState :: w -> UIButtonState
-
-class Monad m => MouseHandler a m w where
-    -- |The function 'onMousePressed' is called when the primary button is pressed
-    --  while inside a screen coordinate within the widget ('isInside').
-    onMousePressed :: ScreenUnit -- ^screen x coordinate 
-                   -> ScreenUnit -- ^screen y coordinate
-                   -> w -- ^widget the event is invoked on
-                   -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMousePressed _ _ wg a = return (wg, a)
-
-    -- |The function 'onMouseReleased' is called when the primary button is released
-    --  while the pressing event occured within the widget ('isInside').
-    --  
-    --  Thus, the mouse is either within the widget or outside while still dragging.
-    onMouseReleased :: ScreenUnit -- ^screen x coordinate
-                    -> ScreenUnit  -- ^screen x coordinate
-                    -> w -- ^wdiget the event is invoked on
-                    -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseReleased _ _ wg a = return (wg, a)
-
-    -- |The function 'onMousePressed' is called when the secondary button is pressed
-    --  while inside a screen coordinate within the widget ('isInside').
-    onMousePressedAlt :: ScreenUnit -- ^screen x coordinate 
-                   -> ScreenUnit -- ^screen y coordinate
-                   -> w -- ^widget the event is invoked on
-                   -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMousePressedAlt _ _ wg a = return (wg, a)
-
-    -- |The function 'onMouseReleased' is called when the secondary button is released
-    --  while the pressing event occured within the widget ('isInside').
-    --  
-    --  Thus, the mouse is either within the widget or outside while still dragging.
-    onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate
-                       -> ScreenUnit  -- ^screen x coordinate
-                       -> w -- ^wdiget the event is invoked on
-                       -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseReleasedAlt _ _ wg a = return (wg, a)
-                        
-    -- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-    --  widget's space ('isInside').
-    onMouseMove :: ScreenUnit -- ^screen x coordinate
-                -> ScreenUnit -- ^screen y coordinate
-                -> w -- ^widget the event is invoked on
-                -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseMove _ _ wg a = return (wg, a)
-    
-    -- |The function 'onMouseMove' is invoked when the mouse enters the
-    --  widget's space ('isInside').
-    onMouseEnter :: ScreenUnit -- ^screen x coordinate
-                 -> ScreenUnit -- ^screen y coordinate
-                 -> w -- ^widget the event is invoked on
-                 -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseEnter _ _ wg a = return (wg, a)
-    
-    -- |The function 'onMouseMove' is invoked when the mouse leaves the
-    --  widget's space ('isInside').
-    onMouseLeave :: ScreenUnit -- ^screen x coordinate
-                 -> ScreenUnit -- ^screen y coordinate
-                 -> w -- ^widget the event is invoked on
-                 -> a -> m (w, a) -- ^widget after the event and the altered handler
-    onMouseLeave _ _ wg a = return (wg, a)
-
-instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where
-    onMousePressed x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMousePressedAlt x y w h
-        return (w', MouseHandlerSwitch h')
-    onMouseReleased x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseReleasedAlt x y w h
-        return (w', MouseHandlerSwitch h')
-    onMousePressedAlt x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMousePressed x y w h
-        return (w', MouseHandlerSwitch h')
-    onMouseReleasedAlt x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseReleased x y w h
-        return (w', MouseHandlerSwitch h')
-    onMouseMove x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseMove x y w h
-        return (w', MouseHandlerSwitch h')
-    onMouseEnter x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseEnter x y w h
-        return (w', MouseHandlerSwitch h')
-    onMouseLeave x y w (MouseHandlerSwitch h) = do
-        (w', h') <- onMouseLeave x y w h
-        return (w', MouseHandlerSwitch h')
-
-instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
-    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
-    onMousePressed _ _ wg h =
-        return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
-
-    -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
-    --  call 'action' if inside the widget or
-    --  set '_buttonstateIsDeferred' to false otherwise.
-    onMouseReleased x y wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg 
-        then do
-            wg' <- action wg x y
-            return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h)
-        else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h)
-    
-    -- |Do nothing.
-    onMouseMove _ _ wg h = return (wg, h)
-    
-    -- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and
-    --  update dragging state (only drag if inside widget).
-    --  In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value
-    --   and set '_buttonstateIsFiring' to @False@. 
-    onMouseEnter _ _ wg h = return
-        (updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s
-                                    , _buttonstateIsDeferred = False
-                                    , _buttonstateIsReady = True
-                                    }) wg
-                                    , h)
-    
-    -- |Set 'UIButtonState's 'buttonstateIsReady' to @False@ and
-    --  update dragging state (only drag if inside widget).
-    --  In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
-    --  and set '_buttonstateIsDeferred's' to @False@.
-    onMouseLeave _ _ wg h = return
-        (updateButtonState (\s -> s { _buttonstateIsFiring = False
-                                    , _buttonstateIsDeferred = _buttonstateIsFiring s
-                                    , _buttonstateIsReady = False
-                                    }) wg
-                                    , h)
-
-instance (Monad m) => GUIAnyMap m (GUIAny m) where
-    guiAnyMap f w = f w
-
-instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
-    getBoundary (GUIAnyC w) = getBoundary w
-    getBoundary (GUIAnyP w) = getBoundary w
-    getBoundary (GUIAnyB w _) = getBoundary w
-    getChildren (GUIAnyC w) = getChildren w
-    getChildren (GUIAnyP w) = getChildren w
-    getChildren (GUIAnyB w _) = getChildren 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
-    getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str }
-    getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str }
-    getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str }
-
-instance (Monad m) => GUIAnyMap m GUIContainer where
-    guiAnyMap f (GUIAnyC c) = f c
-    guiAnyMap _ _ = error "invalid types in guiAnyMap"
-instance (Monad m) => GUIWidget m GUIContainer where
-    getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
-    getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt)
-    getChildren cnt = return $ _uiChildren cnt
-    getPriority cnt = return $ _uiPriority cnt
-    getShorthand _ = return $ "CNT"
-    
-instance GUIAnyMap m GUIPanel where
-    guiAnyMap f (GUIAnyP p) = f p
-    guiAnyMap _ _ = error "invalid types in guiAnyMap"
-instance GUIWidget T.Pioneers GUIPanel where
-    getBoundary pnl = do
-        state <- get
-        let hmap = state ^. T.ui . T.uiMap
-        case _uiChildren $ _panelContainer pnl of
-                           [] -> getBoundary $ _panelContainer pnl
-                           cs -> do
-                                 let widgets = catMaybes $ map (flip Map.lookup hmap) cs
-                                 foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets
-      where
-        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'')
-            
-    getChildren pnl = getChildren $ _panelContainer pnl
-    getPriority pnl = getPriority $ _panelContainer pnl
-    getShorthand _ = return $ "PNL"
-
-instance (Monad m) => GUIAnyMap m GUIButton where
-    guiAnyMap f (GUIAnyB btn _) = f btn
-    guiAnyMap _ _ = error "invalid types in guiAnyMap"
-instance GUIClickable GUIButton where
-    getButtonState = _uiButtonState
-    updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn}
-instance (Monad m) => GUIWidget m GUIButton where
-    getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn)
-    getChildren _ = return []
-    getPriority btn = return $ _uiPriorityB btn
-    getShorthand _ = return "BTN"

src/UI/UIOperations.hs

@@ -1,24 +1,19 @@
 module UI.UIOperations where
 
+import           Control.Lens                    ((^.))
 import           Control.Monad                   (liftM)
 import qualified Data.HashMap.Strict             as Map
 import           Data.Maybe
 
 import Types
-import UI.UIBaseData
+import UI.UIBase
-import UI.UIClasses
 
-defaultUIState :: UIButtonState
+toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m
-defaultUIState = UIButtonState False False False False False False
+toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
-
-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 :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
-toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
+toGUIAnys m = mapMaybe (`Map.lookup` m)
 {-# INLINE toGUIAnys #-}
 -- TODO: check for missing components?
 
@@ -32,17 +27,16 @@ toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
 --  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
+getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-             -> ScreenUnit -- ^screen x coordinate
+          -> Pixel  -- ^screen position
-             -> ScreenUnit -- ^screen y coordinate
+          -> GUIWidget Pioneers  -- ^the parent widget
-             -> GUIAny Pioneers  -- ^the parent widget
+          -> Pioneers [GUIWidget Pioneers]
-             -> Pioneers [GUIAny Pioneers]
+getInside hMap px wg = do
-getInside hMap x' y' wg = do
+  inside <- (wg ^. baseProperties.isInside) wg px
-  inside <- isInside x' y' wg
   if inside -- test inside parent's bounding box
   then do
-       childrenIds <- getChildren wg
+       childrenIds <- wg ^. baseProperties.children
-       hitChildren <- liftM concat $ mapM (getInside hMap x' y') (toGUIAnys hMap childrenIds)
+       hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds)
        case hitChildren of
             [] -> return [wg]
             _  -> return hitChildren
@@ -58,18 +52,17 @@ getInside hMap x' y' wg = do
 --  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
+getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-            -> ScreenUnit -- ^screen x coordinate
+            -> Pixel  -- ^screen position
-            -> ScreenUnit -- ^screen y coordinate
             -> UIId  -- ^the parent widget
             -> Pioneers [UIId]
-getInsideId hMap x' y' uid = do
+getInsideId hMap px uid = do
   let wg = toGUIAny hMap uid
-  inside <- isInside x' y' wg
+  inside <- (wg ^. baseProperties.isInside) wg px
   if inside -- test inside parent's bounding box
     then do
-      childrenIds <- getChildren wg
+      childrenIds <- wg ^. baseProperties.children
-      hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds
+      hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds
       case hitChildren of
            [] -> return [uid]
            _  -> return hitChildren

src/UI/UIWidgets.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
+
+module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
+
+import           Control.Lens                         ((^.), (.~), (&))
+import           Control.Monad
+--import           Control.Monad.IO.Class -- MonadIO
+import           Control.Monad.RWS.Strict             (get)
+import           Data.List
+import           Data.Maybe
+import qualified Data.HashMap.Strict as Map
+
+import           Types
+import UI.UIBase
+
+
+createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
+createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
+                                          Nothing
+                                          emptyGraphics
+
+
+createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
+createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
+                                      Nothing
+                                      emptyGraphics
+  where
+    autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
+    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'')
+        case chld of
+             [] -> return bnd
+             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
+createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
+                                         (Just $ buttonMouseActions action)
+                                         emptyGraphics