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

31
src/Main.hs
View File

@ -44,7 +44,6 @@ import UI.Callbacks
import Map.Graphics import Map.Graphics
import Map.Creation (exportedMap) import Map.Creation (exportedMap)
import Types import Types
import qualified UI.UIBase as UI
import Importer.IQM.Parser import Importer.IQM.Parser
--import Data.Attoparsec.Char8 (parseTest) --import Data.Attoparsec.Char8 (parseTest)
--import qualified Data.ByteString as B --import qualified Data.ByteString as B
@ -65,15 +64,18 @@ testParser a = print =<< parseIQM a
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () 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.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.WindowShown -- window should be visible [SDL.WindowOpengl -- we want openGL
,SDL.WindowResizable -- and resizable ,SDL.WindowShown -- window should be visible
,SDL.WindowInputFocus -- focused (=> active) ,SDL.WindowResizable -- and resizable
,SDL.WindowMouseFocus -- Mouse into it ,SDL.WindowInputFocus -- focused (=> active)
--,WindowInputGrabbed-- never let go of input (KB/Mouse) ,SDL.WindowMouseFocus -- Mouse into it
] $ \window' -> do --,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window' -> do
SDL.withOpenGL window' $ do SDL.withOpenGL window' $ do
--Create Renderbuffer & Framebuffer --Create Renderbuffer & Framebuffer
@ -114,7 +116,6 @@ main =
let zDistClosest' = 2 let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10 zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage --TODO: Move near/far/fov to state for runtime-changability & central storage
(guiMap, guiRoots) = createGUI
aks = ArrowKeyState { aks = ArrowKeyState {
_up = False _up = False
, _down = False , _down = False
@ -140,8 +141,7 @@ main =
, _camera = cam' , _camera = cam'
, _camStack = camStack' , _camStack = camStack'
, _mouse = MouseState , _mouse = MouseState
{ _isDown = False { _isDragging = False
, _isDragging = False
, _dragStartX = 0 , _dragStartX = 0
, _dragStartY = 0 , _dragStartY = 0
, _dragStartXAngle = 0 , _dragStartXAngle = 0
@ -161,12 +161,7 @@ main =
, _glFramebuffer = frameBuffer , _glFramebuffer = frameBuffer
} }
, _game = game' , _game = game'
, _ui = UIState , _ui = createGUI initialWidth initialHeight
{ _uiHasChanged = True
, _uiMap = guiMap
, _uiRoots = guiRoots
, _uiButtonState = UI.UIButtonState 0 Nothing False
}
} }
putStrLn "init done." putStrLn "init done."

10
src/Types.hs
View File

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

126
src/UI/Callbacks.hs
View File

@ -3,17 +3,17 @@ module UI.Callbacks where
import qualified Graphics.Rendering.OpenGL.GL as GL 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 (liftM, when, unless)
import Control.Monad.RWS.Strict (ask, get, modify) import Control.Monad.RWS.Strict (ask, get, modify)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import Data.List (foldl') --import Data.List (foldl')
import Data.Maybe import Data.Maybe
import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL 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) import Control.Concurrent.STM (atomically)
@ -23,13 +23,19 @@ import UI.UIWidgets
import UI.UIOperations import UI.UIOperations
-- TODO: define GUI positions in a file -- TODO: define GUI positions in a file
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId]) createGUI :: ScreenUnit -> ScreenUnit -> UIState
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0) createGUI w h = UIState
, (UIId 1, createContainer (30, 215, 100, 80) [] 1) { _uiHasChanged = True
, (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3) , _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 ) , (UIId 1, createContainer (30, 215, 100, 80) [] 1)
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage) , (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
], [UIId 0]) , (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
]
, _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.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
getGUI = Map.elems getGUI = Map.elems
@ -69,9 +75,10 @@ eventCallback :: SDL.Event -> Pioneers ()
eventCallback e = do eventCallback e = do
env <- ask env <- ask
case SDL.eventData e of case SDL.eventData e of
SDL.Window _ _ -> -- windowID event SDL.Window _ ev -> -- windowID event
-- TODO: resize GUI case ev of
return () SDL.Resized (SDL.Size x y) -> windowResizeHandler x y
_ -> return ()
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
-- need modifiers? use "keyModifiers key" to get them -- need modifiers? use "keyModifiers key" to get them
let aks = keyboard.arrowsPressed in let aks = keyboard.arrowsPressed in
@ -103,40 +110,15 @@ eventCallback e = do
_ -> _ ->
return () return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
do mouseMoveHandler (x, y)
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)
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
do case state of
case button of SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
SDL.LeftButton -> do SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
let pressed = state == SDL.Pressed _ -> return ()
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
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 SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do do -- TODO: MouseWheelHandler
state <- get state <- get
liftIO $ atomically $ do liftIO $ atomically $ do
cam <- readTVar (state ^. camera) cam <- readTVar (state ^. camera)
@ -150,7 +132,18 @@ eventCallback e = do
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e] _ -> 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 () -> MouseButton -> Pixel -> Pioneers ()
mouseButtonHandler transFunc btn px = do mouseButtonHandler transFunc btn px = do
state <- get state <- get
@ -160,7 +153,7 @@ mouseButtonHandler transFunc btn px = do
Just (wid, px') -> do Just (wid, px') -> do
let target = toGUIAny hMap wid let target = toGUIAny hMap wid
target' <- case target ^. eventHandlers.(at MouseEvent) of 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 Nothing -> return target
modify $ ui.uiMap %~ Map.insert wid target' modify $ ui.uiMap %~ Map.insert wid target'
return () return ()
@ -229,7 +222,9 @@ mouseSetLeaving wid px = do
modify $ ui.uiButtonState.mouseInside .~ False modify $ ui.uiButtonState.mouseInside .~ False
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do 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' modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return () Nothing -> return ()
@ -245,7 +240,7 @@ mouseMoveHandler px = do
Left b -> -- no child hit Left b -> -- no child hit
if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler? 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' modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return () Nothing -> return ()
else if b then -- && not mouseInside --> entering else if b then -- && not mouseInside --> entering
@ -269,36 +264,6 @@ mouseMoveHandler px = do
mouseSetMouseActive px 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 -- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
-- --
--TODO: should be done asynchronously at one point. --TODO: should be done asynchronously at one point.
@ -320,7 +285,7 @@ prepareGUI = do
modify $ ui.uiHasChanged .~ False modify $ ui.uiHasChanged .~ False
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates.. --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 -> GUIWidget Pioneers -- ^the widget to draw
-> Pioneers () -> Pioneers ()
copyGUI tex (vX, vY) widget = do 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 --temporary color here. lateron better some getData-function to
--get a list of pixel-data or a texture. --get a list of pixel-data or a texture.
color = case widget ^. baseProperties.shorthand of color = case widget ^. baseProperties.shorthand of
"VWP" -> [0,128,128,0]
"CNT" -> [255,0,0,128] "CNT" -> [255,0,0,128]
"BTN" -> [255,255,0,255] "BTN" -> [255,255,0,255]
"PNL" -> [128,128,128,128] "PNL" -> [128,128,128,128]

254
src/UI/UIBase.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-}
-- widget data is separated into several modules to avoid cyclic dependencies with the Type module -- widget data is separated into several modules to avoid cyclic dependencies with the Type module
-- TODO: exclude UIMouseState constructor from export? -- TODO: exclude UIMouseState constructor from export?
module UI.UIBase where module UI.UIBase where
import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses) import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
import Control.Monad (liftM) import Control.Monad (join,liftM)
import Data.Array import Data.Array
import Data.Bits (xor) import Data.Bits (xor)
import Data.Hashable import Data.Hashable
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import Data.Ix () import Data.Ix ()
@ -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') merge f (x, y) (x', y') = (f x x', f y y')
{-# INLINABLE merge #-} {-# 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) (>:) :: (a -> b) -> (a, a) -> (b, b)
f >: (x, y) = (f x, f y) f >: (x, y) = (f x, f y)
{-# INLINABLE (>:) #-} {-# INLINABLE (>:) #-}
@ -87,7 +87,7 @@ data MouseButtonState = MouseButtonState
-- ^deferred if e. g. dragging but outside component -- ^deferred if e. g. dragging but outside component
} deriving (Eq, Show) } 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 = data WidgetState =
-- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'. -- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
MouseState MouseState
@ -101,67 +101,100 @@ data WidgetState =
--- events --- 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'. -- |A key to reference a specific 'EventHandler'.
data EventKey = MouseEvent | MouseMotionEvent data EventKey = WindowEvent | WidgetPositionEvent
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
hash = fromEnum hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x 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. instance Eq (EventHandler m) where
data EventHandler m = WindowHandler _ id' == WindowHandler _ id'' = id' == id''
-- |Handler to control the functionality of a 'GUIWidget' on mouse button events. _ == _ = False
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 ()
--------------------------- ---------------------------
@ -173,7 +206,7 @@ data GUIWidget m = Widget
{_baseProperties :: GUIBaseProperties m {_baseProperties :: GUIBaseProperties m
,_graphics :: GUIGraphics m ,_graphics :: GUIGraphics m
,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping ,_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'. -- |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. -- |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] _children :: m [UIId]
, ,
-- |The function @_isInside@ tests whether a point is inside the widget itself. -- |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 -- The default implementations tests if the point is within the rectangle specified by the
-- 'getBoundary' function. -- 'getBoundary' function.
_isInside :: GUIWidget m --
-> Pixel -- local coordinates -- The passed coordinates are widget-local coordinates.
-> m Bool _isInside :: GUIWidget m -> Pixel -> m Bool
, ,
-- |The @_getPriority@ function returns the priority score of a @GUIWidget@. -- |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. -- 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'. -- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
data GUIGraphics m = Graphics data GUIGraphics (m :: * -> *) = Graphics
{temp :: m Int}
$(makeLenses ''UIButtonState) $(makeLenses ''UIButtonState)
$(makeLenses ''WidgetState) $(makeLenses ''WidgetState)
$(makeLenses ''MouseButtonState) $(makeLenses ''MouseButtonState)
$(makeLenses ''EventHandler) $(makeLenses ''WidgetEventHandler)
$(makeLenses ''GUIWidget) $(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties) $(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIGraphics) $(makeLenses ''GUIGraphics)
-- |Creates a default @MouseButtonState@.
initialButtonState :: MouseButtonState initialButtonState :: MouseButtonState
initialButtonState = MouseButtonState False False initialButtonState = MouseButtonState False False
{-# INLINE initialButtonState #-} {-# INLINE initialButtonState #-}
-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@ -- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'.
-- provided in the passed list.
initialMouseState :: WidgetState initialMouseState :: WidgetState
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)]) initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
False (0, 0) False (0, 0)
{-# INLINE initialMouseState #-} {-# 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 -- 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'. -- only fully functional in conjunction with 'setMouseMotionStateActions'.
setMouseStateActions :: (Monad m) => EventHandler m setMouseStateActions :: (Monad m) => WidgetEventHandler m
setMouseStateActions = MouseHandler press' release' setMouseStateActions = MouseHandler press' release'
where where
-- |Change 'MouseButtonState's '_mouseIsDragging' to @True@. -- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@.
press' b _ w = press' b _ _ w =
return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
-- |Change 'MouseButtonState's '_mouseIsDragging' and '_mouseIsDeferred' to @False@. -- |Change 'MouseButtonState'’s '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
release' b _ w = release' b _ _ w =
return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~ return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
(mouseIsDragging .~ False) . (mouseIsDeferred .~ False) (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'. -- only fully functional in conjunction with 'setMouseStateActions'.
setMouseMotionStateActions :: (Monad m) => EventHandler m setMouseMotionStateActions :: (Monad m) => WidgetEventHandler m
setMouseMotionStateActions = MouseMotionHandler move' enter' leave' setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
where where
-- |Updates mouse position. -- |Updates mouse position.
move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p 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@. -- value and sets '_mouseIsDragging' to @False@.
enter' p w = return $ w & widgetStates.(ix MouseStateKey) enter' p w = return $ w & widgetStates.(ix MouseStateKey)
%~ (mouseIsReady .~ True) . (mousePixel .~ p) %~ (mouseIsReady .~ True) . (mousePixel .~ p)
@ -268,7 +338,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
. (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred))) . (\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@. -- value and sets '_mouseIsDeferred' to @False@.
leave' p w = return $ w & widgetStates.(ix MouseStateKey) leave' p w = return $ w & widgetStates.(ix MouseStateKey)
%~ (mouseIsReady .~ False) . (mousePixel .~ p) %~ (mouseIsReady .~ False) . (mousePixel .~ p)
@ -277,40 +347,38 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
. (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging))) . (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
-- TODO: make only fire if press started within widget -- 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 buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> EventHandler m -> WidgetEventHandler m
buttonMouseActions a = MouseHandler press' release' buttonMouseActions a = MouseHandler press' release'
where where
press' _ _ = return press' _ _ _ = return
release' b p w = do fire <- (w ^. baseProperties.isInside) w p release' b p inside w = if inside then a b w p else return w
if fire then a b w p else return w
-- TODO: make only fire if press started within widget -- 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 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' buttonSingleMouseActions a btn = MouseHandler press' release'
where where
press' _ _ = return press' _ _ _ = return
release' b p w = do fire <- liftM (b == btn &&) $ (w ^. baseProperties.isInside) w p release' b p inside w = if inside && b == btn then a w p else return w
if fire then a w p else return w
emptyGraphics :: (Monad m) => GUIGraphics m emptyGraphics :: (Monad m) => GUIGraphics m
emptyGraphics = Graphics (return 3) emptyGraphics = Graphics
-- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'. -- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit) extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit)
extractExtent (_,_,w,h) = (w,h) extractExtent (_,_,w,h) = (w,h)
{-# INLINABLE extractExtent #-} {-# 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 :: (ScreenUnit, ScreenUnit) -> Pixel -> Bool
isInsideExtent (w,h) (x',y') = (x' <= w) && (x' >= 0) && (y' <= h) && (y' >= 0) 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 module UI.UIOperations where
import Control.Lens ((^.)) import Control.Lens ((^.), (%~))
import Control.Monad (liftM) import Control.Monad (liftM)
--import Control.Monad.IO.Class (liftIO) --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 qualified Data.HashMap.Strict as Map
import Data.Hashable
--import qualified Data.List as L
import Data.Maybe import Data.Maybe
import Types import Types
@ -29,9 +31,44 @@ isInsideFast wg px = do
(_, _, w, h) <- wg ^. baseProperties.boundary (_, _, w, h) <- wg ^. baseProperties.boundary
liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px 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 -- |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 -- 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 -- 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 (bX, bY, _, _) <- wg ^. baseProperties.boundary
let px' = px -: (bX, bY) let px' = px -: (bX, bY)
inside <- isInsideFast wg px' inside <- isInsideFast wg px'
if inside -- test inside parent's bounding box if inside -- test inside parent’s bounding box
then do then do
childrenIds <- wg ^. baseProperties.children childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds 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 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
--import Control.Monad.IO.Class -- MonadIO import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get) import Control.Monad.RWS.Strict (get, modify)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import Types import Types
import UI.UIBase import UI.UIBase
import UI.UIOperations
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m 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 emptyGraphics
(Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
(Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers (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)