Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge branch 'ui'

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-05-10 11:19:31 +02:00
commit 6dcdb2eda2
4 changed files with 253 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
src/UI/Callbacks.hs
View File

@ -2,7 +2,7 @@ module UI.Callbacks where
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
import Control.Lens ((^.), (.~), (%~)) import Control.Lens ((^.), (.~), (%~), (^?), at)
import Control.Monad (liftM, when, unless) import Control.Monad (liftM, when, unless)
import Control.Monad.RWS.Strict (ask, get, modify) import Control.Monad.RWS.Strict (ask, get, modify)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
@ -19,13 +19,13 @@ import Types
import UI.UIWidgets import UI.UIWidgets
import UI.UIOperations import UI.UIOperations
-- TODO: define GUI positions in a file
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId]) createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0) createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
, (UIId 1, createContainer (20, 50, 120, 80) [] 1) , (UIId 1, createContainer (30, 215, 100, 80) [] 1)
, (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3) , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (100, 140, 130, 200) [] 4 ) , (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (30, 200, 60, 175) 2 testMessage) , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
], [UIId 0]) ], [UIId 0])
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers] getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
@ -89,12 +89,12 @@ eventCallback e = do
modify $ aks.down .~ (movement == SDL.KeyDown) modify $ aks.down .~ (movement == SDL.KeyDown)
SDL.KeypadPlus -> SDL.KeypadPlus ->
when (movement == SDL.KeyDown) $ do when (movement == SDL.KeyDown) $ do
modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1)) modify $ gl.glMap.stateTessellationFactor %~ (min 5) . (+1)
state <- get state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
SDL.KeypadMinus -> SDL.KeypadMinus ->
when (movement == SDL.KeyDown) $ do when (movement == SDL.KeyDown) $ do
modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1))) modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1))
state <- get state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
_ -> _ ->
@ -104,13 +104,13 @@ eventCallback e = do
state <- get state <- get
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
modify $ (mouse.isDragging .~ True) modify $ (mouse.isDragging .~ True)
. (mouse.dragStartX .~ (fromIntegral x)) . (mouse.dragStartX .~ fromIntegral x)
. (mouse.dragStartY .~ (fromIntegral y)) . (mouse.dragStartY .~ fromIntegral y)
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
. (mouse.mousePosition. Types._y .~ (fromIntegral y)) . (mouse.mousePosition. Types._y .~ fromIntegral y)
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
case button of case button of
SDL.LeftButton -> do SDL.LeftButton -> do
@ -122,13 +122,13 @@ eventCallback e = do
modify $ mouse.isDragging .~ False modify $ mouse.isDragging .~ False
else else
clickHandler LeftButton (x, y) clickHandler LeftButton (x, y)
_ -> do when (state == SDL.Released) _ -> when (state == SDL.Released)
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button $ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do do
state <- get state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist') modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
-- there is more (joystic, touchInterface, ...), but currently ignored -- there is more (joystic, touchInterface, ...), but currently ignored
SDL.Quit -> modify $ window.shouldClose .~ True SDL.Quit -> modify $ window.shouldClose .~ True
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] _ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
@ -145,19 +145,19 @@ clickHandler btn pos@(x,y) = do
case hits of case hits of
[] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"] [] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
_ -> do _ -> do
changes <- mapM (\uid -> do changes <- mapM (\(uid, pos') -> do
let w = toGUIAny hMap uid let w = toGUIAny hMap uid
short = w ^. baseProperties.shorthand short = w ^. baseProperties.shorthand
bound <- w ^. baseProperties.boundary bound <- w ^. baseProperties.boundary
prio <- w ^. baseProperties.priority prio <- w ^. baseProperties.priority
liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
++ " at [" ++ show x ++ "," ++ show y ++ "]" ++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
case w ^. mouseActions of case w ^. eventHandlers.(at MouseEvent) of
Just ma -> do w' <- (ma ^. onMousePress) btn pos w Just ma -> do w' <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
w'' <- (ma ^. onMouseRelease) btn pos w' w'' <- fromJust (ma ^? onMouseRelease) btn pos' True w' -- TODO unsafe fromJust
return $ Just (uid, w'') return $ Just (uid, w'')
Nothing -> return Nothing Nothing -> return Nothing
) $ hits ) hits
let newMap :: Map.HashMap UIId (GUIWidget Pioneers) let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
modify $ ui.uiMap .~ newMap modify $ ui.uiMap .~ newMap
@ -177,16 +177,18 @@ prepareGUI :: Pioneers ()
prepareGUI = do prepareGUI = do
state <- get state <- get
roots <- getRoots roots <- getRoots
let tex = (state ^. gl.glHud.hudTexture) let tex = state ^. gl.glHud.hudTexture
liftIO $ do liftIO $ do
-- bind texture - all later calls work on this one. -- bind texture - all later calls work on this one.
GL.textureBinding GL.Texture2D GL.$= Just tex GL.textureBinding GL.Texture2D GL.$= Just tex
mapM_ (copyGUI tex) roots mapM_ (copyGUI tex (0, 0)) roots
modify $ ui.uiHasChanged .~ False modify $ ui.uiHasChanged .~ False
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. --TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers () copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset
copyGUI tex widget = do -> GUIWidget Pioneers -- ^the widget to draw
-> Pioneers ()
copyGUI tex (vX, vY) widget = do
(xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary (xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
state <- get state <- get
let let
@ -205,11 +207,11 @@ copyGUI tex widget = do
GL.texSubImage2D GL.texSubImage2D
GL.Texture2D GL.Texture2D
0 0
(GL.TexturePosition2D (int xoff) (int yoff)) (GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff)))
(GL.TextureSize2D (int wWidth) (int wHeight)) (GL.TextureSize2D (int wWidth) (int wHeight))
(GL.PixelData GL.RGBA GL.UnsignedByte ptr) (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
nextChildrenIds <- widget ^. baseProperties.children nextChildrenIds <- widget ^. baseProperties.children
mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc. --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
--TODO: Maybe queues are better? --TODO: Maybe queues are better?

324
src/UI/UIBase.hs
View File

@ -3,12 +3,14 @@
-- TODO: exclude UIMouseState constructor from export? -- TODO: exclude UIMouseState constructor from export?
module UI.UIBase where module UI.UIBase where
import Control.Lens ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses) import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Array import Data.Array
import Data.Bits (xor)
import Data.Hashable import Data.Hashable
import qualified Data.HashMap.Strict as Map
import Data.Ix () import Data.Ix ()
import Data.Maybe -- import Data.Maybe
import GHC.Generics (Generic) import GHC.Generics (Generic)
-- |Unit of screen/window -- |Unit of screen/window
@ -17,48 +19,145 @@ type ScreenUnit = Int
-- | @x@ and @y@ position on screen. -- | @x@ and @y@ position on screen.
type Pixel = (ScreenUnit, ScreenUnit) type Pixel = (ScreenUnit, ScreenUnit)
-- |Combines two tuples element-wise. Designed for use with 'Pixel'.
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'.
(>:) :: (a -> b) -> (a, a) -> (b, b)
f >: (x, y) = (f x, f y)
{-# INLINABLE (>:) #-}
-- |Adds two numeric tuples component-wise.
(+:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
(+:) = merge (+)
{-# INLINABLE (+:) #-}
-- |Calculates the component-wise difference between two tuples.
(-:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
(-:) = merge (-)
{-# INLINABLE (-:) #-}
-- |Multiplies two numeric tuples component-wise.
(*:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
(*:) = merge (*)
{-# INLINABLE (*:) #-}
infixl 7 *:
infixl 6 +:, -:
infixl 5 >:
-- |Id to reference a specific widget, must be unique.
newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read) newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
-- |Mouse buttons processed by the program.
data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2 data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable MouseButton instance Hashable MouseButton where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
firstButton :: MouseButton ---------------------------
firstButton = LeftButton --- widget state
---------------------------
-- |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
lastButton :: MouseButton -- |The button dependant state of a 'MouseState'.
lastButton = MiddleButton data MouseButtonState = MouseButtonState
{ _mouseIsDragging :: Bool -- ^firing if pressed but not confirmed
-- |The button dependant state of a 'UIMouseState'.
data UIMouseStateSingle = MouseStateSingle
{ _mouseIsFiring :: Bool -- ^firing if pressed but not confirmed
, _mouseIsDeferred :: Bool , _mouseIsDeferred :: Bool
-- ^deferred if e. g. dragging but outside component -- ^deferred if e. g. dragging but outside component
} deriving (Eq, Show) } deriving (Eq, Show)
-- |An applied state a widget may take, depending on its usage and event handlers.
data WidgetState =
-- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
MouseState
{ _mouseStates :: Array MouseButton MouseButtonState
, _mouseIsReady :: Bool -- ^ready if mouse is above component
, _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component
}
deriving (Eq, Show)
-- |The state of a clickable ui widget. ---------------------------
data UIMouseState = MouseState --- events
{ _mouseStates :: Array MouseButton UIMouseStateSingle ---------------------------
, _mouseIsReady :: Bool -- ^ready if mouse is above component
} deriving (Eq, Show) -- |A key to reference a specific 'EventHandler'.
data EventKey = MouseEvent | MouseMotionEvent
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
--- event handlers
-- |A handler to react on certain events.
data EventHandler m =
-- |Handler to control the functionality of a 'GUIWidget' on mouse button events.
MouseHandler
{
-- |The function 'onMousePressed' is called when a button is pressed
-- while inside a screen coordinate within the widget ('isInside').
_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
,
-- |The function 'onMouseReleased' is called when a button is released
-- while the pressing event occured within the widget ('isInside').
--
-- Thus, the mouse is either within the widget or outside while still dragging.
_onMouseRelease :: MouseButton -- ^the released button
-> Pixel -- ^screen position
-> Bool -- ^@True@ if the event occured inside the widget
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
}
|
-- |Handler to control the functionality of a 'GUIWidget' on mouse movement.
MouseMotionHandler
{
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-- widget's space ('isInside').
_onMouseMove :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse enters the
-- widget's space ('isInside').
_onMouseEnter :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse leaves the
-- widget's space ('isInside').
_onMouseLeave :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
}
deriving ()
-- |Switches primary and secondary mouse actions. ---------------------------
-- "monad type" "widget type" "original handler" --- widgets
data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show) ---------------------------
-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
data ButtonHandler m w = ButtonHandler
{ _action :: w -> Pixel -> m w }
instance Show (ButtonHandler m w) where
show _ = "ButtonHandler ***"
-- |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 data GUIWidget m = Widget
{_baseProperties :: GUIBaseProperties m {_baseProperties :: GUIBaseProperties m
,_mouseActions :: Maybe (GUIMouseActions m)
,_graphics :: GUIGraphics m ,_graphics :: GUIGraphics m
,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key
} }
-- |Base properties are fundamental settings of any 'GUIWidget'. -- |Base properties are fundamental settings of any 'GUIWidget'.
@ -93,46 +192,6 @@ data GUIBaseProperties m = BaseProperties
_shorthand :: String _shorthand :: String
} }
-- |Mouse actions control the functionality of a 'GUIWidget' on mouse events.
data GUIMouseActions m = MouseActions
{
-- |The @_mouseState@ function returns the current mouse state of a widget.
_mouseState :: UIMouseState
,
-- |The function 'onMousePressed' is called when a button is pressed
-- while inside a screen coordinate within the widget ('isInside').
_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
,
-- |The function 'onMouseReleased' is called when a button is released
-- while the pressing event occured within the widget ('isInside').
--
-- Thus, the mouse is either within the widget or outside while still dragging.
_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 function 'onMouseMove' is invoked when the mouse is moved inside the
-- widget's space ('isInside').
_onMouseMove :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse enters the
-- widget's space ('isInside').
_onMouseEnter :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse leaves the
-- widget's space ('isInside').
_onMouseLeave :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
}
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'. -- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
@ -140,93 +199,112 @@ data GUIMouseActions m = MouseActions
data GUIGraphics m = Graphics data GUIGraphics m = Graphics
{temp :: m Int} {temp :: m Int}
$(makeLenses ''UIMouseState) $(makeLenses ''WidgetStateKey)
$(makeLenses ''UIMouseStateSingle) $(makeLenses ''WidgetState)
$(makeLenses ''MouseButtonState)
$(makeLenses ''EventKey)
$(makeLenses ''EventHandler)
$(makeLenses ''GUIWidget) $(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties) $(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIMouseActions)
$(makeLenses ''GUIGraphics) $(makeLenses ''GUIGraphics)
initialMouseStateS :: UIMouseStateSingle initialButtonState :: MouseButtonState
initialMouseStateS = MouseStateSingle False False initialButtonState = MouseButtonState False False
{-# INLINE initialMouseStateS #-} {-# INLINE initialButtonState #-}
-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@ -- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
-- provided in the passed list. -- provided in the passed list.
initialMouseState :: UIMouseState initialMouseState :: WidgetState
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)]) initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
False False (0, 0)
{-# INLINE initialMouseState #-} {-# INLINE initialMouseState #-}
emptyMouseAction :: (Monad m) => GUIMouseActions m
emptyMouseAction = MouseActions initialMouseState empty'' empty'' empty' empty' empty'
where empty' _ = return
empty'' _ _ = return
-- TODO: combined mouse handler -- TODO: combined mouse handler
-- TODO? breaks if 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 @GUIMouseActions@ handler that enables button clicks. -- only fully functional in conjunction with 'setMouseMotionStateActions'.
-- setMouseStateActions :: (Monad m) => EventHandler m
-- The action is peformed right before the button state change. setMouseStateActions = MouseHandler press' release'
buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> GUIMouseActions m
buttonMouseActions a = MouseActions initialMouseState press' release' move' enter' leave'
where where
-- |Change 'UIMouseState's '_mouseIsFiring' to @True@. -- |Change 'MouseButtonState's '_mouseIsDragging' to @True@.
press' b _ w = press' b _ w =
return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
-- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and -- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
-- call action if '_mouseIsFiring' was @True@. release' b _ _ w =
release' b p w = return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly (mouseIsDragging .~ False) . (mouseIsDeferred .~ False)
in do w' <- if fire
then a b w p -- |Creates a 'MouseHandler' that sets a widget's 'WidgetState MouseState' properties if present,
else return w -- only fully functional in conjunction with 'setMouseStateActions'.
return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~ setMouseMotionStateActions :: (Monad m) => EventHandler m
(mouseIsFiring .~ False) . (mouseIsDeferred .~ False) setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
where
-- |Updates mouse position.
move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p
-- |Do nothing. -- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging's current
move' _ = return -- value and sets '_mouseIsDragging' to @False@.
enter' p w = return $ w & widgetStates.(ix MouseStateKey)
-- |Set 'UIMouseState's '_mouseIsReady' to @True@ and %~ (mouseIsReady .~ True) . (mousePixel .~ p)
-- update dragging state (only drag if inside widget). . (mouseStates.mapped %~ (mouseIsDeferred .~ False)
-- In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value -- following line executed BEFORE above line
-- and set '_mouseIsFiring' to @False@. . (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred)))
enter' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ True)
.(mouseStates.mapped %~ (mouseIsDeferred .~ False)
-- following line executed BEFORE above line
.(\sState -> sState & mouseIsFiring .~ not (sState ^. mouseIsDeferred)))
-- |Set 'UIMouseState's 'buttonstateIsReady' to @False@ and -- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current
-- update dragging state (only drag if inside widget). -- value and sets '_mouseIsDeferred' to @False@.
-- In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value leave' p w = return $ w & widgetStates.(ix MouseStateKey)
-- and set '_buttonstateIsDeferred's' to @False@. %~ (mouseIsReady .~ False) . (mousePixel .~ p)
leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False) . (mouseStates.mapped %~ (mouseIsDragging .~ False)
.(mouseStates.mapped %~ (mouseIsFiring .~ False) -- following line executed BEFORE above line
-- following line executed BEFORE above line . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
.(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
-- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
-- |Creates a MouseHandler that reacts on mouse clicks.
--
-- Does /not/ update 'WidgetState MouseState'!
buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> EventHandler m
buttonMouseActions a = MouseHandler press' release'
where
press' _ _ = return
release' b p isIn w =
if isIn
then a b w p
else return w
emptyGraphics :: (Monad m) => GUIGraphics m emptyGraphics :: (Monad m) => GUIGraphics m
emptyGraphics = Graphics (return 3) emptyGraphics = Graphics (return 3)
isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool -- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0) 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.
isInsideExtent :: (ScreenUnit, ScreenUnit) -> Pixel -> Bool
isInsideExtent (w,h) (x',y') = (x' <= w) && (x' >= 0) && (y' <= h) && (y' >= 0)
-- |Calculates whether a point is within a given rectangle.
isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
isInsideRect (x,y,w,h) px = isInsideExtent (w, h) $ px -: (x, y)
-- |@GUIBaseProperties@ with a rectangular base that fills the bounds.
rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
rectangularBase bnd chld prio short = rectangularBase bnd chld prio short =
BaseProperties (return bnd) (return chld) BaseProperties (return bnd) (return chld)
(\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary)) (\w p -> liftM (flip isInsideExtent p . extractExtent) (w ^. baseProperties.boundary)) -- isInside
(return prio) short (return prio) short
debugShowWidget' :: (Monad m) => GUIWidget m -> m String debugShowWidget' :: (Monad m) => GUIWidget m -> m String
debugShowWidget' (Widget base mouse _) = do debugShowWidget' (Widget base _ _ handler) = do
bnd <- base ^. boundary bnd <- base ^. boundary
chld <- base ^. children chld <- base ^. children
prio <- base ^. priority prio <- base ^. priority
let short = base ^. shorthand let short = base ^. shorthand
return $ concat [short,"| boundary:", show bnd, ", children:", show chld, return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
",priority:",show prio, maybe "" (const ", with mouse handler") mouse] ",priority:",show prio, maybe "" (const ", with mouse handler") (Map.lookup MouseEvent handler)]

47
src/UI/UIOperations.hs
View File

@ -8,63 +8,40 @@ import Data.Maybe
import Types import Types
import UI.UIBase import UI.UIBase
-- TODO: test GUI function to scan for overlapping widgets
toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m
toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m) toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
{-# INLINE toGUIAny #-} {-# INLINABLE toGUIAny #-}
toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m] toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
toGUIAnys m = mapMaybe (`Map.lookup` m) toGUIAnys m = mapMaybe (`Map.lookup` m)
{-# INLINE toGUIAnys #-} {-# INLINABLE toGUIAnys #-}
-- TODO: check for missing components? -- TODO: check for missing components?
-- |The function 'getInside' returns child widgets that overlap with a specific
-- screen position.
--
-- A screen position may be inside the bounding box of a widget but not
-- considered part of the component. The function returns all hit widgets that
-- have no hit children, which may be the input widget itself,
-- or @[]@ if the point does not hit the widget.
--
-- This function returns the widgets themselves unlike 'getInsideId'.
getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-> Pixel -- ^screen position
-> GUIWidget Pioneers -- ^the parent widget
-> Pioneers [GUIWidget Pioneers]
getInside hMap px wg = do
inside <- (wg ^. baseProperties.isInside) wg px
if inside -- test inside parent's bounding box
then do
childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds)
case hitChildren of
[] -> return [wg]
_ -> return hitChildren
else return []
--TODO: Priority queue?
-- |The function 'getInsideId' returns child widgets that overlap with a -- |The function 'getInsideId' returns child widgets that overlap with a
-- specific screen position. -- specific screen position and the pixel's local coordinates.
-- --
-- A screen position may be inside the bounding box of a widget but not -- 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 -- considered part of the component. The function returns all hit widgets that
-- have no hit children, which may be the input widget itself, -- have no hit children, which may be the input widget itself,
-- or @[]@ if the point does not hit the widget. -- or @[]@ if the point does not hit the widget.
--
-- This function returns the 'UIId's of the widgets unlike 'getInside'.
getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-> Pixel -- ^screen position -> Pixel -- ^screen position
-> UIId -- ^the parent widget -> UIId -- ^the parent widget
-> Pioneers [UIId] -> Pioneers [(UIId, Pixel)]
getInsideId hMap px uid = do getInsideId hMap px uid = do
let wg = toGUIAny hMap uid let wg = toGUIAny hMap uid
inside <- (wg ^. baseProperties.isInside) wg px bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary
let px' = px -: (bX, bY)
inside <- liftM (isInsideRect bnd px &&) $ (wg ^. baseProperties.isInside) wg px'
if inside -- test inside parent's bounding box if inside -- test inside parent's bounding box
then do then do
childrenIds <- wg ^. baseProperties.children childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds hitChildren <- liftM concat $ mapM (getInsideId hMap px') childrenIds
case hitChildren of case hitChildren of
[] -> return [uid] [] -> return [(uid, px')]
_ -> return hitChildren _ -> return hitChildren
else return [] else return []
--TODO: Priority queue? --TODO: Priority queue?

25
src/UI/UIWidgets.hs
View File

@ -16,33 +16,30 @@ import UI.UIBase
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT") createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
Nothing emptyGraphics
emptyGraphics Map.empty -- widget states
Map.empty -- event handlers
createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize') createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
Nothing emptyGraphics
emptyGraphics Map.empty -- widget states
Map.empty -- event handlers
where where
autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
autosize' = do autosize' = do
state <- get state <- get
let hmap = state ^. ui . uiMap let hmap = state ^. ui . uiMap
-- TODO: local coordinates
determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
determineSize' (x, y, w, h) (x', y', w', h') = determineSize' (x, y, w, h) (x', y', w', h') = (x, y, max w (x' + w'), max h (y' + h'))
let x'' = if x' < x then x' else x
y'' = if y' < y then y' else y
w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
in (x'', y'', w'', h'')
case chld of case chld of
[] -> return bnd [] -> return bnd
cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs
foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets
createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m
createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN") createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
(Just $ buttonMouseActions action) emptyGraphics
emptyGraphics (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
(Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers