pioneers/src/UI/UIBase.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
-- 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           Data.Array
import          Data.Bits                 (xor)
import           Data.Hashable
import qualified Data.HashMap.Strict      as Map
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)

-- |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 (*:) #-}

-- |Id to reference a specific widget, must be unique.
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
    deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)

instance Hashable MouseButton where -- TODO: generic deriving creates functions that run forever
    hash = fromEnum
    hashWithSalt salt x = (salt * 16777619)  `xor` hash x

---------------------------
--- 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

-- |The button dependant state of a 'MouseState'.
data MouseButtonState = MouseButtonState
    { _mouseIsDragging      :: Bool -- ^firing if pressed but not confirmed
    , _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 = 
    -- |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)

---------------------------
--- events
---------------------------

-- |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 ()


---------------------------
--- widgets
---------------------------

-- |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
    }

-- |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
    }



-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.

data GUIGraphics m = Graphics 
    {temp :: m Int}

$(makeLenses ''WidgetStateKey)
$(makeLenses ''WidgetState)
$(makeLenses ''MouseButtonState)
$(makeLenses ''EventKey)
$(makeLenses ''EventHandler)
$(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIGraphics)

initialButtonState :: MouseButtonState
initialButtonState = MouseButtonState False False
{-# INLINE initialButtonState #-}

-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
--  provided in the passed list.
initialMouseState :: WidgetState
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
                               False (0, 0)
{-# INLINE initialMouseState #-}

-- TODO: combined mouse handler

-- |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 = MouseHandler press' release'
  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 =
        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,
--  only fully functional in conjunction with 'setMouseStateActions'.
setMouseMotionStateActions :: (Monad m) => EventHandler 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@. 
    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@. 
    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? 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 = 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)) -- isInside
                   (return prio) short

debugShowWidget' :: (Monad m) => GUIWidget m -> m String
debugShowWidget' (Widget base _ _ handler) = 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") (Map.lookup MouseEvent handler)]