pioneers/src/UI/UIBaseData.hs

233 lines
10 KiB
Haskell
Raw Normal View History

{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
2014-04-26 19:58:20 +02:00
-- 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.Maybe
import GHC.Generics (Generic)
-- |Unit of screen/window
type ScreenUnit = Int
-- | @x@ and @y@ position on screen.
type Pixel = (ScreenUnit, ScreenUnit)
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 UIMouseState = MouseState
{ _mouseStates :: Array MouseButton UIMouseStateSingle
, _mouseIsReady :: Bool -- ^ready if mouse is above component
} deriving (Eq, Show)
-- |Switches primary and secondary mouse actions.
-- "monad type" "widget type" "original handler"
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.
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
}
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
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]