Merge branch 'ui' into iqm
Conflicts: src/UI/UIBase.hs
This commit is contained in:
commit
e512149461
31
src/Main.hs
31
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."
|
||||
|
||||
10
src/Types.hs
10
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
|
||||
|
||||
@ -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]
|
||||
|
||||
252
src/UI/UIBase.hs
252
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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user