Merge branch 'ui' into tessallation
This commit is contained in:
commit
4285cefa31
@ -162,7 +162,7 @@ main =
|
||||
{ _uiHasChanged = True
|
||||
, _uiMap = guiMap
|
||||
, _uiRoots = guiRoots
|
||||
, _uiButtonState = UI.UIButtonState 0 Nothing
|
||||
, _uiButtonState = UI.UIButtonState 0 Nothing False
|
||||
}
|
||||
}
|
||||
|
||||
@ -234,7 +234,7 @@ run = do
|
||||
let double = fromRational.toRational :: (Real a) => a -> Double
|
||||
targetFramerate = 60.0
|
||||
targetFrametime = 1.0/targetFramerate
|
||||
targetFrametimeμs = targetFrametime * 1000000.0
|
||||
--targetFrametimeμs = targetFrametime * 1000000.0
|
||||
now <- getCurrentTime
|
||||
let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs
|
||||
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
module UI.Callbacks where
|
||||
|
||||
|
||||
@ -102,28 +103,34 @@ eventCallback e = do
|
||||
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
|
||||
do
|
||||
state <- get
|
||||
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
|
||||
if state ^. mouse.isDown && not (state ^. mouse.isDragging)
|
||||
then
|
||||
modify $ (mouse.isDragging .~ True)
|
||||
. (mouse.dragStartX .~ fromIntegral x)
|
||||
. (mouse.dragStartY .~ fromIntegral y)
|
||||
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
|
||||
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
|
||||
|
||||
else mouseMoveHandler (x, y)
|
||||
modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
|
||||
. (mouse.mousePosition. Types._y .~ fromIntegral y)
|
||||
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
|
||||
do
|
||||
case button of
|
||||
SDL.LeftButton -> do
|
||||
let pressed = state == SDL.Pressed
|
||||
modify $ mouse.isDown .~ pressed
|
||||
unless pressed $ do
|
||||
if pressed
|
||||
then mouseReleaseHandler LeftButton (x, y)
|
||||
else do
|
||||
st <- get
|
||||
if st ^. mouse.isDragging then
|
||||
modify $ mouse.isDragging .~ False
|
||||
else
|
||||
clickHandler LeftButton (x, y)
|
||||
_ -> when (state == SDL.Released)
|
||||
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
|
||||
else do
|
||||
mousePressHandler LeftButton (x, y)
|
||||
_ -> case state of
|
||||
SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
|
||||
SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
|
||||
_ -> return ()
|
||||
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
|
||||
do
|
||||
state <- get
|
||||
@ -137,17 +144,16 @@ eventCallback e = do
|
||||
mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
|
||||
-> MouseButton -> Pixel -> Pioneers ()
|
||||
mouseButtonHandler transFunc btn px = do
|
||||
modify $ ui.uiButtonState %~ (mousePressed %~ (+1)) -- TODO: what happens if released outside window? not reset properly?
|
||||
state <- get
|
||||
let hMap = state ^. ui.uiMap
|
||||
currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget
|
||||
case currentWidget of
|
||||
Just (wui, px') -> do
|
||||
let target = toGUIAny hMap wui
|
||||
Just (wid, px') -> do
|
||||
let target = toGUIAny hMap wid
|
||||
target' <- case target ^. eventHandlers.(at MouseEvent) of
|
||||
Just ma -> transFunc ma btn (px -: px') target -- TODO unsafe fromJust
|
||||
Just ma -> transFunc ma btn (px -: px') target
|
||||
Nothing -> return target
|
||||
modify $ ui.uiMap %~ Map.insert wui target'
|
||||
modify $ ui.uiMap %~ Map.insert wid target'
|
||||
return ()
|
||||
Nothing -> return ()
|
||||
|
||||
@ -160,24 +166,112 @@ mouseReleaseHandler :: MouseButton -> Pixel -> Pioneers ()
|
||||
mouseReleaseHandler btn px = do
|
||||
modify $ ui.uiButtonState %~ (mousePressed %~ flip (-) 1) -- TODO: what happens if pressed outside window? not set properly?
|
||||
mouseButtonHandler (\ma -> fromJust (ma ^? onMouseRelease)) btn px
|
||||
-- TODO: trigger move/enter/leave
|
||||
state <- get
|
||||
unless (state ^. ui.uiButtonState.mousePressed > 0) $ do
|
||||
case state ^. ui.uiButtonState.mouseCurrentWidget of
|
||||
Just (wid, px') -> do
|
||||
let target = toGUIAny (state ^. ui.uiMap) wid
|
||||
-- debug
|
||||
let short = target ^. baseProperties.shorthand
|
||||
bound <- target ^. baseProperties.boundary
|
||||
prio <- target ^. baseProperties.priority
|
||||
liftIO $ putStrLn $ "releasing(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
|
||||
++ show prio ++ " at [" ++ show (fst px) ++ "," ++ show (snd px) ++ "]"
|
||||
-- /debug
|
||||
target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do
|
||||
target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
|
||||
fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
|
||||
Nothing -> return target
|
||||
modify $ ui.uiMap %~ Map.insert wid target'
|
||||
Nothing -> return ()
|
||||
mouseSetMouseActive px -- TODO leave current
|
||||
|
||||
mouseSetMouseActiveTargeted :: (UIId, Pixel) -- ^ (target widget, local coorinates)
|
||||
-> Pixel -- ^ global coordinates
|
||||
-> Pioneers ()
|
||||
mouseSetMouseActiveTargeted (wid, px') px = do
|
||||
state <- get
|
||||
--liftIO $ putStrLn $ "new target: " ++ show wid
|
||||
let hMap = state ^. ui.uiMap
|
||||
target = toGUIAny hMap wid
|
||||
modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Just (wid, px -: px')) . (mouseInside .~ True)
|
||||
target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do
|
||||
target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
|
||||
fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
|
||||
Nothing -> return target
|
||||
modify $ ui.uiMap %~ Map.insert wid target'
|
||||
|
||||
mouseSetMouseActive :: Pixel -- ^global coordinates
|
||||
-> Pioneers ()
|
||||
mouseSetMouseActive px = do
|
||||
roots <- getRootIds
|
||||
hits <- liftM concat $ mapM (getInsideId px) roots
|
||||
leading <- getLeadingWidget hits
|
||||
case leading of
|
||||
Just hit -> mouseSetMouseActiveTargeted hit px
|
||||
Nothing -> modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Nothing) . (mouseInside .~ False)
|
||||
|
||||
mouseSetLeaving :: UIId -> Pixel -> Pioneers ()
|
||||
mouseSetLeaving wid px = do
|
||||
state <- get
|
||||
let target = toGUIAny (state ^. ui.uiMap) wid
|
||||
modify $ ui.uiButtonState.mouseInside .~ False
|
||||
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do
|
||||
target' <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust
|
||||
modify $ ui.uiMap %~ Map.insert wid target'
|
||||
Nothing -> return ()
|
||||
|
||||
mouseMoveHandler :: Pixel -> Pioneers ()
|
||||
mouseMoveHandler px = undefined
|
||||
mouseMoveHandler px = do
|
||||
state <- get
|
||||
--liftIO $ print $ state ^. ui.uiButtonState
|
||||
case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget?
|
||||
Just (wid, px') -> do
|
||||
let target = toGUIAny (state ^. ui.uiMap) wid
|
||||
inTest <- isHittingChild (px -: px') target
|
||||
case inTest of
|
||||
Left b -> -- no child hit
|
||||
if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside
|
||||
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do target' <- fromJust (ma ^? onMouseMove) px' target
|
||||
modify $ ui.uiMap %~ Map.insert wid target'
|
||||
Nothing -> return ()
|
||||
else if b then -- && not mouseInside --> entering
|
||||
do modify $ ui.uiButtonState.mouseInside .~ True
|
||||
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
|
||||
Just ma -> do
|
||||
target_ <- fromJust (ma ^? onMouseEnter) (px -: px') target --TODO unsafe fromJust
|
||||
target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ --TODO unsafe fromJust
|
||||
modify $ ui.uiMap %~ Map.insert wid target'
|
||||
Nothing -> return ()
|
||||
else -- not b && mouseInside --> leaving
|
||||
do mouseSetLeaving wid (px -: px')
|
||||
when (state ^. ui.uiButtonState.mousePressed <= 0) -- change mouse-active widget?
|
||||
$ mouseSetMouseActive px
|
||||
|
||||
Right childHit -> do
|
||||
mouseSetLeaving wid (px -: px')
|
||||
when (state ^. ui.uiButtonState.mousePressed <= 0) -- change mouse-active widget?
|
||||
$ mouseSetMouseActiveTargeted childHit px
|
||||
Nothing -> do
|
||||
mouseSetMouseActive px
|
||||
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
|
||||
clickHandler :: MouseButton -> Pixel -> Pioneers ()
|
||||
clickHandler btn pos@(x,y) = do
|
||||
state <- get
|
||||
let hMap = state ^. ui.uiMap
|
||||
roots <- getRootIds
|
||||
hits <- liftM concat $ mapM (getInsideId hMap pos) roots
|
||||
hits <- liftM concat $ mapM (getInsideId pos) roots
|
||||
case hits of
|
||||
[] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
|
||||
_ -> do
|
||||
changes <- mapM (\(uid, pos') -> do
|
||||
let w = toGUIAny hMap uid
|
||||
state <- get
|
||||
let w = toGUIAny (state ^. ui.uiMap) uid
|
||||
short = w ^. baseProperties.shorthand
|
||||
bound <- w ^. baseProperties.boundary
|
||||
prio <- w ^. baseProperties.priority
|
||||
@ -189,7 +283,8 @@ clickHandler btn pos@(x,y) = do
|
||||
return $ Just (uid, w'')
|
||||
Nothing -> return Nothing
|
||||
) hits
|
||||
let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
|
||||
state <- get
|
||||
let hMap = state ^. ui.uiMap
|
||||
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
|
||||
modify $ ui.uiMap .~ newMap
|
||||
return ()
|
||||
|
||||
@ -77,6 +77,7 @@ data UIButtonState = UIButtonState
|
||||
-- ^the current mouse-active widget and its global coordinates.
|
||||
-- If @_mousePressed == 0@: widget the mouse is hovering over,
|
||||
-- otherwise: widget the first button has been pressed on.
|
||||
, _mouseInside :: Bool -- ^@True@ if the mouse is currently within the mouse-active widget
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- |The button dependant state of a 'MouseState'.
|
||||
@ -195,7 +196,7 @@ data GUIBaseProperties m = BaseProperties
|
||||
-- The default implementations tests if the point is within the rectangle specified by the
|
||||
-- 'getBoundary' function.
|
||||
_isInside :: GUIWidget m
|
||||
-> Pixel -- ^screen position
|
||||
-> Pixel -- ^local coordinates
|
||||
-> m Bool
|
||||
,
|
||||
-- |The @_getPriority@ function returns the priority score of a @GUIWidget@.
|
||||
|
||||
@ -2,6 +2,8 @@ module UI.UIOperations where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad (liftM)
|
||||
--import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.RWS.Strict (get)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.Maybe
|
||||
|
||||
@ -19,6 +21,14 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
|
||||
{-# INLINABLE toGUIAnys #-}
|
||||
-- TODO: check for missing components?
|
||||
|
||||
-- | Tests whether a point is inside a widget by testing its bounding box first.
|
||||
isInsideFast :: Monad m => GUIWidget m
|
||||
-> Pixel -- ^ local coordinates
|
||||
-> m Bool
|
||||
isInsideFast wg px = do
|
||||
(_, _, w, h) <- wg ^. baseProperties.boundary
|
||||
liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
|
||||
|
||||
|
||||
-- |The function 'getInsideId' returns child widgets that overlap with a
|
||||
-- specific screen position and the pixel's local coordinates.
|
||||
@ -27,27 +37,49 @@ toGUIAnys m = mapMaybe (`Map.lookup` m)
|
||||
-- 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.
|
||||
getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
|
||||
-> Pixel -- ^screen position
|
||||
getInsideId :: Pixel -- ^parent’s local coordinates
|
||||
-> UIId -- ^the parent widget
|
||||
-> Pioneers [(UIId, Pixel)]
|
||||
getInsideId hMap px uid = do
|
||||
let wg = toGUIAny hMap uid
|
||||
bnd@(bX, bY, _, _) <- wg ^. baseProperties.boundary
|
||||
getInsideId px uid = do
|
||||
state <- get
|
||||
let wg = toGUIAny (state ^. ui.uiMap) uid
|
||||
(bX, bY, _, _) <- wg ^. baseProperties.boundary
|
||||
let px' = px -: (bX, bY)
|
||||
inside <- liftM (isInsideRect bnd px &&) $ (wg ^. baseProperties.isInside) wg px'
|
||||
inside <- isInsideFast wg px'
|
||||
if inside -- test inside parent's bounding box
|
||||
then do
|
||||
childrenIds <- wg ^. baseProperties.children
|
||||
hitChildren <- liftM concat $ mapM (getInsideId hMap px') childrenIds
|
||||
hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds
|
||||
case hitChildren of
|
||||
[] -> return [(uid, px')]
|
||||
_ -> return hitChildren
|
||||
else return []
|
||||
--TODO: Priority queue?
|
||||
--TODO: only needs to return single target if non-overlapping-child convention applies
|
||||
|
||||
-- TODO not needed if non-overlapping-child convention applies
|
||||
getLeadingWidget :: [(UIId, Pixel)] -- ^widgets and their screen positions
|
||||
-> Pioneers (Maybe (UIId, Pixel)) -- ^the leading widget
|
||||
getLeadingWidget [] = return Nothing
|
||||
getLeadingWidget (x:_) = return $ Just x
|
||||
|
||||
-- |The function 'isHittingChild' tests if a pixel is hitting a child of the given widget.
|
||||
--
|
||||
-- @'Left' 'False'@ is returned if the point is outside the widget,
|
||||
-- @'Left' 'True'@ is returned if the point is inside the widget and hits no child and
|
||||
-- 'Right' in combination with both the innermost hit child and the position’s local coordinates
|
||||
-- is returned otherwise.
|
||||
isHittingChild :: Pixel -- ^parent’s local coordinates
|
||||
-> GUIWidget Pioneers -- ^parent widget
|
||||
-> Pioneers (Either Bool (UIId, Pixel))
|
||||
isHittingChild px wg = do
|
||||
isIn <- isInsideFast wg px
|
||||
if isIn
|
||||
then do
|
||||
chld <- wg ^. baseProperties.children
|
||||
hitChld <- liftM concat $ mapM (getInsideId px) chld
|
||||
hitLead <- getLeadingWidget hitChld
|
||||
case hitLead of
|
||||
Nothing -> return $ Left True
|
||||
Just h -> return $ Right h
|
||||
else return $ Left False
|
||||
Loading…
Reference in New Issue
Block a user