basic gui working... somehow (no painting yet)

src/UI/Callbacks.hs

@@ -9,14 +9,37 @@ import UI.UITypes
 data Pixel = Pixel Int Int
 
 getGUI :: [GUIAny]
-getGUI = (GUIAny $ GUIContainer 0 0 120 80 [] 1):(GUIAny $ GUIContainer 50 60 300 700 [(GUIAny $ GUIContainer 55 65 200 400 [] 5)] 1):[]
+getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1
+         , toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0
+             [toGUIAny $ GUIContainer  0 80 100 200 [] 4
+             ,GUIAnyB (GUIButton 50 400 200 175 2 (testMessage) defaultUIState)
+             ] 3
+         ]
+
+testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w
+testMessage w x y = do
+    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 concat $ map (isInside x y) getGUI of
+clickHandler (Pixel x y) = case concatMap (isInside x y) getGUI of
     [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
-    hit -> liftIO $ putStrLn $ unwords $ foldl (++) ["hitting"] ([map (\w -> (show.getBoundary) w ++ ' ':(show.getPriority) w) hit])
+    hit -> liftIO $ do
+        _ <- sequence $ map (\w ->
+            case w of
+                 (GUIAnyB b) -> do
+                      putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
+                          ++ " at ["++show x++","++show y++"]"
+                      (b', _) <- onMousePressed x y b b
+                      _ <- onMouseReleased x y b' b'
+                      return ()
+                 _ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
+                          ++ " at ["++show x++","++show y++"]"
+            ) hit
+        return ()
+
 
 -- | Handler for UI-Inputs.
 --   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...

src/UI/UITypes.hs

@@ -1,16 +1,54 @@
-{-# LANGUAGE InstanceSigs, ExistentialQuantification #-}
+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
 
 module UI.UITypes where
 
+import Data.List
+import Foreign.C                            (CFloat)
+import Linear.Matrix (M44)
 
-type IntScreen = Int
+-- |Unit of screen/window
+type ScreenUnit = Int
 
-data GUIAny = forall wg. GUIWidget wg => GUIAny wg
+-- |A viewport to an OpenGL scene.
+data Viewport = Viewport
+    { _viewportXAngle          :: !Double
+    , _viewportYAngle          :: !Double
+    , _viewportZDist           :: !Double
+    , _viewportFrustum         :: !(M44 CFloat)
+    , _viewportPositionX       :: !ScreenUnit -- ^x position in window
+    , _viewportPositionY       :: !ScreenUnit -- ^y position in window
+    , _viewportWidth           :: !ScreenUnit -- ^viewport width in window
+    , _viewportHeight          :: !ScreenUnit -- ^viewport height in window
+    } deriving (Eq, Show)
+    
+data UIState = UIState
+    { _uistateIsFiring      :: Bool
+    -- ^firing if pressed but not confirmed 
+    , _uistateIsFiringAlt   :: Bool
+    -- ^firing if pressed but not confirmed (secondary mouse button)
+    , _uistateIsDeferred    :: Bool -- ^ deferred if e. g. dragging but outside component
+    , _uistateIsDeferredAlt :: Bool
+    -- ^deferred if e. g. dragging but outside component (secondary mouse button)
+    , _uistateIsReady       :: Bool
+    -- ^ready if mouse is above component
+    , _uistateIsActivated   :: Bool
+    -- ^in activated state (e. g. toggle button)
+    } deriving (Eq, Show)
 
-class GUIWidget uiw where
+
+defaultUIState :: UIState
+defaultUIState = UIState False False False False False False
+
+class GUIAnyMap w where
+    guiAnyMap :: (w -> b) -> GUIAny -> b
+    toGUIAny :: w -> GUIAny
+    fromGUIAny :: GUIAny -> w
+    
+    
+class (GUIAnyMap uiw) => GUIWidget uiw where
     -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
     --  The bounding box wholly contains all children components.
-    getBoundary :: uiw -> (IntScreen, IntScreen, IntScreen ,IntScreen) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
+    getBoundary :: uiw -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
 
     -- |The 'getChildren' function returns all children associated with this widget.
     --
@@ -19,9 +57,13 @@ class GUIWidget uiw where
     getChildren _ = []
 
     -- |The function 'isInsideSelf' 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.
+    --  A screen position may be inside the bounding box of a widget but not considered part of the
-    isInsideSelf :: IntScreen -- ^screen x coordinate
+    --  component.
-                 -> IntScreen -- ^screen y coordinate
+    --  
+    --  The default implementations tests if the point is within the rectangle specified by the 
+    --  'getBoundary' function.
+    isInsideSelf :: ScreenUnit -- ^screen x coordinate
+                 -> ScreenUnit -- ^screen y coordinate
                  -> uiw       -- ^the parent widget
                  -> Bool
     isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg
@@ -31,15 +73,15 @@ class GUIWidget uiw where
     --  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 :: IntScreen -- ^screen x coordinate
+    isInside :: ScreenUnit -- ^screen x coordinate
-             -> IntScreen -- ^screen y coordinate
+             -> ScreenUnit -- ^screen y coordinate
              -> uiw       -- ^the parent widget
              -> [GUIAny]
     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
-                [] -> [GUIAny wg]
+                [] -> [toGUIAny wg]
                 l  -> l
     --TODO: Priority queue?
 
@@ -47,22 +89,297 @@ class GUIWidget uiw where
     --  A widget with a high score is more in the front than a low scored widget.
     getPriority :: uiw -> Int
     getPriority _ = 0
+    
+    -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
+    --  The shorthand should be unique for each instance.
+    getShorthand :: uiw -> String
 
+class MouseHandler a 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 -> IO (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 -> IO (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 -> IO (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 -> IO (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 -> IO (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 -> IO (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 -> IO (w, a) -- ^widget after the event and the altered handler
+    onMouseLeave _ _ wg a = return (wg, a)
+
+-- |Switches primary and secondary mouse actions.
+data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show)
+instance Functor (MouseHandlerSwitch w) where
+    fmap :: (h1 -> h2) -> MouseHandlerSwitch w h1 -> MouseHandlerSwitch w h2
+    fmap f (MouseHandlerSwitch h) = MouseHandlerSwitch (f h)
+instance Monad (MouseHandlerSwitch w) where
+    (>>=) :: (MouseHandlerSwitch w h1) -> (h1 -> MouseHandlerSwitch w h2) -> MouseHandlerSwitch w h2 
+    (MouseHandlerSwitch h) >>= f = f h
+    return :: h -> MouseHandlerSwitch w h
+    return h = MouseHandlerSwitch h
+instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) 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')
+
+
+-- !!Important: one handler can only handle one single widget!!
+data ButtonHandler w = ButtonHandler 
+    { _action :: (w -> ScreenUnit -> ScreenUnit -> IO w)
+    , _handlerState :: UIState
+    }
+instance (Show w) => Show (ButtonHandler w) where
+    show (ButtonHandler _ w) = "ButtonHandler [" ++ show w ++ "] " ++ "[action]" 
+instance MouseHandler (ButtonHandler w) w where
+    -- |Change 'UIState's '_uistateIsFiring' to @True@.
+    onMousePressed _ _ wg h@(ButtonHandler _ s) = do
+        return (wg, h {_handlerState = s {_uistateIsFiring = True}})
+
+    -- |Change 'UIState's '_uistateIsFiring' to @False@ and
+    --  call 'action' if inside the widget or
+    --  set '_uistateIsDeferred' to false otherwise.
+    onMouseReleased x y wg h@(ButtonHandler f s) = if _uistateIsFiring s 
+        then do
+            wg' <- f wg x y
+            return (wg', h {_handlerState = s {_uistateIsFiring = False}})
+        else return (wg, h {_handlerState = s {_uistateIsDeferred = False}})
+    
+    -- |Do nothing.
+    onMouseMove _ _ wg h = return (wg, h)
+    
+    -- |Set 'UIState's '_uistateIsReady' to @True@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value
+    --   and set '_uistateIsFiring' to @False@. 
+    onMouseEnter _ _ wg h@(ButtonHandler _ s) = return
+        (wg, h {_handlerState = s { _uistateIsFiring = _uistateIsDeferred s
+                                  , _uistateIsDeferred = False
+                                  , _uistateIsReady = True
+                                  }})
+    
+    -- |Set 'UIState's 'uistateIsReady' to @False@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIState's '_uistateIsFiring' to '_uistateIsDeferred's current value
+    --  and set '_uistateIsDeferred's' to @False@.
+    onMouseLeave _ _ wg h@(ButtonHandler _ s) = return
+        (wg, h {_handlerState = s { _uistateIsFiring = False
+                                  , _uistateIsDeferred = _uistateIsFiring s
+                                  , _uistateIsReady = False
+                                  }})
+
+
+data GUIAny = GUIAnyC GUIContainer
+            | GUIAnyP GUIPanel
+            | GUIAnyB GUIButton
+            deriving (Show)
+instance GUIAnyMap GUIAny where
+    guiAnyMap f w = f w
+    toGUIAny = id
+    fromGUIAny = id
 
 instance GUIWidget GUIAny where
-    getBoundary (GUIAny wg) = getBoundary wg
+    getBoundary (GUIAnyC w) = getBoundary w
-    isInsideSelf x y (GUIAny wg) = isInsideSelf x y wg
+    getBoundary (GUIAnyP w) = getBoundary w
-    isInside x y (GUIAny wg) = isInside x y wg
+    getBoundary (GUIAnyB w) = getBoundary w
-    getChildren (GUIAny wg) = getChildren wg
+    getChildren (GUIAnyC w) = getChildren w
-    getPriority (GUIAny wg) = getPriority wg
+    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
+    getShorthand (GUIAnyC w) = "A" ++ getShorthand w
+    getShorthand (GUIAnyP w) = "A" ++ getShorthand w
+    getShorthand (GUIAnyB w) = "A" ++ getShorthand w
 
-data GUIContainer = GUIContainer {_screenX :: IntScreen, _screenY :: IntScreen
+-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
-                                 , _width :: IntScreen, _height :: IntScreen
+--  functionality itself.
+data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit
+                                 , _width :: ScreenUnit, _height :: ScreenUnit
                                  , _children :: [GUIAny]
-                                 , _priority :: Int}
+                                 , _priority :: Int
+                                 } deriving (Show)
 
+instance GUIAnyMap GUIContainer where
+    guiAnyMap f (GUIAnyC c) = f c
+    guiAnyMap _ _ = error "invalid types in guiAnyMap"
+    toGUIAny cnt = GUIAnyC cnt
+    fromGUIAny (GUIAnyC cnt) = cnt
+    fromGUIAny _ = error "invalid GUIAny type"
 instance GUIWidget GUIContainer where
-    getBoundary :: GUIContainer -> (IntScreen, IntScreen, IntScreen ,IntScreen)
+    getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
     getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
     getChildren cnt = _children cnt
-    getPriority cnt = _priority cnt
+    getPriority cnt = _priority cnt
+    getShorthand _ = "CNT"
+    
+-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
+--  children components.
+data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
+instance GUIAnyMap GUIPanel where
+    guiAnyMap f (GUIAnyP p) = f p
+    guiAnyMap _ _ = error "invalid types in guiAnyMap"
+    toGUIAny pnl = GUIAnyP pnl
+    fromGUIAny (GUIAnyP pnl) = pnl
+    fromGUIAny _ = error "invalid GUIAny type"
+instance GUIWidget GUIPanel where
+    getBoundary pnl = case getChildren $ _panelContainer pnl of
+                           [] -> getBoundary $ _panelContainer pnl
+                           cs -> foldl1' determineSize $ map getBoundary cs
+      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 _ = "PNL"
+    
+-- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be
+--  provided by an appropriate 'MouseHanlder'.
+data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit
+                           , _widthB :: ScreenUnit, _heightB :: ScreenUnit
+                           , _priorityB :: Int
+                           , _actionB :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton)
+                           , _handlerStateB :: UIState
+                           } deriving ()
+
+instance Show GUIButton where
+    show w = "GUIButton {_screenXB = " ++ show (_screenXB w)
+                    ++ " _screenYB = " ++ show (_screenYB w)
+                    ++ " _widthB = " ++ show (_widthB w)
+                    ++ " _heightB = " ++ show (_heightB w)
+                    ++ " _priorityB = " ++ show (_screenYB w)
+                    ++ " _actionB = " ++ "***"
+                    ++ " _handlerStateB = " ++ show (_handlerStateB w)
+                    ++ "}"
+instance MouseHandler GUIButton GUIButton where
+    -- |Change 'UIState's '_uistateIsFiring' to @True@.
+    onMousePressed _ _ _ h = let
+        h' = h {_handlerStateB = (_handlerStateB h) {_uistateIsFiring = True}}
+        in return (h', h')
+
+    -- |Change 'UIState's '_uistateIsFiring' to @False@ and
+    --  call '_actionB' if inside the widget or
+    --  set '_uistateIsDeferred' to false otherwise.
+    onMouseReleased x y wg h =
+        if _uistateIsFiring (_handlerStateB h) then do
+            wg' <- _actionB h wg x y
+            wg'' <- return wg' {_handlerStateB = (_handlerStateB wg') {_uistateIsFiring = False}}
+            return (wg'', wg'')
+        else let
+            wg' = wg {_handlerStateB = (_handlerStateB wg) {_uistateIsDeferred = False}}
+            in return (wg', wg')
+    
+    -- |Do nothing.
+    onMouseMove _ _ wg h = return (wg, h)
+    
+    -- |Set 'UIState's '_uistateIsReady' to @True@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIState's '_uistateIsDeferred' to '_uistateIsFiring's current value
+    --   and set '_uistateIsFiring' to @False@. 
+    onMouseEnter _ _ _ h = let
+        s = _handlerStateB h
+        h' = h {_handlerStateB = s { _uistateIsFiring = _uistateIsDeferred s
+                                    , _uistateIsDeferred = False
+                                    , _uistateIsReady = True
+                                    }}
+        in return (h', h')
+    
+    -- |Set 'UIState's 'uistateIsReady' to @False@ and
+    --  update dragging state (only drag if inside widget).
+    --  In detail, change 'UIState's 'uistateIsFiring' to 'uistateIsDeferred's current value
+    --  and set 'uistateIsDeferred's' to @False@.
+    onMouseLeave _ _ _ h = let
+        s = _handlerStateB h
+        h' = h {_handlerStateB = s { _uistateIsFiring = False
+                                    , _uistateIsDeferred = _uistateIsFiring s
+                                    , _uistateIsReady = False
+                                    }}
+        in return (h', h')
+instance GUIAnyMap GUIButton where
+    guiAnyMap f (GUIAnyB btn) = f btn
+    guiAnyMap _ _ = error "invalid types in guiAnyMap"
+    toGUIAny btn = GUIAnyB btn
+    fromGUIAny (GUIAnyB btn) = btn
+    fromGUIAny _ = error "invalid GUIAny type"
+instance GUIWidget GUIButton where
+    getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn)
+    getChildren _ = []
+    getPriority btn = _priorityB btn
+    getShorthand _ = "BTN"