introducing window resize event, main viewport resizing to actual window size

src/Main.hs

@@ -45,7 +45,6 @@ import           UI.Callbacks
 import           Map.Graphics
 import           Map.Creation                          (exportedMap)
 import           Types
-import qualified UI.UIBase as UI
 import           Importer.IQM.Parser
 --import           Data.Attoparsec.Char8 (parseTest)
 --import qualified Data.ByteString as B
@@ -66,15 +65,18 @@ testParser a = print  =<< parseIQM a
 --------------------------------------------------------------------------------
 
 main :: IO ()
-main =
+main = do
+    let initialWidth = 1024
+        initialHeight = 600
     SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
-      SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl     -- we want openGL
+      SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight)
-                                                                             ,SDL.WindowShown      -- window should be visible
+          [SDL.WindowOpengl     -- we want openGL
-                                                                             ,SDL.WindowResizable  -- and resizable
+          ,SDL.WindowShown      -- window should be visible
-                                                                             ,SDL.WindowInputFocus -- focused (=> active)
+          ,SDL.WindowResizable  -- and resizable
-                                                                             ,SDL.WindowMouseFocus -- Mouse into it
+          ,SDL.WindowInputFocus -- focused (=> active)
-                                                                             --,WindowInputGrabbed-- never let go of input (KB/Mouse)
+          ,SDL.WindowMouseFocus -- Mouse into it
-                                                                             ] $ \window' -> do
+          --,WindowInputGrabbed-- never let go of input (KB/Mouse)
+          ] $ \window' -> do
        SDL.withOpenGL window' $ do
 
         --Create Renderbuffer & Framebuffer
@@ -114,7 +116,6 @@ main =
         let zDistClosest'  = 2
             zDistFarthest' = zDistClosest' + 10
             --TODO: Move near/far/fov to state for runtime-changability & central storage
-            (guiMap, guiRoots) = createGUI
             aks = ArrowKeyState {
                   _up       = False
                 , _down     = False
@@ -159,12 +160,7 @@ main =
                         , _glFramebuffer       = frameBuffer
                         }
               , _game                = game'
-              , _ui                  = UIState
+              , _ui                  = createGUI initialWidth initialHeight
-                        { _uiHasChanged        = True
-                        , _uiMap = guiMap
-                        , _uiRoots = guiRoots
-                        , _uiButtonState = UI.UIButtonState 0 Nothing False
-                        }
               }
 
         putStrLn "init done."
@@ -243,7 +239,7 @@ run = do
 		targetFrametime = 1.0/targetFramerate
 		--targetFrametimeμs = targetFrametime * 1000000.0
         now <- getCurrentTime
-        let diff  = max 0.1 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
+        let diff  = diffUTCTime now (state ^. io.clock) -- get time-diffs
             title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
             ddiff = double diff
         SDL.setWindowTitle (env ^. windowObject) title

src/Types.hs

@@ -155,6 +155,7 @@ data GLState = GLState
 data UIState = UIState
     { _uiHasChanged        :: !Bool
     , _uiMap               :: !(Map.HashMap UIId (GUIWidget Pioneers))
+    , _uiObserverEvents    :: !(Map.HashMap EventKey [EventHandler Pioneers])
     , _uiRoots             :: !([UIId])
     , _uiButtonState       :: !UIButtonState
     }

src/UI/Callbacks.hs

@@ -3,7 +3,7 @@ module UI.Callbacks where
 
 
 import qualified Graphics.Rendering.OpenGL.GL         as GL
-import           Control.Lens                         ((^.), (.~), (%~), (^?), at)
+import           Control.Lens                         ((^.), (.~), (%~), (^?), at, ix)
 import           Control.Monad                        (liftM, when, unless)
 import           Control.Monad.RWS.Strict             (ask, get, modify)
 import           Control.Monad.Trans                  (liftIO)
@@ -13,7 +13,7 @@ import           Data.Maybe
 import           Foreign.Marshal.Array                (pokeArray)
 import           Foreign.Marshal.Alloc                (allocaBytes)
 import qualified Graphics.UI.SDL                      as SDL
-import           Control.Concurrent.STM.TVar          (readTVar, readTVarIO, writeTVar)
+import           Control.Concurrent.STM.TVar          (readTVar, writeTVar)
 import           Control.Concurrent.STM               (atomically)
 
 
@@ -23,13 +23,19 @@ import UI.UIWidgets
 import UI.UIOperations
 
 -- TODO: define GUI positions in a file
-createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
+createGUI :: ScreenUnit -> ScreenUnit -> UIState
-createGUI = (Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize
+createGUI w h = UIState
-                          , (UIId 1, createContainer (30, 215, 100, 80) [] 1)
+    { _uiHasChanged     = True
-                          , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
+    , _uiMap            = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize
-                          , (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
+                                       , (UIId 1, createContainer (30, 215, 100, 80) [] 1)
-                          , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
+                                       , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
-                          ], [UIId 0])
+                                       , (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
+                                       , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
+                                       ]
+    , _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
+    , _uiRoots          = [UIId 0]
+    , _uiButtonState    = UIButtonState 0 Nothing False
+    }
          
 getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
 getGUI = Map.elems
@@ -69,9 +75,10 @@ eventCallback :: SDL.Event -> Pioneers ()
 eventCallback e = do
         env <- ask
         case SDL.eventData e of
-            SDL.Window _ _ -> -- windowID event
+            SDL.Window _ ev -> -- windowID event
-                -- TODO: resize GUI
+                case ev of
-                return ()
+                     SDL.Resized (SDL.Size x y) -> windowResizeHandler x y
+                     _ -> return ()
             SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
                      -- need modifiers? use "keyModifiers key" to get them
                 let aks = keyboard.arrowsPressed in
@@ -125,7 +132,18 @@ eventCallback e = do
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
 
 
-mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
+windowResizeHandler :: ScreenUnit -> ScreenUnit -> Pioneers ()
+windowResizeHandler x y = do
+    state <- get
+    case state ^. ui.uiObserverEvents.(at WindowEvent) of
+         Just evs -> let handle :: EventHandler Pioneers -> Pioneers (EventHandler Pioneers)
+                         handle (WindowHandler h _) = h x y
+                         handle h = return h -- TODO: may log invalid event mapping
+           in do newEvs <- mapM handle evs
+                 modify $ ui.uiObserverEvents.(ix WindowEvent) .~ newEvs
+         Nothing -> return ()
+
+mouseButtonHandler :: (WidgetEventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
                    -> MouseButton -> Pixel -> Pioneers ()
 mouseButtonHandler transFunc btn px = do
     state <- get
@@ -279,7 +297,7 @@ copyGUI tex (vX, vY) widget = do
                             --temporary color here. lateron better some getData-function to
                             --get a list of pixel-data or a texture.
                             color = case widget ^. baseProperties.shorthand of
-                                "VWP" -> [0,128,128,30]
+                                "VWP" -> [0,128,128,0]
                                 "CNT" -> [255,0,0,128]
                                 "BTN" -> [255,255,0,255]
                                 "PNL" -> [128,128,128,128]

src/UI/UIBase.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-}
 -- 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
@@ -87,7 +87,7 @@ data MouseButtonState = MouseButtonState
       -- ^deferred if e. g. dragging but outside component
     } deriving (Eq, Show)
     
--- |An applied state a widget may take, depending on its usage and event handlers.
+-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'. 
 data WidgetState = 
     -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
     MouseState
@@ -101,18 +101,18 @@ data WidgetState =
 --- events
 ---------------------------
 
--- |A key to reference a specific 'EventHandler'.
+-- |A key to reference a specific 'WidgetEventHandler'.
-data EventKey = MouseEvent | MouseMotionEvent
+data WidgetEventKey = MouseEvent | MouseMotionEvent
     deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
     
-instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
+instance Hashable WidgetEventKey where -- TODO: generic deriving creates functions that run forever
     hash = fromEnum
     hashWithSalt salt x = (salt * 16777619)  `xor` hash x
 
 --- event handlers
 
--- |A handler to react on certain events.
+-- |A handler to react on certain events. Corresponding key: 'WidgetEventKey'.
-data EventHandler m = 
+data WidgetEventHandler m = 
     -- |Handler to control the functionality of a 'GUIWidget' on mouse button events.
     --  
     --  All screen coordinates are widget-local coordinates.
@@ -168,6 +168,34 @@ data EventHandler m =
         }
     deriving ()
 
+-- |A key to reference a specific 'EventHandler'.
+data EventKey = WindowEvent | WidgetPositionEvent 
+    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
+
+instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
+    hash = fromEnum
+    hashWithSalt salt x = (salt * 16777619)  `xor` hash x
+
+ -- |A handler to react on certain events. Corresponding key: 'EventKey'.
+data EventHandler (m :: * -> *) = 
+    WindowHandler
+        {
+        -- |The function '_onWindowResize' is invoked when the global application window changes size.
+        --  
+        --  The input is the window’s new width and height in that order.
+        --  
+        --  The returned handler is resulting handler that may change by the event. Its type must
+        --  remain @WindowHandler@. 
+        _onWindowResize :: ScreenUnit -> ScreenUnit -> m (EventHandler m)
+        ,
+        -- |Unique id to identify an event instance.
+        _eventId :: UIId
+        }
+    
+instance Eq (EventHandler m) where
+    WindowHandler _ id' == WindowHandler _ id'' = id' == id''
+    _ == _ = False
+
 
 ---------------------------
 --- widgets
@@ -178,7 +206,7 @@ data GUIWidget m = Widget
     {_baseProperties :: GUIBaseProperties m
     ,_graphics :: GUIGraphics m
     ,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
-    ,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key
+    ,_eventHandlers :: Map.HashMap WidgetEventKey (WidgetEventHandler m) -- no guarantee that data match key
     }
 
 -- |Base properties are fundamental settings of any 'GUIWidget'.
@@ -217,13 +245,12 @@ data GUIBaseProperties m = BaseProperties
 
 -- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
 
-data GUIGraphics m = Graphics 
+data GUIGraphics (m :: * -> *) = Graphics
-    {temp :: m Int}
 
 $(makeLenses ''UIButtonState)
 $(makeLenses ''WidgetState)
 $(makeLenses ''MouseButtonState)
-$(makeLenses ''EventHandler)
+$(makeLenses ''WidgetEventHandler)
 $(makeLenses ''GUIWidget)
 $(makeLenses ''GUIBaseProperties)
 $(makeLenses ''GUIGraphics)
@@ -244,11 +271,11 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta
 --  second handler and all other parameters are the same for both function calls.
 --  
 --  If not both input handlers are of type @MouseHandler@ an error is raised.
-combinedMouseHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m
+combinedMouseHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
 combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) =
     MouseHandler (comb p1 p2) (comb r1 r2)
   where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside
-combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two EventHandler" ++
+combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two WidgetEventHandler" ++
     " with constructor MouseHandler"
 
 -- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action
@@ -256,11 +283,11 @@ combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two Eve
 --  widget of the second handler and all other parameters are the same for both function calls.
 --  
 --  If not both input handlers are of type @MouseMotionHandler@ an error is raised.
-combinedMouseMotionHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m
+combinedMouseMotionHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
 combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) =
     MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2)
   where comb h1 h2 px = join . liftM (h2 px) . h1 px
-combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two EventHandler" ++
+combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two WidgetEventHandler" ++
     " with constructor MouseMotionHandler" 
 
 -- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing.
@@ -268,7 +295,7 @@ combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only com
 --  
 --  >>> emptyMouseHandler & _onMousePress .~ myPressFunction
 --  >>> emptyMouseHandler { _onMousePress = myPressFunction }
-emptyMouseHandler :: (Monad m) => EventHandler m
+emptyMouseHandler :: (Monad m) => WidgetEventHandler m
 emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
 
 -- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing.
@@ -276,13 +303,13 @@ emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
 --  
 --  >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction
 --  >>> emptyMouseHandler { _onMouseMove = myMoveFunction }
-emptyMouseMotionHandler :: (Monad m) => EventHandler m
+emptyMouseMotionHandler :: (Monad m) => WidgetEventHandler m
 emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return)
 
 -- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export
 -- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present,
 --  only fully functional in conjunction with 'setMouseMotionStateActions'.
-setMouseStateActions :: (Monad m) => EventHandler m
+setMouseStateActions :: (Monad m) => WidgetEventHandler m
 setMouseStateActions = MouseHandler press' release'
   where 
     -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@.
@@ -296,7 +323,7 @@ setMouseStateActions = MouseHandler press' release'
 
 -- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present,
 --  only fully functional in conjunction with 'setMouseStateActions'.
-setMouseMotionStateActions :: (Monad m) => EventHandler m
+setMouseMotionStateActions :: (Monad m) => WidgetEventHandler m
 setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
   where
     -- |Updates mouse position.
@@ -324,7 +351,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
 -- 
 --  Does /not/ update the widget’s 'MouseState'!
 buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-                                -> EventHandler m
+                                -> WidgetEventHandler m
 buttonMouseActions a = MouseHandler press' release'
   where 
     press' _ _ _ = return
@@ -336,7 +363,7 @@ buttonMouseActions a = MouseHandler press' release'
 -- 
 --  Does /not/ update the widget’s 'MouseState'!
 buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-                                      -> MouseButton -> EventHandler m
+                                      -> MouseButton -> WidgetEventHandler m
 buttonSingleMouseActions a btn = MouseHandler press' release'
   where 
     press' _ _ _ = return
@@ -344,7 +371,7 @@ buttonSingleMouseActions a btn = MouseHandler press' release'
     release' b p inside w = if inside && b == btn then a w p else return w
 
 emptyGraphics :: (Monad m) => GUIGraphics m
-emptyGraphics = Graphics (return 3)
+emptyGraphics = Graphics
 
 -- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
 extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit)

src/UI/UIOperations.hs

@@ -1,10 +1,12 @@
 module UI.UIOperations where
 
-import           Control.Lens                    ((^.))
+import           Control.Lens                    ((^.), (%~))
 import           Control.Monad                   (liftM)
 --import           Control.Monad.IO.Class          (liftIO)
-import           Control.Monad.RWS.Strict        (get)
+import           Control.Monad.RWS.Strict        (get, modify)
 import qualified Data.HashMap.Strict             as Map
+import           Data.Hashable
+--import qualified Data.List                       as L
 import           Data.Maybe
 
 import Types
@@ -29,6 +31,41 @@ isInsideFast wg px = do
   (_, _, w, h) <- wg ^. baseProperties.boundary
   liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
 
+-- |Adds an event to the given map. The new event is concatenated to present events. Does not test
+--  if the map already contains the given element.
+addEvent :: (Eq k, Hashable k) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
+addEvent k v eventMap = Map.insertWith (++) k [v] eventMap
+
+-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
+registerEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
+registerEvent k v = modify  $ ui.uiObserverEvents %~ addEvent k v
+
+-- |The 'deleteQualitative' function behaves like 'Data.List.deleteBy' but reports @True@ if the
+--  list contained the relevant object.
+deleteQualitative :: (a -> a -> Bool) -> a -> [a] -> ([a], Bool)
+deleteQualitative _  _ [] = ([], False)
+deleteQualitative eq x (y:ys)    = if x `eq` y then (ys, True) else
+    let (zs, b) = deleteQualitative eq x ys
+    in (y:zs, b)
+
+-- |Removes the first occurrence of an event from the given map if it is within the event list of
+--  the key.
+removeEvent :: (Eq k, Hashable k, Eq v) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
+removeEvent k v eventMap =
+  case Map.lookup k eventMap of
+       Just list -> case deleteQualitative (==) v list of
+            (_, False) -> eventMap
+            (ys, _) -> case ys of
+                            [] -> Map.delete k eventMap 
+                            _  -> Map.insert k ys eventMap 
+       Nothing   -> Map.insert k [v] eventMap
+
+
+-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
+deregisterEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
+deregisterEvent k v = modify $ ui.uiObserverEvents %~ removeEvent k v
+
+
 
 -- |The function 'getInsideId' returns child widgets that overlap with a 
 --  specific screen position and the pixel’s local coordinates.

src/UI/UIWidgets.hs

@@ -13,6 +13,7 @@ import qualified Data.HashMap.Strict as Map
 
 import           Types
 import UI.UIBase
+import UI.UIOperations
 
 
 createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
@@ -53,7 +54,7 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
                                     (Map.fromList [(MouseEvent, viewportMouseAction)
                                                   ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
   where
-    viewportMouseAction :: EventHandler Pioneers
+    viewportMouseAction :: WidgetEventHandler Pioneers
     viewportMouseAction =
         let press btn' (x, y) _ w =
               do when (btn == btn') $ do
@@ -71,7 +72,7 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
                                     return w
         in MouseHandler press release
     
-    viewportMouseMotionAction :: EventHandler Pioneers
+    viewportMouseMotionAction :: WidgetEventHandler Pioneers
     viewportMouseMotionAction =
         let move (x, y) w =
               do state <- get
@@ -79,4 +80,19 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
                         modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
                                         . (mousePosition.Types._y .~ fromIntegral y)
                  return w
-        in emptyMouseMotionHandler & onMouseMove .~ move
+        in emptyMouseMotionHandler & onMouseMove .~ move
+        
+resizeToScreenHandler :: UIId -- ^id of a widget
+                      -> EventHandler Pioneers
+resizeToScreenHandler id' = WindowHandler resize (UIId 0) -- TODO: unique id
+  where resize :: ScreenUnit -> ScreenUnit -> Pioneers (EventHandler Pioneers)
+        resize w h = do
+            state <- get
+            let wg = toGUIAny (state ^. ui.uiMap) id'
+            (x, y, _, _) <- wg ^. baseProperties.boundary
+            let wg' = wg & baseProperties.boundary .~ return (x, y, w-x, h-y)
+            modify $ ui.uiMap %~ Map.insert id' wg'
+            return $ WindowHandler resize (UIId 0)
+            
+            
+