diff --git a/src/Main.hs b/src/Main.hs index 58c8da5..b189197 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -44,7 +44,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 @@ -65,15 +64,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 @@ -140,8 +141,7 @@ main = , _camera = cam' , _camStack = camStack' , _mouse = MouseState - { _isDown = False - , _isDragging = False + { _isDragging = False , _dragStartX = 0 , _dragStartY = 0 , _dragStartXAngle = 0 @@ -161,12 +161,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." diff --git a/src/Types.hs b/src/Types.hs index 53b1175..6e1e463 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -62,8 +62,7 @@ data GameState = GameState } data MouseState = MouseState - { _isDown :: !Bool - , _isDragging :: !Bool + { _isDragging :: !Bool , _dragStartX :: !Double , _dragStartY :: !Double , _dragStartXAngle :: !Double @@ -172,9 +171,10 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool - , _uiMap :: Map.HashMap UIId (GUIWidget Pioneers) - , _uiRoots :: [UIId] - , _uiButtonState :: UIButtonState + , _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers)) + , _uiObserverEvents :: !(Map.HashMap EventKey [EventHandler Pioneers]) + , _uiRoots :: !([UIId]) + , _uiButtonState :: !UIButtonState } data State = State diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index 6b5d7f3..62bf672 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -3,17 +3,17 @@ 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) import qualified Data.HashMap.Strict as Map -import Data.List (foldl') +--import Data.List (foldl') 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, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0) - , (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 @@ -103,40 +110,15 @@ eventCallback e = do _ -> return () SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel - do - state <- get - if state ^. mouse.isDown && not (state ^. mouse.isDragging) - then - do - cam <- liftIO $ readTVarIO (state ^. camera) - modify $ (mouse.isDragging .~ True) - . (mouse.dragStartX .~ fromIntegral x) - . (mouse.dragStartY .~ fromIntegral y) - . (mouse.dragStartXAngle .~ (cam ^. xAngle)) - . (mouse.dragStartYAngle .~ (cam ^. yAngle)) - else mouseMoveHandler (x, y) - modify $ (mouse.mousePosition. Types._x .~ fromIntegral x) - . (mouse.mousePosition. Types._y .~ fromIntegral y) + mouseMoveHandler (x, y) + SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt - do - case button of - SDL.LeftButton -> do - let pressed = state == SDL.Pressed - modify $ mouse.isDown .~ pressed - if pressed - then mouseReleaseHandler LeftButton (x, y) - else do - st <- get - if st ^. mouse.isDragging then - modify $ mouse.isDragging .~ False - else do - mousePressHandler LeftButton (x, y) - _ -> case state of - SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button - SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button - _ -> return () + case state of + SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button + SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button + _ -> return () SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll - do + do -- TODO: MouseWheelHandler state <- get liftIO $ atomically $ do cam <- readTVar (state ^. camera) @@ -150,7 +132,18 @@ eventCallback e = do _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] -mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> 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 @@ -160,7 +153,7 @@ mouseButtonHandler transFunc btn px = do Just (wid, px') -> do let target = toGUIAny hMap wid target' <- case target ^. eventHandlers.(at MouseEvent) of - Just ma -> transFunc ma btn (px -: px') target + Just ma -> transFunc ma btn (px -: px') (state ^. ui.uiButtonState.mouseInside) target Nothing -> return target modify $ ui.uiMap %~ Map.insert wid target' return () @@ -229,7 +222,9 @@ mouseSetLeaving wid px = do modify $ ui.uiButtonState.mouseInside .~ False case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? Just ma -> do - target' <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust + target_ <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust + target' <- if state ^. ui.uiButtonState.mousePressed <= 0 then return target_ + else fromJust (ma ^? onMouseMove) px target_ --TODO unsafe fromJust modify $ ui.uiMap %~ Map.insert wid target' Nothing -> return () @@ -245,7 +240,7 @@ mouseMoveHandler px = do Left b -> -- no child hit if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? - Just ma -> do target' <- fromJust (ma ^? onMouseMove) px' target + Just ma -> do target' <- fromJust (ma ^? onMouseMove) (px -: px') target modify $ ui.uiMap %~ Map.insert wid target' Nothing -> return () else if b then -- && not mouseInside --> entering @@ -269,36 +264,6 @@ mouseMoveHandler px = do mouseSetMouseActive px --- | Handler for UI-Inputs. --- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ... -clickHandler :: MouseButton -> Pixel -> Pioneers () -clickHandler btn pos@(x,y) = do - roots <- getRootIds - hits <- liftM concat $ mapM (getInsideId pos) roots - case hits of - [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"] - _ -> do - changes <- mapM (\(uid, pos') -> do - state <- get - let w = toGUIAny (state ^. ui.uiMap) uid - short = w ^. baseProperties.shorthand - bound <- w ^. baseProperties.boundary - prio <- w ^. baseProperties.priority - liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " " - ++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]" - case w ^. eventHandlers.(at MouseEvent) of - Just ma -> do w' <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust - w'' <- fromJust (ma ^? onMouseRelease) btn pos' w' -- TODO unsafe fromJust - return $ Just (uid, w'') - Nothing -> return Nothing - ) hits - state <- get - let hMap = state ^. ui.uiMap - newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes - modify $ ui.uiMap .~ newMap - return () - - -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture -- --TODO: should be done asynchronously at one point. @@ -320,7 +285,7 @@ prepareGUI = do modify $ ui.uiHasChanged .~ False --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. -copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset +copyGUI :: GL.TextureObject -> Pixel -- ^current view’s offset -> GUIWidget Pioneers -- ^the widget to draw -> Pioneers () copyGUI tex (vX, vY) widget = do @@ -332,6 +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,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 9ca3cc5..f3ad69e 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -1,12 +1,12 @@ -{-# 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 import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses) -import Control.Monad (liftM) +import Control.Monad (join,liftM) import Data.Array -import Data.Bits (xor) +import Data.Bits (xor) import Data.Hashable import qualified Data.HashMap.Strict as Map import Data.Ix () @@ -16,7 +16,7 @@ import GHC.Generics (Generic) -- |Unit of screen/window type ScreenUnit = Int --- | @x@ and @y@ position on screen. +-- | @x@ and @y@ position on screen. type Pixel = (ScreenUnit, ScreenUnit) -- |Combines two tuples element-wise. Designed for use with 'Pixel'. @@ -24,7 +24,7 @@ merge :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) merge f (x, y) (x', y') = (f x x', f y y') {-# INLINABLE merge #-} --- |Maps the over the elements of a tuple. Designed for use with 'Pixel'. +-- |Maps over the elements of a tuple. Designed for use with 'Pixel'. (>:) :: (a -> b) -> (a, a) -> (b, b) f >: (x, y) = (f x, f y) {-# INLINABLE (>:) #-} @@ -65,7 +65,7 @@ instance Hashable MouseButton where -- TODO: generic deriving creates functions -- |A key to reference a specific type of 'WidgetState'. data WidgetStateKey = MouseStateKey deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) - + instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever hash = fromEnum hashWithSalt salt x = (salt * 16777619) `xor` hash x @@ -86,9 +86,9 @@ data MouseButtonState = MouseButtonState , _mouseIsDeferred :: Bool -- ^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. -data WidgetState = + +-- |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 { _mouseStates :: Array MouseButton MouseButtonState @@ -101,79 +101,112 @@ 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 = - -- |Handler to control the functionality of a 'GUIWidget' on mouse button events. +-- |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. MouseHandler { -- |The function 'onMousePressed' is called when a button is pressed - -- while the widget is mouse-active. - -- - -- A widget becomes mouse-active if no other button is currently pressed and the mouse - -- coordinates are within the widget's extent ('isInside') until no button is pressed any - -- more. - _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 + -- while the button is mouse-active. + -- + -- The boolean value indicates if the button press happened within the widget + -- ('_isInside'). + -- + -- The function returns the altered widget resulting from the button press. + _onMousePress :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseReleased' is called when a button is released -- while the widget is mouse-active. -- -- 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 boolean value indicates if the button release happened within the widget + -- ('_isInside'). + -- + -- The function returns the altered widget resulting from the button press. + _onMouseRelease :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m) } | - -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. + -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. + -- + -- All screen coordinates are widget-local coordinates. MouseMotionHandler { -- |The function 'onMouseMove' is invoked when the mouse is moved inside the - -- widget's extent ('isInside') while no button is pressed or when the mouse is inside the - -- widget's extent while another button loses its mouse-active state. Triggered after - -- '_onMouseEnter'. - _onMouseMove :: Pixel -- screen position - -> GUIWidget m -- widget the event is invoked on - -> m (GUIWidget m) -- widget after the event and the altered handler + -- widget’s extent ('isInside') while no button is pressed or when the mouse is inside the + -- widget’s extent while another button loses its mouse-active state. Triggered after + -- '_onMouseEnter' or '_onMouseLeave' (only if still mouse-active on leaving) if applicable. + -- + -- The function returns the altered widget resulting from the button press. + _onMouseMove :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseMove' is invoked when the mouse enters the - -- widget's extent ('isInside') or when the mouse is inside the - -- widget's extent while another button loses its mouse-active state.. - _onMouseEnter :: Pixel -- screen position - -> GUIWidget m -- widget the event is invoked on - -> m (GUIWidget m) -- widget after the event and the altered handler + -- widget’s extent ('isInside') or when the mouse is inside the + -- widget’s extent while another button loses its mouse-active state. + -- + -- The function returns the altered widget resulting from the button press. + _onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m) , -- |The function 'onMouseLeave' is invoked when the mouse leaves the - -- widget's extent ('isInside') while no other widget is mouse-active. - _onMouseLeave :: Pixel -- screen position - -> GUIWidget m -- widget the event is invoked on - -> m (GUIWidget m) -- widget after the event and the altered handler + -- widget’s extent ('isInside') while no other widget is mouse-active. + -- + -- The function returns the altered widget resulting from the button press. + _onMouseLeave :: Pixel -> GUIWidget m -> m (GUIWidget 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 --------------------------- --- |A @GUIWidget@ is a visual object the HUD is composed of. +-- |A @GUIWidget@ is a visual object the HUD is composed of. 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'. @@ -186,18 +219,18 @@ data GUIBaseProperties m = BaseProperties , -- |The @_getChildren@ function returns all children associated with this widget. -- - -- All children must be wholly inside the parent's bounding box specified by '_boundary'. + -- 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 -- local coordinates - -> m Bool + -- + -- The passed coordinates are widget-local coordinates. + _isInside :: GUIWidget m -> Pixel -> 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. @@ -212,105 +245,140 @@ 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) +-- |Creates a default @MouseButtonState@. initialButtonState :: MouseButtonState initialButtonState = MouseButtonState False False {-# INLINE initialButtonState #-} --- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@ --- provided in the passed list. +-- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'. initialMouseState :: WidgetState initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)]) False (0, 0) {-# INLINE initialMouseState #-} --- TODO: combined mouse handler +-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions +-- of two handlers. Thereby, the resulting widget of the first handler is the input widget of the +-- 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) => 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 WidgetEventHandler" ++ + " with constructor MouseHandler" + +-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action +-- functions of two handlers. Thereby, the resulting widget of the second handler is the input +-- 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) => 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 WidgetEventHandler" ++ + " with constructor MouseMotionHandler" + +-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing. +-- It may be useful as construction kit. +-- +-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction +-- >>> emptyMouseHandler { _onMousePress = myPressFunction } +emptyMouseHandler :: (Monad m) => WidgetEventHandler m +emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return) + +-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing. +-- It may be useful as construction kit. +-- +-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction +-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction } +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, +-- |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@. - press' b _ w = + where + -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@. + press' b _ _ w = return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True - -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@. - release' b _ w = + -- |Change 'MouseButtonState'’s '_mouseIsDragging' and '_mouseIsDeferred' to @False@. + release' b _ _ w = return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~ (mouseIsDragging .~ False) . (mouseIsDeferred .~ False) --- |Creates a 'MouseHandler' that sets a widget's 'WidgetState MouseState' properties if present, +-- |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. move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p - - -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current - -- value and sets '_mouseIsDragging' to @False@. + + -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging'’s current + -- value and sets '_mouseIsDragging' to @False@. enter' p w = return $ w & widgetStates.(ix MouseStateKey) %~ (mouseIsReady .~ True) . (mousePixel .~ p) . (mouseStates.mapped %~ (mouseIsDeferred .~ False) -- following line executed BEFORE above line . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred))) - - - -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current - -- value and sets '_mouseIsDeferred' to @False@. + + + -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred'’s current + -- value and sets '_mouseIsDeferred' to @False@. leave' p w = return $ w & widgetStates.(ix MouseStateKey) %~ (mouseIsReady .~ False) . (mousePixel .~ p) . (mouseStates.mapped %~ (mouseIsDragging .~ False) -- following line executed BEFORE above line . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging))) --- TODO: make only fire if press started within widget --- |Creates a MouseHandler that reacts on mouse clicks. +-- TODO: make only fire if press started within widget +-- |Creates a 'MouseHandler' that reacts on mouse clicks. -- --- Does /not/ update 'WidgetState MouseState'! +-- 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 + where + press' _ _ _ = return - release' b p w = do fire <- (w ^. baseProperties.isInside) w p - if fire then a b w p else return w + release' b p inside w = if inside then a b w p else return w -- TODO: make only fire if press started within widget --- |Creates a MouseHandler that reacts on mouse clicks. --- --- Does /not/ update 'WidgetState MouseState'! +-- |Creates a 'MouseHandler' that reacts on mouse clicks. +-- +-- 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 + where + press' _ _ _ = return - release' b p w = do fire <- liftM (b == btn &&) $ (w ^. baseProperties.isInside) w p - if fire then a w p else return w + 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) extractExtent (_,_,w,h) = (w,h) {-# INLINABLE extractExtent #-} --- |Calculates whether a point's value exceed the given width and height. +-- |Calculates whether a point’s value exceed the given width and height. isInsideExtent :: (ScreenUnit, ScreenUnit) -> Pixel -> Bool isInsideExtent (w,h) (x',y') = (x' <= w) && (x' >= 0) && (y' <= h) && (y' >= 0) diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 4f0ad2e..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,9 +31,44 @@ 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. +-- specific screen position and the pixel’s local coordinates. -- -- 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 @@ -46,7 +83,7 @@ getInsideId px uid = do (bX, bY, _, _) <- wg ^. baseProperties.boundary let px' = px -: (bX, bY) inside <- isInsideFast wg px' - if inside -- test inside parent's bounding box + if inside -- test inside parent’s bounding box then do childrenIds <- wg ^. baseProperties.children hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index 4226e56..9ab9215 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -2,16 +2,18 @@ module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where -import Control.Lens ((^.), (.~), (&)) +import Control.Concurrent.STM.TVar (readTVarIO) +import Control.Lens ((^.), (.~), (%~), (&)) import Control.Monad ---import Control.Monad.IO.Class -- MonadIO -import Control.Monad.RWS.Strict (get) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.RWS.Strict (get, modify) import Data.List import Data.Maybe 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 @@ -43,3 +45,54 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN") emptyGraphics (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers + +createViewport :: MouseButton -- ^ button to drag with + -> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers +createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") + emptyGraphics + Map.empty -- widget states + (Map.fromList [(MouseEvent, viewportMouseAction) + ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers + where + viewportMouseAction :: WidgetEventHandler Pioneers + viewportMouseAction = + let press btn' (x, y) _ w = + do when (btn == btn') $ do + state <- get + cam <- liftIO $ readTVarIO (state ^. camera) + modify $ mouse %~ (isDragging .~ True) + . (dragStartX .~ fromIntegral x) + . (dragStartY .~ fromIntegral y) + . (dragStartXAngle .~ (cam ^. xAngle)) + . (dragStartYAngle .~ (cam ^. yAngle)) + . (mousePosition.Types._x .~ fromIntegral x) + . (mousePosition.Types._y .~ fromIntegral y) + return w + release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False) + return w + in MouseHandler press release + + viewportMouseMotionAction :: WidgetEventHandler Pioneers + viewportMouseMotionAction = + let move (x, y) w = + do state <- get + when (state ^. mouse.isDragging) $ + modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x) + . (mousePosition.Types._y .~ fromIntegral y) + return w + 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