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

Merge branch 'ui' into iqm

Browse Source 
Conflicts:
	src/UI/UIBase.hs
This commit is contained in:
Nicole Dresselhaus 2014-06-15 03:29:03 +02:00
commit e512149461
No known key found for this signature in database
GPG Key ID: BC16D887851A1A80
6 changed files with 321 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
src/Main.hs
View File

@ -44,7 +44,6 @@ import UI.Callbacks
import Map.Graphics
import Map.Creation (exportedMap)
import Types
import qualified UI.UIBase as UI
import Importer.IQM.Parser
--import Data.Attoparsec.Char8 (parseTest)
--import qualified Data.ByteString as B
@ -65,9 +64,12 @@ testParser a = print =<< parseIQM a
--------------------------------------------------------------------------------
main :: IO ()
main =
main = do
let initialWidth = 1024
initialHeight = 600
SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl -- we want openGL
SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight)
[SDL.WindowOpengl -- we want openGL
,SDL.WindowShown -- window should be visible
,SDL.WindowResizable -- and resizable
,SDL.WindowInputFocus -- focused (=> active)
@ -114,7 +116,6 @@ main =
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage
(guiMap, guiRoots) = createGUI
aks = ArrowKeyState {
_up = False
, _down = False
@ -140,8 +141,7 @@ main =
, _camera = cam'
, _camStack = camStack'
, _mouse = MouseState
{ _isDown = False
, _isDragging = False
{ _isDragging = False
, _dragStartX = 0
, _dragStartY = 0
, _dragStartXAngle = 0
@ -161,12 +161,7 @@ main =
, _glFramebuffer = frameBuffer
}
, _game = game'
, _ui = UIState
{ _uiHasChanged = True
, _uiMap = guiMap
, _uiRoots = guiRoots
, _uiButtonState = UI.UIButtonState 0 Nothing False
}
, _ui = createGUI initialWidth initialHeight
}
putStrLn "init done."

10
src/Types.hs
View File

@ -62,8 +62,7 @@ data GameState = GameState
}
data MouseState = MouseState
{ _isDown :: !Bool
, _isDragging :: !Bool
{ _isDragging :: !Bool
, _dragStartX :: !Double
, _dragStartY :: !Double
, _dragStartXAngle :: !Double
@ -172,9 +171,10 @@ data GLState = GLState
data UIState = UIState
{ _uiHasChanged :: !Bool
, _uiMap :: Map.HashMap UIId (GUIWidget Pioneers)
, _uiRoots :: [UIId]
, _uiButtonState :: UIButtonState
, _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers))
, _uiObserverEvents :: !(Map.HashMap EventKey [EventHandler Pioneers])
, _uiRoots :: !([UIId])
, _uiButtonState :: !UIButtonState
}
data State = State

112
src/UI/Callbacks.hs
View File

@ -3,17 +3,17 @@ module UI.Callbacks where
import qualified Graphics.Rendering.OpenGL.GL as GL
import Control.Lens ((^.), (.~), (%~), (^?), at)
import Control.Lens ((^.), (.~), (%~), (^?), at, ix)
import Control.Monad (liftM, when, unless)
import Control.Monad.RWS.Strict (ask, get, modify)
import Control.Monad.Trans (liftIO)
import qualified Data.HashMap.Strict as Map
import Data.List (foldl')
--import Data.List (foldl')
import Data.Maybe
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL
import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar)
import Control.Concurrent.STM.TVar (readTVar, writeTVar)
import Control.Concurrent.STM (atomically)
@ -23,13 +23,19 @@ import UI.UIWidgets
import UI.UIOperations
-- TODO: define GUI positions in a file
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
createGUI :: ScreenUnit -> ScreenUnit -> UIState
createGUI w h = UIState
{ _uiHasChanged = True
, _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize
, (UIId 1, createContainer (30, 215, 100, 80) [] 1)
, (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
], [UIId 0])
]
, _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
, _uiRoots = [UIId 0]
, _uiButtonState = UIButtonState 0 Nothing False
}
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
getGUI = Map.elems
@ -69,9 +75,10 @@ eventCallback :: SDL.Event -> Pioneers ()
eventCallback e = do
env <- ask
case SDL.eventData e of
SDL.Window _ _ -> -- windowID event
-- TODO: resize GUI
return ()
SDL.Window _ ev -> -- windowID event
case ev of
SDL.Resized (SDL.Size x y) -> windowResizeHandler x y
_ -> return ()
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
-- need modifiers? use "keyModifiers key" to get them
let aks = keyboard.arrowsPressed in
@ -103,40 +110,15 @@ eventCallback e = do
_ ->
return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
do
state <- get
if state ^. mouse.isDown && not (state ^. mouse.isDragging)
then
do
cam <- liftIO $ readTVarIO (state ^. camera)
modify $ (mouse.isDragging .~ True)
. (mouse.dragStartX .~ fromIntegral x)
. (mouse.dragStartY .~ fromIntegral y)
. (mouse.dragStartXAngle .~ (cam ^. xAngle))
. (mouse.dragStartYAngle .~ (cam ^. yAngle))
else mouseMoveHandler (x, y)
modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
. (mouse.mousePosition. Types._y .~ fromIntegral y)
mouseMoveHandler (x, 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
if pressed
then mouseReleaseHandler LeftButton (x, y)
else do
st <- get
if st ^. mouse.isDragging then
modify $ mouse.isDragging .~ False
else do
mousePressHandler LeftButton (x, y)
_ -> case state of
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
do -- TODO: MouseWheelHandler
state <- get
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
@ -150,7 +132,18 @@ eventCallback e = do
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
windowResizeHandler :: ScreenUnit -> ScreenUnit -> Pioneers ()
windowResizeHandler x y = do
state <- get
case state ^. ui.uiObserverEvents.(at WindowEvent) of
Just evs -> let handle :: EventHandler Pioneers -> Pioneers (EventHandler Pioneers)
handle (WindowHandler h _) = h x y
handle h = return h -- TODO: may log invalid event mapping
in do newEvs <- mapM handle evs
modify $ ui.uiObserverEvents.(ix WindowEvent) .~ newEvs
Nothing -> return ()
mouseButtonHandler :: (WidgetEventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
-> MouseButton -> Pixel -> Pioneers ()
mouseButtonHandler transFunc btn px = do
state <- get
@ -160,7 +153,7 @@ mouseButtonHandler transFunc btn px = do
Just (wid, px') -> do
let target = toGUIAny hMap wid
target' <- case target ^. eventHandlers.(at MouseEvent) of
Just ma -> transFunc ma btn (px -: px') target
Just ma -> transFunc ma btn (px -: px') (state ^. ui.uiButtonState.mouseInside) target
Nothing -> return target
modify $ ui.uiMap %~ Map.insert wid target'
return ()
@ -229,7 +222,9 @@ mouseSetLeaving wid px = do
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
target_ <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust
target' <- if state ^. ui.uiButtonState.mousePressed <= 0 then return target_
else fromJust (ma ^? onMouseMove) px target_ --TODO unsafe fromJust
modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return ()
@ -245,7 +240,7 @@ mouseMoveHandler px = do
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
Just ma -> do target' <- fromJust (ma ^? onMouseMove) (px -: px') target
modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return ()
else if b then -- && not mouseInside --> entering
@ -269,36 +264,6 @@ mouseMoveHandler px = 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
roots <- getRootIds
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
state <- get
let w = toGUIAny (state ^. ui.uiMap) uid
short = w ^. baseProperties.shorthand
bound <- w ^. baseProperties.boundary
prio <- w ^. baseProperties.priority
liftIO $ putStrLn $ "hitting(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
++ show prio ++ " at [" ++ show x ++ "," ++ show y ++ "]"
case w ^. eventHandlers.(at MouseEvent) of
Just ma -> do w' <- fromJust (ma ^? onMousePress) btn pos' w -- TODO unsafe fromJust
w'' <- fromJust (ma ^? onMouseRelease) btn pos' w' -- TODO unsafe fromJust
return $ Just (uid, w'')
Nothing -> return Nothing
) hits
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 ()
-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
--
--TODO: should be done asynchronously at one point.
@ -320,7 +285,7 @@ prepareGUI = do
modify $ ui.uiHasChanged .~ False
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> Pixel -- ^current view's offset
copyGUI :: GL.TextureObject -> Pixel -- ^current view’s offset
-> GUIWidget Pioneers -- ^the widget to draw
-> Pioneers ()
copyGUI tex (vX, vY) widget = do
@ -332,6 +297,7 @@ copyGUI tex (vX, vY) widget = do
--temporary color here. lateron better some getData-function to
--get a list of pixel-data or a texture.
color = case widget ^. baseProperties.shorthand of
"VWP" -> [0,128,128,0]
"CNT" -> [255,0,0,128]
"BTN" -> [255,255,0,255]
"PNL" -> [128,128,128,128]

252
src/UI/UIBase.hs
View File

@ -1,10 +1,10 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-}
-- 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 Control.Monad (join,liftM)
import Data.Array
import Data.Bits (xor)
import Data.Hashable
@ -24,7 +24,7 @@ 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'.
-- |Maps 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 (>:) #-}
@ -87,7 +87,7 @@ data MouseButtonState = MouseButtonState
-- ^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.
-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'.
data WidgetState =
-- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
MouseState
@ -101,67 +101,100 @@ data WidgetState =
--- events
---------------------------
-- |A key to reference a specific 'WidgetEventHandler'.
data WidgetEventKey = MouseEvent | MouseMotionEvent
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable WidgetEventKey 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. Corresponding key: 'WidgetEventKey'.
data WidgetEventHandler m =
-- |Handler to control the functionality of a 'GUIWidget' on mouse button events.
--
-- All screen coordinates are widget-local coordinates.
MouseHandler
{
-- |The function 'onMousePressed' is called when a button is pressed
-- while the button is mouse-active.
--
-- The boolean value indicates if the button press happened within the widget
-- ('_isInside').
--
-- The function returns the altered widget resulting from the button press.
_onMousePress :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseReleased' is called when a button is released
-- while the widget is mouse-active.
--
-- Thus, the mouse is either within the widget or outside while still dragging.
--
--
-- The boolean value indicates if the button release happened within the widget
-- ('_isInside').
--
-- The function returns the altered widget resulting from the button press.
_onMouseRelease :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m)
}
|
-- |Handler to control the functionality of a 'GUIWidget' on mouse movement.
--
-- All screen coordinates are widget-local coordinates.
MouseMotionHandler
{
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-- widget’s extent ('isInside') while no button is pressed or when the mouse is inside the
-- widget’s extent while another button loses its mouse-active state. Triggered after
-- '_onMouseEnter' or '_onMouseLeave' (only if still mouse-active on leaving) if applicable.
--
-- The function returns the altered widget resulting from the button press.
_onMouseMove :: Pixel -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseMove' is invoked when the mouse enters the
-- widget’s extent ('isInside') or when the mouse is inside the
-- widget’s extent while another button loses its mouse-active state.
--
-- The function returns the altered widget resulting from the button press.
_onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseLeave' is invoked when the mouse leaves the
-- widget’s extent ('isInside') while no other widget is mouse-active.
--
-- The function returns the altered widget resulting from the button press.
_onMouseLeave :: Pixel -> GUIWidget m -> m (GUIWidget m)
}
deriving ()
-- |A key to reference a specific 'EventHandler'.
data EventKey = MouseEvent | MouseMotionEvent
data EventKey = WindowEvent | WidgetPositionEvent
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. Corresponding key: 'EventKey'.
data EventHandler (m :: * -> *) =
WindowHandler
{
-- |The function '_onWindowResize' is invoked when the global application window changes size.
--
-- The input is the window’s new width and height in that order.
--
-- The returned handler is resulting handler that may change by the event. Its type must
-- remain @WindowHandler@.
_onWindowResize :: ScreenUnit -> ScreenUnit -> m (EventHandler m)
,
-- |Unique id to identify an event instance.
_eventId :: UIId
}
-- |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 the widget is mouse-active.
--
-- A widget becomes mouse-active if no other button is currently pressed and the mouse
-- coordinates are within the widget's extent ('isInside') until no button is pressed any
-- more.
_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 widget is mouse-active.
--
-- 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
}
|
-- |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 extent ('isInside') while no button is pressed or when the mouse is inside the
-- widget's extent while another button loses its mouse-active state. Triggered after
-- '_onMouseEnter'.
_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 extent ('isInside') or when the mouse is inside the
-- widget's extent while another button loses its mouse-active state..
_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 'onMouseLeave' is invoked when the mouse leaves the
-- widget's extent ('isInside') while no other widget is mouse-active.
_onMouseLeave :: Pixel -- screen position
-> GUIWidget m -- widget the event is invoked on
-> m (GUIWidget m) -- widget after the event and the altered handler
}
deriving ()
instance Eq (EventHandler m) where
WindowHandler _ id' == WindowHandler _ id'' = id' == id''
_ == _ = False
---------------------------
@ -173,7 +206,7 @@ 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
,_eventHandlers :: Map.HashMap WidgetEventKey (WidgetEventHandler m) -- no guarantee that data match key
}
-- |Base properties are fundamental settings of any 'GUIWidget'.
@ -186,7 +219,7 @@ data GUIBaseProperties m = BaseProperties
,
-- |The @_getChildren@ function returns all children associated with this widget.
--
-- All children must be wholly inside the parent's bounding box specified by '_boundary'.
-- 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.
@ -195,9 +228,9 @@ data GUIBaseProperties m = BaseProperties
--
-- The default implementations tests if the point is within the rectangle specified by the
-- 'getBoundary' function.
_isInside :: GUIWidget m
-> Pixel -- local coordinates
-> m Bool
--
-- The passed coordinates are widget-local coordinates.
_isInside :: GUIWidget m -> Pixel -> 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.
@ -212,54 +245,91 @@ data GUIBaseProperties m = BaseProperties
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
data GUIGraphics m = Graphics
{temp :: m Int}
data GUIGraphics (m :: * -> *) = Graphics
$(makeLenses ''UIButtonState)
$(makeLenses ''WidgetState)
$(makeLenses ''MouseButtonState)
$(makeLenses ''EventHandler)
$(makeLenses ''WidgetEventHandler)
$(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIGraphics)
-- |Creates a default @MouseButtonState@.
initialButtonState :: MouseButtonState
initialButtonState = MouseButtonState False False
{-# INLINE initialButtonState #-}
-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
-- provided in the passed list.
-- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'.
initialMouseState :: WidgetState
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
False (0, 0)
{-# INLINE initialMouseState #-}
-- TODO: combined mouse handler
-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions
-- of two handlers. Thereby, the resulting widget of the first handler is the input widget of the
-- second handler and all other parameters are the same for both function calls.
--
-- If not both input handlers are of type @MouseHandler@ an error is raised.
combinedMouseHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) =
MouseHandler (comb p1 p2) (comb r1 r2)
where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside
combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two WidgetEventHandler" ++
" with constructor MouseHandler"
-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action
-- functions of two handlers. Thereby, the resulting widget of the second handler is the input
-- widget of the second handler and all other parameters are the same for both function calls.
--
-- If not both input handlers are of type @MouseMotionHandler@ an error is raised.
combinedMouseMotionHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) =
MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2)
where comb h1 h2 px = join . liftM (h2 px) . h1 px
combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two WidgetEventHandler" ++
" with constructor MouseMotionHandler"
-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing.
-- It may be useful as construction kit.
--
-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction
-- >>> emptyMouseHandler { _onMousePress = myPressFunction }
emptyMouseHandler :: (Monad m) => WidgetEventHandler m
emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing.
-- It may be useful as construction kit.
--
-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction
-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction }
emptyMouseMotionHandler :: (Monad m) => WidgetEventHandler m
emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return)
-- TODO? breaks if button 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 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present,
-- only fully functional in conjunction with 'setMouseMotionStateActions'.
setMouseStateActions :: (Monad m) => EventHandler m
setMouseStateActions :: (Monad m) => WidgetEventHandler m
setMouseStateActions = MouseHandler press' release'
where
-- |Change 'MouseButtonState's '_mouseIsDragging' to @True@.
press' b _ w =
-- |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 =
-- |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,
-- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present,
-- only fully functional in conjunction with 'setMouseStateActions'.
setMouseMotionStateActions :: (Monad m) => EventHandler m
setMouseMotionStateActions :: (Monad m) => WidgetEventHandler 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
-- |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)
@ -268,7 +338,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
. (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred)))
-- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred's current
-- |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)
@ -277,40 +347,38 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
. (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
-- TODO: make only fire if press started within widget
-- |Creates a MouseHandler that reacts on mouse clicks.
-- |Creates a 'MouseHandler' that reacts on mouse clicks.
--
-- Does /not/ update 'WidgetState MouseState'!
-- Does /not/ update the widget’s 'MouseState'!
buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> EventHandler m
-> WidgetEventHandler m
buttonMouseActions a = MouseHandler press' release'
where
press' _ _ = return
press' _ _ _ = return
release' b p w = do fire <- (w ^. baseProperties.isInside) w p
if fire then a b w p else return w
release' b p inside w = if inside then a b w p else return w
-- TODO: make only fire if press started within widget
-- |Creates a MouseHandler that reacts on mouse clicks.
-- |Creates a 'MouseHandler' that reacts on mouse clicks.
--
-- Does /not/ update 'WidgetState MouseState'!
-- Does /not/ update the widget’s 'MouseState'!
buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> MouseButton -> EventHandler m
-> MouseButton -> WidgetEventHandler m
buttonSingleMouseActions a btn = MouseHandler press' release'
where
press' _ _ = return
press' _ _ _ = return
release' b p w = do fire <- liftM (b == btn &&) $ (w ^. baseProperties.isInside) w p
if fire then a w p else return w
release' b p inside w = if inside && b == btn then a w p else return w
emptyGraphics :: (Monad m) => GUIGraphics m
emptyGraphics = Graphics (return 3)
emptyGraphics = Graphics
-- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
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.
-- |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)

45
src/UI/UIOperations.hs
View File

@ -1,10 +1,12 @@
module UI.UIOperations where
import Control.Lens ((^.))
import Control.Lens ((^.), (%~))
import Control.Monad (liftM)
--import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get)
import Control.Monad.RWS.Strict (get, modify)
import qualified Data.HashMap.Strict as Map
import Data.Hashable
--import qualified Data.List as L
import Data.Maybe
import Types
@ -29,9 +31,44 @@ isInsideFast wg px = do
(_, _, w, h) <- wg ^. baseProperties.boundary
liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
-- |Adds an event to the given map. The new event is concatenated to present events. Does not test
-- if the map already contains the given element.
addEvent :: (Eq k, Hashable k) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
addEvent k v eventMap = Map.insertWith (++) k [v] eventMap
-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
registerEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
registerEvent k v = modify $ ui.uiObserverEvents %~ addEvent k v
-- |The 'deleteQualitative' function behaves like 'Data.List.deleteBy' but reports @True@ if the
-- list contained the relevant object.
deleteQualitative :: (a -> a -> Bool) -> a -> [a] -> ([a], Bool)
deleteQualitative _ _ [] = ([], False)
deleteQualitative eq x (y:ys) = if x `eq` y then (ys, True) else
let (zs, b) = deleteQualitative eq x ys
in (y:zs, b)
-- |Removes the first occurrence of an event from the given map if it is within the event list of
-- the key.
removeEvent :: (Eq k, Hashable k, Eq v) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
removeEvent k v eventMap =
case Map.lookup k eventMap of
Just list -> case deleteQualitative (==) v list of
(_, False) -> eventMap
(ys, _) -> case ys of
[] -> Map.delete k eventMap
_ -> Map.insert k ys eventMap
Nothing -> Map.insert k [v] eventMap
-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
deregisterEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
deregisterEvent k v = modify $ ui.uiObserverEvents %~ removeEvent k v
-- |The function 'getInsideId' returns child widgets that overlap with a
-- specific screen position and the pixel's local coordinates.
-- specific screen position and the pixel’s local coordinates.
--
-- 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
@ -46,7 +83,7 @@ getInsideId px uid = do
(bX, bY, _, _) <- wg ^. baseProperties.boundary
let px' = px -: (bX, bY)
inside <- isInsideFast wg px'
if inside -- test inside parent's bounding box
if inside -- test inside parent’s bounding box
then do
childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds

59
src/UI/UIWidgets.hs
View File

@ -2,16 +2,18 @@
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Lens ((^.), (.~), (&))
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Lens ((^.), (.~), (%~), (&))
import Control.Monad
--import Control.Monad.IO.Class -- MonadIO
import Control.Monad.RWS.Strict (get)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify)
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
import Types
import UI.UIBase
import UI.UIOperations
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
@ -43,3 +45,54 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
emptyGraphics
(Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
(Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers
createViewport :: MouseButton -- ^ button to drag with
-> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
emptyGraphics
Map.empty -- widget states
(Map.fromList [(MouseEvent, viewportMouseAction)
,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
where
viewportMouseAction :: WidgetEventHandler Pioneers
viewportMouseAction =
let press btn' (x, y) _ w =
do when (btn == btn') $ do
state <- get
cam <- liftIO $ readTVarIO (state ^. camera)
modify $ mouse %~ (isDragging .~ True)
. (dragStartX .~ fromIntegral x)
. (dragStartY .~ fromIntegral y)
. (dragStartXAngle .~ (cam ^. xAngle))
. (dragStartYAngle .~ (cam ^. yAngle))
. (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w
release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False)
return w
in MouseHandler press release
viewportMouseMotionAction :: WidgetEventHandler Pioneers
viewportMouseMotionAction =
let move (x, y) w =
do state <- get
when (state ^. mouse.isDragging) $
modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w
in emptyMouseMotionHandler & onMouseMove .~ move
resizeToScreenHandler :: UIId -- ^id of a widget
-> EventHandler Pioneers
resizeToScreenHandler id' = WindowHandler resize (UIId 0) -- TODO: unique id
where resize :: ScreenUnit -> ScreenUnit -> Pioneers (EventHandler Pioneers)
resize w h = do
state <- get
let wg = toGUIAny (state ^. ui.uiMap) id'
(x, y, _, _) <- wg ^. baseProperties.boundary
let wg' = wg & baseProperties.boundary .~ return (x, y, w-x, h-y)
modify $ ui.uiMap %~ Map.insert id' wg'
return $ WindowHandler resize (UIId 0)