restructured GUI widgets' data representation from class type/instance-based
to function-based advantage: single constructor for any widget type, no branching necessary
This commit is contained in:
tpajenka
parent
f35f3895f5
commit
ca51c23650
@ -135,7 +135,7 @@ data GLState = GLState
|
||||
|
||||
data UIState = UIState
|
||||
{ _uiHasChanged :: !Bool
|
||||
, _uiMap :: Map.HashMap UIId (GUIAny Pioneers)
|
||||
, _uiMap :: Map.HashMap UIId (GUIWidget Pioneers)
|
||||
, _uiRoots :: [UIId]
|
||||
}
|
||||
|
||||
|
||||
@ -15,21 +15,21 @@ import qualified Graphics.UI.SDL as SDL
|
||||
import Render.Misc (genColorData)
|
||||
|
||||
import Types
|
||||
import Render.Misc (curb)
|
||||
import Render.Misc (curb) -- TODO: necessary import ?
|
||||
import UI.UIBaseData
|
||||
import UI.UIClasses
|
||||
import UI.UIOperations
|
||||
|
||||
|
||||
createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
|
||||
createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
|
||||
, (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
|
||||
, (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
|
||||
, (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 )
|
||||
, (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage))
|
||||
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 (20, 50, 120, 80) [] 1)
|
||||
, (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3)
|
||||
, (UIId 3, createContainer (100, 140, 130, 200) [] 4 )
|
||||
, (UIId 4, createButton (30, 200, 60, 175) 2 testMessage)
|
||||
], [UIId 0])
|
||||
|
||||
getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers]
|
||||
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
|
||||
getGUI = Map.elems
|
||||
{-# INLINE getGUI #-}
|
||||
|
||||
@ -38,23 +38,36 @@ getRootIds = do
|
||||
state <- get
|
||||
return $ state ^. ui.uiRoots
|
||||
|
||||
getRoots :: Pioneers [GUIAny Pioneers]
|
||||
getRoots :: Pioneers [GUIWidget Pioneers]
|
||||
getRoots = do
|
||||
state <- get
|
||||
rootIds <- getRootIds
|
||||
let hMap = state ^. ui.uiMap
|
||||
return $ toGUIAnys hMap rootIds
|
||||
|
||||
testMessage :: w -> Pixel -> Pioneers w
|
||||
testMessage w (x, y) = do
|
||||
liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
|
||||
testMessage :: MouseButton -> w -> Pixel -> Pioneers w
|
||||
testMessage btn w (x, y) = do
|
||||
case btn of
|
||||
LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y)
|
||||
RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y)
|
||||
MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y)
|
||||
MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y)
|
||||
MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y)
|
||||
return w
|
||||
|
||||
transformButton :: SDL.MouseButton -> Maybe MouseButton
|
||||
transformButton SDL.LeftButton = Just LeftButton
|
||||
transformButton SDL.RightButton = Just RightButton
|
||||
transformButton SDL.MiddleButton = Just MiddleButton
|
||||
transformButton SDL.MouseX1 = Just MouseX1
|
||||
transformButton SDL.MouseX2 = Just MouseX2
|
||||
transformButton _ = Nothing
|
||||
|
||||
eventCallback :: SDL.Event -> Pioneers ()
|
||||
eventCallback e = do
|
||||
env <- ask
|
||||
case SDL.eventData e of
|
||||
SDL.Window _ winEvent -> -- windowID event
|
||||
SDL.Window _ _ -> -- windowID event
|
||||
-- TODO: resize GUI
|
||||
return ()
|
||||
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
|
||||
@ -109,11 +122,9 @@ eventCallback e = do
|
||||
if st ^. mouse.isDragging then
|
||||
modify $ mouse.isDragging .~ False
|
||||
else
|
||||
clickHandler (x, y)
|
||||
SDL.RightButton -> do
|
||||
when (state == SDL.Released) $ alternateClickHandler (x, y)
|
||||
_ ->
|
||||
return ()
|
||||
clickHandler LeftButton (x, y)
|
||||
_ -> do when (state == SDL.Released)
|
||||
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
|
||||
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
|
||||
do
|
||||
state <- get
|
||||
@ -126,42 +137,34 @@ eventCallback e = do
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
|
||||
clickHandler :: Pixel -> Pioneers ()
|
||||
clickHandler pos@(x,y) = do
|
||||
clickHandler :: MouseButton -> Pixel -> Pioneers ()
|
||||
clickHandler btn pos@(x,y) = do
|
||||
state <- get
|
||||
let hMap = state ^. ui.uiMap
|
||||
roots <- getRootIds
|
||||
hits <- liftM concat $ mapM (getInsideId hMap pos) roots
|
||||
case hits of
|
||||
[] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
|
||||
[] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
|
||||
_ -> do
|
||||
changes <- mapM (\uid -> do
|
||||
let w = toGUIAny hMap uid
|
||||
short <- getShorthand w
|
||||
bound <- getBoundary w
|
||||
prio <- getPriority w
|
||||
short = w ^. baseProperties.shorthand
|
||||
bound <- w ^. baseProperties.boundary
|
||||
prio <- w ^. baseProperties.priority
|
||||
liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
|
||||
++ " at [" ++ show x ++ "," ++ show y ++ "]"
|
||||
case w of
|
||||
(GUIAnyB b h) -> do
|
||||
(b', h') <- onMousePressed pos b h
|
||||
(b'', h'') <- onMouseReleased pos b' h'
|
||||
return $ Just (uid, GUIAnyB b'' h'')
|
||||
_ -> return Nothing
|
||||
case w ^. mouseActions of
|
||||
Just ma -> do w' <- (ma ^. onMousePress) btn pos w
|
||||
w'' <- (ma ^. onMouseRelease) btn pos w'
|
||||
return $ Just (uid, w'')
|
||||
Nothing -> return Nothing
|
||||
) $ hits
|
||||
let newMap :: Map.HashMap UIId (GUIAny Pioneers)
|
||||
let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
|
||||
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
|
||||
modify $ ui.uiMap .~ newMap
|
||||
return ()
|
||||
|
||||
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
|
||||
alternateClickHandler :: Pixel -> Pioneers ()
|
||||
alternateClickHandler (x,y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"]
|
||||
|
||||
|
||||
-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
|
||||
--
|
||||
--TODO: should be done asynchronously at one point.
|
||||
@ -183,19 +186,20 @@ prepareGUI = do
|
||||
modify $ ui.uiHasChanged .~ False
|
||||
|
||||
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
|
||||
copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers ()
|
||||
copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers ()
|
||||
copyGUI tex widget = do
|
||||
(xoff, yoff, wWidth, wHeight) <- getBoundary widget
|
||||
(xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
|
||||
state <- get
|
||||
let
|
||||
hMap = state ^. ui.uiMap
|
||||
int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
|
||||
--temporary color here. lateron better some getData-function to
|
||||
--get a list of pixel-data or a texture.
|
||||
color = case widget of
|
||||
(GUIAnyC _) -> [255,0,0,128]
|
||||
(GUIAnyB _ _) -> [255,255,0,255]
|
||||
(GUIAnyP _) -> [128,128,128,128]
|
||||
color = case widget ^. baseProperties.shorthand of
|
||||
"CNT" -> [255,0,0,128]
|
||||
"BTN" -> [255,255,0,255]
|
||||
"PNL" -> [128,128,128,128]
|
||||
_ -> [255,0,255,255]
|
||||
liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
|
||||
--copy data into C-Array
|
||||
pokeArray ptr (genColorData (wWidth*wHeight) color)
|
||||
@ -205,7 +209,7 @@ copyGUI tex widget = do
|
||||
(GL.TexturePosition2D (int xoff) (int yoff))
|
||||
(GL.TextureSize2D (int wWidth) (int wHeight))
|
||||
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
|
||||
nextChildrenIds <- getChildren widget
|
||||
nextChildrenIds <- widget ^. baseProperties.children
|
||||
mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
|
||||
|
||||
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
|
||||
|
||||
@ -1,10 +1,15 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
|
||||
-- data and classes are separated into several modules to avoid cyclic dependencies with the Type module
|
||||
|
||||
-- TODO: exclude UIMouseState constructor
|
||||
module UI.UIBaseData where
|
||||
|
||||
import Control.Lens ((^.), (.~), (%~), (&), ix, to, mapped, traverse, makeLenses)
|
||||
import Control.Monad (liftM)
|
||||
import Data.Array
|
||||
import Data.Hashable
|
||||
import Data.Ix
|
||||
import Data.Ix ()
|
||||
import Data.Maybe
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- |Unit of screen/window
|
||||
type ScreenUnit = Int
|
||||
@ -12,21 +17,30 @@ type ScreenUnit = Int
|
||||
-- | @x@ and @y@ position on screen.
|
||||
type Pixel = (ScreenUnit, ScreenUnit)
|
||||
|
||||
newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
|
||||
newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
|
||||
|
||||
data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
|
||||
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
|
||||
|
||||
instance Hashable MouseButton
|
||||
|
||||
firstButton :: MouseButton
|
||||
firstButton = LeftButton
|
||||
|
||||
lastButton :: MouseButton
|
||||
lastButton = MiddleButton
|
||||
|
||||
-- |The button dependant state of a 'UIMouseState'.
|
||||
data UIMouseStateSingle = MouseStateSingle
|
||||
{ _mouseIsFiring :: Bool -- ^firing if pressed but not confirmed
|
||||
, _mouseIsDeferred :: Bool
|
||||
-- ^deferred if e. g. dragging but outside component
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- |The state of a clickable ui widget.
|
||||
data UIButtonState = UIButtonState
|
||||
{ _buttonstateIsFiring :: Bool
|
||||
-- ^firing if pressed but not confirmed
|
||||
, _buttonstateIsFiringAlt :: Bool
|
||||
-- ^firing if pressed but not confirmed (secondary mouse button)
|
||||
, _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component
|
||||
, _buttonstateIsDeferredAlt :: Bool
|
||||
-- ^deferred if e. g. dragging but outside component (secondary mouse button)
|
||||
, _buttonstateIsReady :: Bool
|
||||
-- ^ready if mouse is above component
|
||||
, _buttonstateIsActivated :: Bool
|
||||
-- ^in activated state (e. g. toggle button)
|
||||
data UIMouseState = MouseState
|
||||
{ _mouseStates :: Array MouseButton UIMouseStateSingle
|
||||
, _mouseIsReady :: Bool -- ^ready if mouse is above component
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
@ -36,41 +50,183 @@ 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) }
|
||||
{ _action :: w -> Pixel -> m w }
|
||||
instance Show (ButtonHandler m w) where
|
||||
show _ = "ButtonHandler ***"
|
||||
|
||||
-- |A collection data type that may hold any usable ui element. @m@ is a monad.
|
||||
data GUIAny m = GUIAnyC GUIContainer
|
||||
| GUIAnyP GUIPanel
|
||||
| GUIAnyB GUIButton (ButtonHandler m GUIButton)
|
||||
deriving (Show)
|
||||
-- |A @GUIWidget@ is a visual object the HUD is composed of.
|
||||
data GUIWidget m = Widget
|
||||
{_baseProperties :: GUIBaseProperties m
|
||||
,_mouseActions :: Maybe (GUIMouseActions m)
|
||||
,_graphics :: GUIGraphics m
|
||||
}
|
||||
|
||||
-- |Base properties are fundamental settings of any 'GUIWidget'.
|
||||
-- They mostly control positioning and widget hierarchy.
|
||||
data GUIBaseProperties m = BaseProperties
|
||||
{
|
||||
-- |The @_getBoundary@ function gives the outer extents of the @GUIWidget@.
|
||||
-- The bounding box wholly contains all children components.
|
||||
_boundary :: m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
|
||||
,
|
||||
-- |The @_getChildren@ function returns all children associated with this widget.
|
||||
--
|
||||
-- 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 -- ^screen position
|
||||
-> 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.
|
||||
_priority :: m Int
|
||||
,
|
||||
-- |The @_getShorthand@ function returns a descriptive 'String' mainly for debuggin prupose.
|
||||
-- The shorthand should be unique for each instance.
|
||||
_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
|
||||
}
|
||||
|
||||
|
||||
-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
|
||||
-- functionality itself.
|
||||
data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit
|
||||
, _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit
|
||||
, _uiChildren :: [UIId]
|
||||
, _uiPriority :: Int
|
||||
} deriving (Show)
|
||||
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
|
||||
|
||||
-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
|
||||
-- children components.
|
||||
data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
|
||||
data GUIGraphics m = Graphics
|
||||
{temp :: m Int}
|
||||
|
||||
$(makeLenses ''UIMouseState)
|
||||
$(makeLenses ''UIMouseStateSingle)
|
||||
$(makeLenses ''GUIWidget)
|
||||
$(makeLenses ''GUIBaseProperties)
|
||||
$(makeLenses ''GUIMouseActions)
|
||||
$(makeLenses ''GUIGraphics)
|
||||
|
||||
initialMouseStateS :: UIMouseStateSingle
|
||||
initialMouseStateS = MouseStateSingle False False
|
||||
{-# INLINE initialMouseStateS #-}
|
||||
|
||||
-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
|
||||
-- provided in the passed list.
|
||||
initialMouseState :: UIMouseState
|
||||
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)])
|
||||
False
|
||||
{-# 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? breaks if array not of sufficient size -- will be avoided by excluding constructor export
|
||||
-- |Creates a @GUIMouseActions@ handler that enables button clicks.
|
||||
--
|
||||
-- The action is peformed right before the button state change.
|
||||
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
|
||||
-- |Change 'UIMouseState's '_mouseIsFiring' to @True@.
|
||||
press' b _ w =
|
||||
return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True
|
||||
|
||||
-- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and
|
||||
-- call action if '_mouseIsFiring' was @True@.
|
||||
release' b p w =
|
||||
let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly
|
||||
in do w' <- if fire
|
||||
then a b w p
|
||||
else return w
|
||||
return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~
|
||||
(mouseIsFiring .~ False) . (mouseIsDeferred .~ False)
|
||||
|
||||
-- |Do nothing.
|
||||
move' _ = return
|
||||
|
||||
-- |Set 'UIMouseState's '_mouseIsReady' to @True@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value
|
||||
-- and set '_mouseIsFiring' to @False@.
|
||||
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
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
|
||||
-- and set '_buttonstateIsDeferred's' to @False@.
|
||||
leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False)
|
||||
.(mouseStates.mapped %~ (mouseIsFiring .~ False)
|
||||
-- following line executed BEFORE above line
|
||||
.(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
|
||||
|
||||
emptyGraphics :: (Monad m) => GUIGraphics m
|
||||
emptyGraphics = Graphics (return 3)
|
||||
|
||||
isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
|
||||
isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
|
||||
|
||||
rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
|
||||
rectangularBase bnd chld prio short =
|
||||
BaseProperties (return bnd) (return chld)
|
||||
(\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary))
|
||||
(return prio) short
|
||||
|
||||
debugShowWidget' :: (Monad m) => GUIWidget m -> m String
|
||||
debugShowWidget' (Widget base mouse _) = do
|
||||
bnd <- base ^. boundary
|
||||
chld <- base ^. children
|
||||
prio <- base ^. priority
|
||||
let short = base ^. shorthand
|
||||
return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
|
||||
",priority:",show prio, maybe "" (const ", with mouse handler") mouse]
|
||||
|
||||
-- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be
|
||||
-- provided by an appropriate 'MouseHanlder'.
|
||||
data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit
|
||||
, _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit
|
||||
, _uiPriorityB :: Int
|
||||
, _uiButtonState :: UIButtonState
|
||||
} deriving ()
|
||||
instance Show GUIButton where
|
||||
show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w)
|
||||
++ " _screenYB = " ++ show (_uiScreenYB w)
|
||||
++ " _widthB = " ++ show (_uiWidthB w)
|
||||
++ " _heightB = " ++ show (_uiHeightB w)
|
||||
++ " _priorityB = " ++ show (_uiScreenYB w)
|
||||
++ " _buttonState = " ++ show (_uiButtonState w)
|
||||
++ "}"
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
|
||||
|
||||
module UI.UIClasses where
|
||||
module UI.UIClasses (module UI.UIClasses, module UI.UIBaseData) where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Lens ((^.), (.~), (&))
|
||||
import Control.Monad
|
||||
--import Control.Monad.IO.Class -- MonadIO
|
||||
import Control.Monad.RWS.Strict (get)
|
||||
@ -10,234 +10,39 @@ import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
|
||||
import qualified Types as T
|
||||
import Types
|
||||
import UI.UIBaseData
|
||||
|
||||
class GUIAnyMap m w where
|
||||
guiAnyMap :: (w -> b) -> GUIAny m -> b
|
||||
|
||||
class (Monad m) => GUIWidget m uiw where
|
||||
-- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
|
||||
-- The bounding box wholly contains all children components.
|
||||
getBoundary :: uiw -> m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
|
||||
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
|
||||
createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
|
||||
Nothing
|
||||
emptyGraphics
|
||||
|
||||
-- |The 'getChildren' function returns all children associated with this widget.
|
||||
--
|
||||
-- All children must be wholly inside the parent's bounding box specified by 'getBoundary'.
|
||||
getChildren :: uiw -> m [UIId]
|
||||
getChildren _ = return []
|
||||
|
||||
-- |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 :: Pixel -- ^screen position
|
||||
-> uiw -- ^the parent widget
|
||||
-> m Bool
|
||||
isInside (x',y') wg = do
|
||||
(x, y, w, h) <- getBoundary wg
|
||||
return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
|
||||
|
||||
-- |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.
|
||||
getPriority :: uiw -> m Int
|
||||
getPriority _ = return 0
|
||||
|
||||
-- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
|
||||
-- The shorthand should be unique for each instance.
|
||||
getShorthand :: uiw -> m String
|
||||
|
||||
-- |A 'GUIClickable' represents a widget with a 'UIButtonState'.
|
||||
--
|
||||
-- Minimal complete definition: 'getButtonState' and either 'updateButtonState' or 'setButtonState'.
|
||||
class GUIClickable w where
|
||||
updateButtonState :: (UIButtonState -> UIButtonState) -> w -> w
|
||||
updateButtonState f w = setButtonState (f $ getButtonState w) w
|
||||
setButtonState :: UIButtonState -> w -> w
|
||||
setButtonState s = updateButtonState (\_ -> s)
|
||||
getButtonState :: w -> UIButtonState
|
||||
|
||||
class Monad m => MouseHandler a m w where
|
||||
-- |The function 'onMousePressed' is called when the primary button is pressed
|
||||
-- while inside a screen coordinate within the widget ('isInside').
|
||||
onMousePressed :: Pixel -- ^screen position
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMousePressed _ wg a = return (wg, a)
|
||||
|
||||
-- |The function 'onMouseReleased' is called when the primary 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.
|
||||
onMouseReleased :: Pixel -- ^screen position
|
||||
-> w -- ^wdiget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMouseReleased _ wg a = return (wg, a)
|
||||
|
||||
-- |The function 'onMousePressed' is called when the secondary button is pressed
|
||||
-- while inside a screen coordinate within the widget ('isInside').
|
||||
onMousePressedAlt :: Pixel -- ^screen position
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMousePressedAlt _ wg a = return (wg, a)
|
||||
|
||||
-- |The function 'onMouseReleased' is called when the secondary 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.
|
||||
onMouseReleasedAlt :: Pixel -- ^screen position
|
||||
-> w -- ^wdiget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMouseReleasedAlt _ wg a = return (wg, a)
|
||||
|
||||
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the
|
||||
-- widget's space ('isInside').
|
||||
onMouseMove :: Pixel -- ^screen position
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMouseMove _ wg a = return (wg, a)
|
||||
|
||||
-- |The function 'onMouseMove' is invoked when the mouse enters the
|
||||
-- widget's space ('isInside').
|
||||
onMouseEnter :: Pixel -- ^screen position
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMouseEnter _ wg a = return (wg, a)
|
||||
|
||||
-- |The function 'onMouseMove' is invoked when the mouse leaves the
|
||||
-- widget's space ('isInside').
|
||||
onMouseLeave :: Pixel -- ^screen position
|
||||
-> w -- ^widget the event is invoked on
|
||||
-> a -> m (w, a) -- ^widget after the event and the altered handler
|
||||
onMouseLeave _ wg a = return (wg, a)
|
||||
|
||||
instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where
|
||||
onMousePressed p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMousePressedAlt p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseReleased p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseReleasedAlt p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMousePressedAlt p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMousePressed p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseReleasedAlt p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseReleased p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseMove p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseMove p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseEnter p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseEnter p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
onMouseLeave p w (MouseHandlerSwitch h) = do
|
||||
(w', h') <- onMouseLeave p w h
|
||||
return (w', MouseHandlerSwitch h')
|
||||
|
||||
instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
|
||||
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
|
||||
onMousePressed _ wg h =
|
||||
return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
|
||||
|
||||
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
|
||||
-- call 'action' if inside the widget or
|
||||
-- set '_buttonstateIsDeferred' to false otherwise.
|
||||
onMouseReleased p wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg
|
||||
then do
|
||||
wg' <- action wg p
|
||||
return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h)
|
||||
else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h)
|
||||
|
||||
-- |Do nothing.
|
||||
onMouseMove _ wg h = return (wg, h)
|
||||
|
||||
-- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value
|
||||
-- and set '_buttonstateIsFiring' to @False@.
|
||||
onMouseEnter _ wg h = return
|
||||
(updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s
|
||||
, _buttonstateIsDeferred = False
|
||||
, _buttonstateIsReady = True
|
||||
}) wg
|
||||
, h)
|
||||
|
||||
-- |Set 'UIButtonState's 'buttonstateIsReady' to @False@ and
|
||||
-- update dragging state (only drag if inside widget).
|
||||
-- In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
|
||||
-- and set '_buttonstateIsDeferred's' to @False@.
|
||||
onMouseLeave _ wg h = return
|
||||
(updateButtonState (\s -> s { _buttonstateIsFiring = False
|
||||
, _buttonstateIsDeferred = _buttonstateIsFiring s
|
||||
, _buttonstateIsReady = False
|
||||
}) wg
|
||||
, h)
|
||||
|
||||
instance (Monad m) => GUIAnyMap m (GUIAny m) where
|
||||
guiAnyMap f w = f w
|
||||
|
||||
instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
|
||||
getBoundary (GUIAnyC w) = getBoundary w
|
||||
getBoundary (GUIAnyP w) = getBoundary w
|
||||
getBoundary (GUIAnyB w _) = getBoundary w
|
||||
getChildren (GUIAnyC w) = getChildren w
|
||||
getChildren (GUIAnyP w) = getChildren w
|
||||
getChildren (GUIAnyB w _) = getChildren w
|
||||
isInside p (GUIAnyC w) = (isInside p) w
|
||||
isInside p (GUIAnyP w) = (isInside p) w
|
||||
isInside p (GUIAnyB w _) = (isInside p) w
|
||||
getPriority (GUIAnyC w) = getPriority w
|
||||
getPriority (GUIAnyP w) = getPriority w
|
||||
getPriority (GUIAnyB w _) = getPriority w
|
||||
getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str }
|
||||
getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str }
|
||||
getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str }
|
||||
|
||||
instance (Monad m) => GUIAnyMap m GUIContainer where
|
||||
guiAnyMap f (GUIAnyC c) = f c
|
||||
guiAnyMap _ _ = error "invalid types in guiAnyMap"
|
||||
instance (Monad m) => GUIWidget m GUIContainer where
|
||||
getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
|
||||
getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt)
|
||||
getChildren cnt = return $ _uiChildren cnt
|
||||
getPriority cnt = return $ _uiPriority cnt
|
||||
getShorthand _ = return $ "CNT"
|
||||
|
||||
instance GUIAnyMap m GUIPanel where
|
||||
guiAnyMap f (GUIAnyP p) = f p
|
||||
guiAnyMap _ _ = error "invalid types in guiAnyMap"
|
||||
instance GUIWidget T.Pioneers GUIPanel where
|
||||
getBoundary pnl = do
|
||||
state <- get
|
||||
let hmap = state ^. T.ui . T.uiMap
|
||||
case _uiChildren $ _panelContainer pnl of
|
||||
[] -> getBoundary $ _panelContainer pnl
|
||||
cs -> do
|
||||
let widgets = catMaybes $ map (flip Map.lookup hmap) cs
|
||||
foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets
|
||||
createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
|
||||
createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
|
||||
Nothing
|
||||
emptyGraphics
|
||||
where
|
||||
determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
|
||||
determineSize (x, y, w, h) (x', y', w', h') =
|
||||
autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
|
||||
autosize' = do
|
||||
state <- get
|
||||
let hmap = state ^. ui . uiMap
|
||||
-- TODO: local coordinates
|
||||
determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
|
||||
determineSize' (x, y, w, h) (x', y', w', 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
|
||||
[] -> return bnd
|
||||
cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs
|
||||
foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets
|
||||
|
||||
getChildren pnl = getChildren $ _panelContainer pnl
|
||||
getPriority pnl = getPriority $ _panelContainer pnl
|
||||
getShorthand _ = return $ "PNL"
|
||||
|
||||
instance (Monad m) => GUIAnyMap m GUIButton where
|
||||
guiAnyMap f (GUIAnyB btn _) = f btn
|
||||
guiAnyMap _ _ = error "invalid types in guiAnyMap"
|
||||
instance GUIClickable GUIButton where
|
||||
getButtonState = _uiButtonState
|
||||
updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn}
|
||||
instance (Monad m) => GUIWidget m GUIButton where
|
||||
getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn)
|
||||
getChildren _ = return []
|
||||
getPriority btn = return $ _uiPriorityB btn
|
||||
getShorthand _ = return "BTN"
|
||||
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")
|
||||
(Just $ buttonMouseActions action)
|
||||
emptyGraphics
|
||||
|
||||
@ -1,23 +1,19 @@
|
||||
module UI.UIOperations where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad (liftM)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.Maybe
|
||||
|
||||
import Types
|
||||
import UI.UIBaseData
|
||||
import UI.UIClasses
|
||||
|
||||
defaultUIState :: UIButtonState
|
||||
defaultUIState = UIButtonState False False False False False False
|
||||
{-# INLINE defaultUIState #-}
|
||||
|
||||
toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny 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)
|
||||
{-# INLINE toGUIAny #-}
|
||||
|
||||
toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m]
|
||||
toGUIAnys m = mapMaybe (flip Map.lookup m)
|
||||
toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
|
||||
toGUIAnys m = mapMaybe (`Map.lookup` m)
|
||||
{-# INLINE toGUIAnys #-}
|
||||
-- TODO: check for missing components?
|
||||
|
||||
@ -31,16 +27,16 @@ toGUIAnys m = mapMaybe (flip Map.lookup m)
|
||||
-- or @[]@ if the point does not hit the widget.
|
||||
--
|
||||
-- This function returns the widgets themselves unlike 'getInsideId'.
|
||||
getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
|
||||
getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
|
||||
-> Pixel -- ^screen position
|
||||
-> GUIAny Pioneers -- ^the parent widget
|
||||
-> Pioneers [GUIAny Pioneers]
|
||||
getInside hMap (x',y') wg = do
|
||||
inside <- isInside (x',y') wg
|
||||
-> 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 <- getChildren wg
|
||||
hitChildren <- liftM concat $ mapM (getInside hMap (x',y')) (toGUIAnys hMap childrenIds)
|
||||
childrenIds <- wg ^. baseProperties.children
|
||||
hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds)
|
||||
case hitChildren of
|
||||
[] -> return [wg]
|
||||
_ -> return hitChildren
|
||||
@ -56,17 +52,17 @@ getInside hMap (x',y') wg = do
|
||||
-- or @[]@ if the point does not hit the widget.
|
||||
--
|
||||
-- This function returns the 'UIId's of the widgets unlike 'getInside'.
|
||||
getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
|
||||
getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
|
||||
-> Pixel -- ^screen position
|
||||
-> UIId -- ^the parent widget
|
||||
-> Pioneers [UIId]
|
||||
getInsideId hMap (x',y') uid = do
|
||||
getInsideId hMap px uid = do
|
||||
let wg = toGUIAny hMap uid
|
||||
inside <- isInside (x',y') wg
|
||||
inside <- (wg ^. baseProperties.isInside) wg px
|
||||
if inside -- test inside parent's bounding box
|
||||
then do
|
||||
childrenIds <- getChildren wg
|
||||
hitChildren <- liftM concat $ mapM (getInsideId hMap (x',y')) childrenIds
|
||||
childrenIds <- wg ^. baseProperties.children
|
||||
hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds
|
||||
case hitChildren of
|
||||
[] -> return [uid]
|
||||
_ -> return hitChildren
|
||||
|
||||
Loading…
Reference in New Issue
Block a user