diff --git a/src/Main.hs b/src/Main.hs index 97ecde0..97ad62b 100644 --- a/src/Main.hs +++ b/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.WindowShown -- window should be visible - ,SDL.WindowResizable -- and resizable - ,SDL.WindowInputFocus -- focused (=> active) - ,SDL.WindowMouseFocus -- Mouse into it - --,WindowInputGrabbed-- never let go of input (KB/Mouse) - ] $ \window' -> do + SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight) + [SDL.WindowOpengl -- we want openGL + ,SDL.WindowShown -- window should be visible + ,SDL.WindowResizable -- and resizable + ,SDL.WindowInputFocus -- focused (=> active) + ,SDL.WindowMouseFocus -- Mouse into it + --,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 - { _uiHasChanged = True - , _uiMap = guiMap - , _uiRoots = guiRoots - , _uiButtonState = UI.UIButtonState 0 Nothing False - } + , _ui = createGUI initialWidth initialHeight } 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 diff --git a/src/Types.hs b/src/Types.hs index 0e1800c..2ed3da7 100644 --- a/src/Types.hs +++ b/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 } diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index a13f7bb..62bf672 100644 --- a/src/UI/Callbacks.hs +++ b/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 = (Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize - , (UIId 1, createContainer (30, 215, 100, 80) [] 1) - , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3) - , (UIId 3, createContainer (80, 15, 130, 90) [] 4 ) - , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage) - ], [UIId 0]) +createGUI :: ScreenUnit -> ScreenUnit -> UIState +createGUI w h = UIState + { _uiHasChanged = True + , _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize + , (UIId 1, createContainer (30, 215, 100, 80) [] 1) + , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3) + , (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 - -- TODO: resize GUI - return () + SDL.Window _ ev -> -- windowID event + case ev of + 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] diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index 9453c7f..82d3955 100644 --- a/src/UI/UIBase.hs +++ b/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'. -data EventKey = MouseEvent | MouseMotionEvent +-- |A key to reference a specific 'WidgetEventHandler'. +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. -data EventHandler m = +-- |A handler to react on certain events. Corresponding key: 'WidgetEventKey'. +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 - {temp :: m Int} +data GUIGraphics (m :: * -> *) = Graphics $(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) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index d790917..5824d3d 100644 --- a/src/UI/UIOperations.hs +++ b/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. diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index dcc6e58..9ab9215 100644 --- a/src/UI/UIWidgets.hs +++ b/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 \ No newline at end of file + 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) + + + \ No newline at end of file