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

Merge remote-tracking branch 'origin/ui'

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-05-06 11:31:12 +02:00
commit ea09cd1a97
8 changed files with 453 additions and 491 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
src/Main.hs
View File

@ -322,81 +322,18 @@ processEvents = do
processEvent :: Event -> Pioneers ()
processEvent e = do
env <- ask
case eventData e of
Window _ winEvent ->
eventCallback e
-- env <- ask
case SDL.eventData e of
SDL.Window _ winEvent -> -- windowID event
case winEvent of
Closing ->
SDL.Closing ->
modify $ window.shouldClose .~ True
Resized {windowResizedTo=size} -> do
modify $ (window . width .~ sizeWidth size)
. (window . height .~ sizeHeight size)
SDL.Resized {windowResizedTo=size} -> do
modify $ (window . width .~ SDL.sizeWidth size)
. (window . height .~ SDL.sizeHeight size)
adjustWindow
SizeChanged ->
SDL.SizeChanged ->
adjustWindow
_ ->
return ()
--liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
Keyboard movement _ _{-isRepeated-} key -> --up/down window(ignored) true/false actualKey
-- need modifiers? use "keyModifiers key" to get them
let aks = keyboard.arrowsPressed in
case keyScancode key of
SDL.R ->
liftIO $ do
r <- getRenderer $ env ^. windowObject
putStrLn $ unwords ["Renderer: ",show r]
Escape ->
modify $ window.shouldClose .~ True
SDL.Left ->
modify $ aks.left .~ (movement == KeyDown)
SDL.Right ->
modify $ aks.right .~ (movement == KeyDown)
SDL.Up ->
modify $ aks.up .~ (movement == KeyDown)
SDL.Down ->
modify $ aks.down .~ (movement == KeyDown)
SDL.KeypadPlus ->
when (movement == KeyDown) $ do
modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1))
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
SDL.KeypadMinus ->
when (movement == KeyDown) $ do
modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1)))
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
_ ->
return ()
MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do
state <- get
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
modify $ (mouse.isDragging .~ True)
. (mouse.dragStartX .~ (fromIntegral x))
. (mouse.dragStartY .~ (fromIntegral y))
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
. (mouse.mousePosition. Types._y .~ (fromIntegral y))
MouseButton _ _{-mouseId-} button state (SDL.Position x y) ->
case button of
LeftButton -> do
let pressed = state == Pressed
modify $ mouse.isDown .~ pressed
unless pressed $ do
st <- get
if st ^. mouse.isDragging then
modify $ mouse.isDragging .~ False
else
clickHandler (UI.Callbacks.Pixel x y)
RightButton -> do
when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
_ ->
return ()
MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do
state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
Quit -> modify $ window.shouldClose .~ True
-- there is more (joystic, touchInterface, ...), but currently ignored
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
_ -> return ()
_ -> return ()

4
src/Types.hs
View File

@ -12,7 +12,7 @@ import Control.Monad.RWS.Strict (RWST)
import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types
import UI.UIBaseData
import UI.UIBase
--Static Read-Only-State
@ -135,7 +135,7 @@ data GLState = GLState
data UIState = UIState
{ _uiHasChanged :: !Bool
, _uiMap :: Map.HashMap UIId (GUIAny Pioneers)
, _uiMap :: Map.HashMap UIId (GUIWidget Pioneers)
, _uiRoots :: [UIId]
}

175
src/UI/Callbacks.hs
View File

@ -2,91 +2,168 @@ module UI.Callbacks where
import qualified Graphics.Rendering.OpenGL.GL as GL
import Control.Lens ((^.), (.~))
import Control.Monad (liftM)
import Control.Monad.RWS.Strict (get, modify)
import Control.Lens ((^.), (.~), (%~))
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.Maybe
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
import Render.Misc (genColorData)
import qualified Graphics.UI.SDL as SDL
import Render.Misc (curb,genColorData)
import Types
import UI.UIBaseData
import UI.UIClasses
import UI.UIWidgets
import UI.UIOperations
data Pixel = Pixel Int Int
createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
, (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
, (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
, (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 )
, (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage))
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
, (UIId 1, createContainer (20, 50, 120, 80) [] 1)
, (UIId 2, createPanel (100, 140, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (100, 140, 130, 200) [] 4 )
, (UIId 4, createButton (30, 200, 60, 175) 2 testMessage)
], [UIId 0])
getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers]
getGUI hmap = Map.elems hmap
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
getGUI = Map.elems
{-# INLINE getGUI #-}
getRootIds :: Pioneers [UIId]
getRootIds = do
state <- get
return $ state ^. ui.uiRoots
getRoots :: Pioneers [GUIAny Pioneers]
getRoots :: Pioneers [GUIWidget Pioneers]
getRoots = do
state <- get
rootIds <- getRootIds
let hMap = state ^. ui.uiMap
return $ toGUIAnys hMap rootIds
testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w
testMessage w x y = do
liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
testMessage :: MouseButton -> w -> Pixel -> Pioneers w
testMessage btn w (x, y) = do
case btn of
LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y)
RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y)
MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y)
MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y)
MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y)
return w
transformButton :: SDL.MouseButton -> Maybe MouseButton
transformButton SDL.LeftButton = Just LeftButton
transformButton SDL.RightButton = Just RightButton
transformButton SDL.MiddleButton = Just MiddleButton
transformButton SDL.MouseX1 = Just MouseX1
transformButton SDL.MouseX2 = Just MouseX2
transformButton _ = Nothing
eventCallback :: SDL.Event -> Pioneers ()
eventCallback e = do
env <- ask
case SDL.eventData e of
SDL.Window _ _ -> -- windowID event
-- TODO: resize GUI
return ()
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
-- need modifiers? use "keyModifiers key" to get them
let aks = keyboard.arrowsPressed in
case SDL.keyScancode key of
SDL.R ->
liftIO $ do
r <- SDL.getRenderer $ env ^. windowObject
putStrLn $ unwords ["Renderer: ",show r]
SDL.Escape ->
modify $ window.shouldClose .~ True
SDL.Left ->
modify $ aks.left .~ (movement == SDL.KeyDown)
SDL.Right ->
modify $ aks.right .~ (movement == SDL.KeyDown)
SDL.Up ->
modify $ aks.up .~ (movement == SDL.KeyDown)
SDL.Down ->
modify $ aks.down .~ (movement == SDL.KeyDown)
SDL.KeypadPlus ->
when (movement == SDL.KeyDown) $ do
modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1))
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
SDL.KeypadMinus ->
when (movement == SDL.KeyDown) $ do
modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1)))
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
_ ->
return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
do
state <- get
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
modify $ (mouse.isDragging .~ True)
. (mouse.dragStartX .~ (fromIntegral x))
. (mouse.dragStartY .~ (fromIntegral y))
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
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
case button of
SDL.LeftButton -> do
let pressed = state == SDL.Pressed
modify $ mouse.isDown .~ pressed
unless pressed $ do
st <- get
if st ^. mouse.isDragging then
modify $ mouse.isDragging .~ False
else
clickHandler LeftButton (x, y)
_ -> do when (state == SDL.Released)
$ maybe (return ()) (`clickHandler` (x, y)) $ transformButton button
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do
state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
-- there is more (joystic, touchInterface, ...), but currently ignored
SDL.Quit -> modify $ window.shouldClose .~ True
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
-- | Handler for UI-Inputs.
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
clickHandler :: Pixel -> Pioneers ()
clickHandler (Pixel x y) = do
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 x y) roots
hits <- liftM concat $ mapM (getInsideId hMap pos) roots
case hits of
[] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
[] -> liftIO $ putStrLn $ unwords [show btn ++ ":press on (",show x,",",show y,")"]
_ -> do
changes <- sequence $ map (\uid -> do
changes <- mapM (\uid -> do
let w = toGUIAny hMap uid
short <- getShorthand w
bound <- getBoundary w
prio <- getPriority w
short = w ^. baseProperties.shorthand
bound <- w ^. baseProperties.boundary
prio <- w ^. baseProperties.priority
liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
++ " at [" ++ show x ++ "," ++ show y ++ "]"
case w of
(GUIAnyB b h) -> do
(b', h') <- onMousePressed x y b h
(b'', h'') <- onMouseReleased x y b' h'
return $ Just (uid, GUIAnyB b'' h'')
_ -> return Nothing
case w ^. mouseActions of
Just ma -> do w' <- (ma ^. onMousePress) btn pos w
w'' <- (ma ^. onMouseRelease) btn pos w'
return $ Just (uid, w'')
Nothing -> return Nothing
) $ hits
let newMap :: Map.HashMap UIId (GUIAny Pioneers)
let newMap :: Map.HashMap UIId (GUIWidget Pioneers)
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
modify $ ui.uiMap .~ newMap
return ()
-- | Handler for UI-Inputs.
-- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
alternateClickHandler :: Pixel -> Pioneers ()
alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"]
-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
--
--TODO: should be done asynchronously at one point.
@ -108,19 +185,19 @@ prepareGUI = do
modify $ ui.uiHasChanged .~ False
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers ()
copyGUI :: GL.TextureObject -> GUIWidget Pioneers -> Pioneers ()
copyGUI tex widget = do
(xoff, yoff, wWidth, wHeight) <- getBoundary widget
(xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
state <- get
let
hMap = state ^. ui.uiMap
int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
--temporary color here. lateron better some getData-function to
--get a list of pixel-data or a texture.
color = case widget of
(GUIAnyC _) -> [255,0,0,128]
(GUIAnyB _ _) -> [255,255,0,255]
(GUIAnyP _) -> [128,128,128,128]
color = case widget ^. baseProperties.shorthand of
"CNT" -> [255,0,0,128]
"BTN" -> [255,255,0,255]
"PNL" -> [128,128,128,128]
_ -> [255,0,255,255]
liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
--copy data into C-Array
@ -131,7 +208,7 @@ copyGUI tex widget = do
(GL.TexturePosition2D (int xoff) (int yoff))
(GL.TextureSize2D (int wWidth) (int wHeight))
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
nextChildrenIds <- getChildren widget
nextChildrenIds <- widget ^. baseProperties.children
mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.

232
src/UI/UIBase.hs Normal file
View File

@ -0,0 +1,232 @@
{-# 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, to, mapped, traverse, makeLenses)
import Control.Monad (liftM)
import Data.Array
import Data.Hashable
import Data.Ix ()
import Data.Maybe
import GHC.Generics (Generic)
-- |Unit of screen/window
type ScreenUnit = Int
-- | @x@ and @y@ position on screen.
type Pixel = (ScreenUnit, ScreenUnit)
newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable MouseButton
firstButton :: MouseButton
firstButton = LeftButton
lastButton :: MouseButton
lastButton = MiddleButton
-- |The button dependant state of a 'UIMouseState'.
data UIMouseStateSingle = MouseStateSingle
{ _mouseIsFiring :: Bool -- ^firing if pressed but not confirmed
, _mouseIsDeferred :: Bool
-- ^deferred if e. g. dragging but outside component
} deriving (Eq, Show)
-- |The state of a clickable ui widget.
data UIMouseState = MouseState
{ _mouseStates :: Array MouseButton UIMouseStateSingle
, _mouseIsReady :: Bool -- ^ready if mouse is above component
} deriving (Eq, Show)
-- |Switches primary and secondary mouse actions.
-- "monad type" "widget type" "original handler"
data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
data ButtonHandler m w = ButtonHandler
{ _action :: w -> Pixel -> m w }
instance Show (ButtonHandler m w) where
show _ = "ButtonHandler ***"
-- |A @GUIWidget@ is a visual object the HUD is composed of.
data GUIWidget m = Widget
{_baseProperties :: GUIBaseProperties m
,_mouseActions :: Maybe (GUIMouseActions m)
,_graphics :: GUIGraphics m
}
-- |Base properties are fundamental settings of any 'GUIWidget'.
-- They mostly control positioning and widget hierarchy.
data GUIBaseProperties m = BaseProperties
{
-- |The @_getBoundary@ function gives the outer extents of the @GUIWidget@.
-- The bounding box wholly contains all children components.
_boundary :: m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
,
-- |The @_getChildren@ function returns all children associated with this widget.
--
-- All children must be wholly inside the parent's bounding box specified by '_boundary'.
_children :: m [UIId]
,
-- |The function @_isInside@ tests whether a point is inside the widget itself.
-- A screen position may be inside the bounding box of a widget but not considered part of the
-- component.
--
-- The default implementations tests if the point is within the rectangle specified by the
-- 'getBoundary' function.
_isInside :: GUIWidget m
-> Pixel -- ^screen position
-> m Bool
,
-- |The @_getPriority@ function returns the priority score of a @GUIWidget@.
-- A widget with a high score is more in the front than a low scored widget.
_priority :: m Int
,
-- |The @_getShorthand@ function returns a descriptive 'String' mainly for debuggin prupose.
-- The shorthand should be unique for each instance.
_shorthand :: String
}
-- |Mouse actions control the functionality of a 'GUIWidget' on mouse events.
data GUIMouseActions m = MouseActions
{
-- |The @_mouseState@ function returns the current mouse state of a widget.
_mouseState :: UIMouseState
,
-- |The function 'onMousePressed' is called when a button is pressed
-- while inside a screen coordinate within the widget ('isInside').
_onMousePress :: MouseButton -- ^the pressed button
-> Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the possibly altered mouse handler
,
-- |The function 'onMouseReleased' is called when a button is released
-- while the pressing event occured within the widget ('isInside').
--
-- Thus, the mouse is either within the widget or outside while still dragging.
_onMouseRelease :: MouseButton -- ^the released button
-> Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-- widget's space ('isInside').
_onMouseMove :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse enters the
-- widget's space ('isInside').
_onMouseEnter :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
,
-- |The function 'onMouseMove' is invoked when the mouse leaves the
-- widget's space ('isInside').
_onMouseLeave :: Pixel -- ^screen position
-> GUIWidget m -- ^widget the event is invoked on
-> m (GUIWidget m) -- ^widget after the event and the altered handler
}
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
data GUIGraphics m = Graphics
{temp :: m Int}
$(makeLenses ''UIMouseState)
$(makeLenses ''UIMouseStateSingle)
$(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIMouseActions)
$(makeLenses ''GUIGraphics)
initialMouseStateS :: UIMouseStateSingle
initialMouseStateS = MouseStateSingle False False
{-# INLINE initialMouseStateS #-}
-- |Creates a @UIMouseState@ its @_mouseStates@ are valid 'UIMouseStateSingle' for any @MouseButton@
-- provided in the passed list.
initialMouseState :: UIMouseState
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialMouseStateS) | i <- range (minBound, maxBound)])
False
{-# INLINE initialMouseState #-}
emptyMouseAction :: (Monad m) => GUIMouseActions m
emptyMouseAction = MouseActions initialMouseState empty'' empty'' empty' empty' empty'
where empty' _ = return
empty'' _ _ = return
-- TODO: combined mouse handler
-- TODO? breaks if array not of sufficient size -- will be avoided by excluding constructor export
-- |Creates a @GUIMouseActions@ handler that enables button clicks.
--
-- The action is peformed right before the button state change.
buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> GUIMouseActions m
buttonMouseActions a = MouseActions initialMouseState press' release' move' enter' leave'
where
-- |Change 'UIMouseState's '_mouseIsFiring' to @True@.
press' b _ w =
return $ w & mouseActions.traverse.mouseState.mouseStates.(ix b).mouseIsFiring .~ True
-- |Change 'UIMouseState's '_mouseIsFiring' and '_mouseIsDeferred' to @False@ and
-- call action if '_mouseIsFiring' was @True@.
release' b p w =
let fire = w ^. mouseActions.(to fromJust).mouseState.mouseStates.(to (!b)).mouseIsFiring -- TODO? may break if initialized and called wrongly
in do w' <- if fire
then a b w p
else return w
return $ w' & mouseActions.traverse.mouseState.mouseStates.(ix b) %~
(mouseIsFiring .~ False) . (mouseIsDeferred .~ False)
-- |Do nothing.
move' _ = return
-- |Set 'UIMouseState's '_mouseIsReady' to @True@ and
-- update dragging state (only drag if inside widget).
-- In detail, change 'UIMouseState's '_mouseIsDeferred' to '_mouseIsFiring's current value
-- and set '_mouseIsFiring' to @False@.
enter' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ True)
.(mouseStates.mapped %~ (mouseIsDeferred .~ False)
-- following line executed BEFORE above line
.(\sState -> sState & mouseIsFiring .~ not (sState ^. mouseIsDeferred)))
-- |Set 'UIMouseState's 'buttonstateIsReady' to @False@ and
-- update dragging state (only drag if inside widget).
-- In detail, change 'UIMouseState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
-- and set '_buttonstateIsDeferred's' to @False@.
leave' _ w = return $ w & mouseActions.traverse.mouseState %~ (mouseIsReady .~ False)
.(mouseStates.mapped %~ (mouseIsFiring .~ False)
-- following line executed BEFORE above line
.(\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsFiring)))
emptyGraphics :: (Monad m) => GUIGraphics m
emptyGraphics = Graphics (return 3)
isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
isInsideRect (x,y,w,h) (x',y') = (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
rectangularBase bnd chld prio short =
BaseProperties (return bnd) (return chld)
(\w p -> liftM (`isInsideRect` p) (w ^. baseProperties.boundary))
(return prio) short
debugShowWidget' :: (Monad m) => GUIWidget m -> m String
debugShowWidget' (Widget base mouse _) = do
bnd <- base ^. boundary
chld <- base ^. children
prio <- base ^. priority
let short = base ^. shorthand
return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
",priority:",show prio, maybe "" (const ", with mouse handler") mouse]

74
src/UI/UIBaseData.hs
View File

@ -1,74 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- data and classes are separated into several modules to avoid cyclic dependencies with the Type module
module UI.UIBaseData where
import Data.Hashable
import Data.Ix
-- |Unit of screen/window
type ScreenUnit = Int
newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
-- |The state of a clickable ui widget.
data UIButtonState = UIButtonState
{ _buttonstateIsFiring :: Bool
-- ^firing if pressed but not confirmed
, _buttonstateIsFiringAlt :: Bool
-- ^firing if pressed but not confirmed (secondary mouse button)
, _buttonstateIsDeferred :: Bool -- ^ deferred if e. g. dragging but outside component
, _buttonstateIsDeferredAlt :: Bool
-- ^deferred if e. g. dragging but outside component (secondary mouse button)
, _buttonstateIsReady :: Bool
-- ^ready if mouse is above component
, _buttonstateIsActivated :: Bool
-- ^in activated state (e. g. toggle button)
} deriving (Eq, Show)
-- |Switches primary and secondary mouse actions.
-- "monad type" "widget type" "original handler"
data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
-- |A 'UI.UIClasses.MouseHandler' with button behaviour.
data ButtonHandler m w = ButtonHandler
{ _action :: (w -> ScreenUnit -> ScreenUnit -> m w) }
instance Show (ButtonHandler m w) where
show _ = "ButtonHandler ***"
-- |A collection data type that may hold any usable ui element. @m@ is a monad.
data GUIAny m = GUIAnyC GUIContainer
| GUIAnyP GUIPanel
| GUIAnyB GUIButton (ButtonHandler m GUIButton)
deriving (Show)
-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
-- functionality itself.
data GUIContainer = GUIContainer { _uiScreenX :: ScreenUnit, _uiScreenY :: ScreenUnit
, _uiWidth :: ScreenUnit, _uiHeight :: ScreenUnit
, _uiChildren :: [UIId]
, _uiPriority :: Int
} deriving (Show)
-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
-- children components.
data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
-- |A 'GUIButton' is a clickable 'GUIWidget'. Its functinality must be
-- provided by an appropriate 'MouseHanlder'.
data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUnit
, _uiWidthB :: ScreenUnit, _uiHeightB :: ScreenUnit
, _uiPriorityB :: Int
, _uiButtonState :: UIButtonState
} deriving ()
instance Show GUIButton where
show w = "GUIButton {_screenXB = " ++ show (_uiScreenXB w)
++ " _screenYB = " ++ show (_uiScreenYB w)
++ " _widthB = " ++ show (_uiWidthB w)
++ " _heightB = " ++ show (_uiHeightB w)
++ " _priorityB = " ++ show (_uiScreenYB w)
++ " _buttonState = " ++ show (_uiButtonState w)
++ "}"

251
src/UI/UIClasses.hs
View File

@ -1,251 +0,0 @@
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
module UI.UIClasses where
import Control.Lens ((^.))
import Control.Monad
--import Control.Monad.IO.Class -- MonadIO
import Control.Monad.RWS.Strict (get)
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
import qualified Types as T
import UI.UIBaseData
class GUIAnyMap m w where
guiAnyMap :: (w -> b) -> GUIAny m -> b
class (Monad m) => GUIWidget m uiw where
-- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
-- The bounding box wholly contains all children components.
getBoundary :: uiw -> 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 'getBoundary'.
getChildren :: uiw -> m [UIId]
getChildren _ = return []
-- |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 :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> uiw -- ^the parent widget
-> m Bool
isInside x' y' wg = do
(x, y, w, h) <- getBoundary wg
return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
-- |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.
getPriority :: uiw -> m Int
getPriority _ = return 0
-- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
-- The shorthand should be unique for each instance.
getShorthand :: uiw -> m String
-- |A 'GUIClickable' represents a widget with a 'UIButtonState'.
--
-- Minimal complete definition: 'getButtonState' and either 'updateButtonState' or 'setButtonState'.
class GUIClickable w where
updateButtonState :: (UIButtonState -> UIButtonState) -> w -> w
updateButtonState f w = setButtonState (f $ getButtonState w) w
setButtonState :: UIButtonState -> w -> w
setButtonState s = updateButtonState (\_ -> s)
getButtonState :: w -> UIButtonState
class Monad m => MouseHandler a m w where
-- |The function 'onMousePressed' is called when the primary button is pressed
-- while inside a screen coordinate within the widget ('isInside').
onMousePressed :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMousePressed _ _ wg a = return (wg, a)
-- |The function 'onMouseReleased' is called when the primary 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.
onMouseReleased :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen x coordinate
-> w -- ^wdiget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseReleased _ _ wg a = return (wg, a)
-- |The function 'onMousePressed' is called when the secondary button is pressed
-- while inside a screen coordinate within the widget ('isInside').
onMousePressedAlt :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMousePressedAlt _ _ wg a = return (wg, a)
-- |The function 'onMouseReleased' is called when the secondary 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.
onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen x coordinate
-> w -- ^wdiget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseReleasedAlt _ _ wg a = return (wg, a)
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-- widget's space ('isInside').
onMouseMove :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseMove _ _ wg a = return (wg, a)
-- |The function 'onMouseMove' is invoked when the mouse enters the
-- widget's space ('isInside').
onMouseEnter :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseEnter _ _ wg a = return (wg, a)
-- |The function 'onMouseMove' is invoked when the mouse leaves the
-- widget's space ('isInside').
onMouseLeave :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseLeave _ _ wg a = return (wg, a)
instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch h) m w where
onMousePressed x y w (MouseHandlerSwitch h) = do
(w', h') <- onMousePressedAlt x y w h
return (w', MouseHandlerSwitch h')
onMouseReleased x y w (MouseHandlerSwitch h) = do
(w', h') <- onMouseReleasedAlt x y w h
return (w', MouseHandlerSwitch h')
onMousePressedAlt x y w (MouseHandlerSwitch h) = do
(w', h') <- onMousePressed x y w h
return (w', MouseHandlerSwitch h')
onMouseReleasedAlt x y w (MouseHandlerSwitch h) = do
(w', h') <- onMouseReleased x y w h
return (w', MouseHandlerSwitch h')
onMouseMove x y w (MouseHandlerSwitch h) = do
(w', h') <- onMouseMove x y w h
return (w', MouseHandlerSwitch h')
onMouseEnter x y w (MouseHandlerSwitch h) = do
(w', h') <- onMouseEnter x y w h
return (w', MouseHandlerSwitch h')
onMouseLeave x y w (MouseHandlerSwitch h) = do
(w', h') <- onMouseLeave x y w h
return (w', MouseHandlerSwitch h')
instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
onMousePressed _ _ wg h =
return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and
-- call 'action' if inside the widget or
-- set '_buttonstateIsDeferred' to false otherwise.
onMouseReleased x y wg h@(ButtonHandler action) = if _buttonstateIsFiring $ getButtonState wg
then do
wg' <- action wg x y
return (updateButtonState (\s -> s {_buttonstateIsFiring = False}) wg', h)
else return (updateButtonState (\s -> s {_buttonstateIsDeferred = False}) wg, h)
-- |Do nothing.
onMouseMove _ _ wg h = return (wg, h)
-- |Set 'UIButtonState's '_buttonstateIsReady' to @True@ and
-- update dragging state (only drag if inside widget).
-- In detail, change 'UIButtonState's '_buttonstateIsDeferred' to '_buttonstateIsFiring's current value
-- and set '_buttonstateIsFiring' to @False@.
onMouseEnter _ _ wg h = return
(updateButtonState (\s -> s { _buttonstateIsFiring = _buttonstateIsDeferred s
, _buttonstateIsDeferred = False
, _buttonstateIsReady = True
}) wg
, h)
-- |Set 'UIButtonState's 'buttonstateIsReady' to @False@ and
-- update dragging state (only drag if inside widget).
-- In detail, change 'UIButtonState's '_buttonstateIsFiring' to '_buttonstateIsDeferred's current value
-- and set '_buttonstateIsDeferred's' to @False@.
onMouseLeave _ _ wg h = return
(updateButtonState (\s -> s { _buttonstateIsFiring = False
, _buttonstateIsDeferred = _buttonstateIsFiring s
, _buttonstateIsReady = False
}) wg
, h)
instance (Monad m) => GUIAnyMap m (GUIAny m) where
guiAnyMap f w = f w
instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
getBoundary (GUIAnyC w) = getBoundary w
getBoundary (GUIAnyP w) = getBoundary w
getBoundary (GUIAnyB w _) = getBoundary w
getChildren (GUIAnyC w) = getChildren w
getChildren (GUIAnyP w) = getChildren w
getChildren (GUIAnyB w _) = getChildren w
isInside x y (GUIAnyC w) = (isInside x y) w
isInside x y (GUIAnyP w) = (isInside x y) w
isInside x y (GUIAnyB w _) = (isInside x y) w
getPriority (GUIAnyC w) = getPriority w
getPriority (GUIAnyP w) = getPriority w
getPriority (GUIAnyB w _) = getPriority w
getShorthand (GUIAnyC w) = do { str <- getShorthand w; return $ "A" ++ str }
getShorthand (GUIAnyP w) = do { str <- getShorthand w; return $ "A" ++ str }
getShorthand (GUIAnyB w _) = do { str <- getShorthand w; return $ "A" ++ str }
instance (Monad m) => GUIAnyMap m GUIContainer where
guiAnyMap f (GUIAnyC c) = f c
guiAnyMap _ _ = error "invalid types in guiAnyMap"
instance (Monad m) => GUIWidget m GUIContainer where
getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt)
getChildren cnt = return $ _uiChildren cnt
getPriority cnt = return $ _uiPriority cnt
getShorthand _ = return $ "CNT"
instance GUIAnyMap m GUIPanel where
guiAnyMap f (GUIAnyP p) = f p
guiAnyMap _ _ = error "invalid types in guiAnyMap"
instance GUIWidget T.Pioneers GUIPanel where
getBoundary pnl = do
state <- get
let hmap = state ^. T.ui . T.uiMap
case _uiChildren $ _panelContainer pnl of
[] -> getBoundary $ _panelContainer pnl
cs -> do
let widgets = catMaybes $ map (flip Map.lookup hmap) cs
foldl' (liftM2 determineSize) (getBoundary $ _panelContainer pnl) $ map getBoundary widgets
where
determineSize :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
determineSize (x, y, w, h) (x', y', w', h') =
let x'' = if x' < x then x' else x
y'' = if y' < y then y' else y
w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
in (x'', y'', w'', h'')
getChildren pnl = getChildren $ _panelContainer pnl
getPriority pnl = getPriority $ _panelContainer pnl
getShorthand _ = return $ "PNL"
instance (Monad m) => GUIAnyMap m GUIButton where
guiAnyMap f (GUIAnyB btn _) = f btn
guiAnyMap _ _ = error "invalid types in guiAnyMap"
instance GUIClickable GUIButton where
getButtonState = _uiButtonState
updateButtonState f btn = btn {_uiButtonState = f $ _uiButtonState btn}
instance (Monad m) => GUIWidget m GUIButton where
getBoundary btn = return (_uiScreenXB btn, _uiScreenYB btn, _uiWidthB btn, _uiHeightB btn)
getChildren _ = return []
getPriority btn = return $ _uiPriorityB btn
getShorthand _ = return "BTN"

47
src/UI/UIOperations.hs
View File

@ -1,24 +1,19 @@
module UI.UIOperations where
import Control.Lens ((^.))
import Control.Monad (liftM)
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Types
import UI.UIBaseData
import UI.UIClasses
import UI.UIBase
defaultUIState :: UIButtonState
defaultUIState = UIButtonState False False False False False False
toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m
toGUIAny m uid = case Map.lookup uid m of
Just w -> w
Nothing -> error "map does not contain requested key" --TODO: better error handling
toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m
toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
{-# INLINE toGUIAny #-}
toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m]
toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
toGUIAnys m = mapMaybe (`Map.lookup` m)
{-# INLINE toGUIAnys #-}
-- TODO: check for missing components?
@ -32,17 +27,16 @@ toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
-- or @[]@ if the point does not hit the widget.
--
-- This function returns the widgets themselves unlike 'getInsideId'.
getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
-> ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> GUIAny Pioneers -- ^the parent widget
-> Pioneers [GUIAny Pioneers]
getInside hMap x' y' wg = do
inside <- isInside x' y' wg
getInside :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-> Pixel -- ^screen position
-> GUIWidget Pioneers -- ^the parent widget
-> Pioneers [GUIWidget Pioneers]
getInside hMap px wg = do
inside <- (wg ^. baseProperties.isInside) wg px
if inside -- test inside parent's bounding box
then do
childrenIds <- getChildren wg
hitChildren <- liftM concat $ mapM (getInside hMap x' y') (toGUIAnys hMap childrenIds)
childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInside hMap px) (toGUIAnys hMap childrenIds)
case hitChildren of
[] -> return [wg]
_ -> return hitChildren
@ -58,18 +52,17 @@ getInside hMap x' y' wg = do
-- or @[]@ if the point does not hit the widget.
--
-- This function returns the 'UIId's of the widgets unlike 'getInside'.
getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
-> ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
getInsideId :: Map.HashMap UIId (GUIWidget Pioneers) -- ^map containing ui widgets
-> Pixel -- ^screen position
-> UIId -- ^the parent widget
-> Pioneers [UIId]
getInsideId hMap x' y' uid = do
getInsideId hMap px uid = do
let wg = toGUIAny hMap uid
inside <- isInside x' y' wg
inside <- (wg ^. baseProperties.isInside) wg px
if inside -- test inside parent's bounding box
then do
childrenIds <- getChildren wg
hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds
childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInsideId hMap px) childrenIds
case hitChildren of
[] -> return [uid]
_ -> return hitChildren

48
src/UI/UIWidgets.hs Normal file
View File

@ -0,0 +1,48 @@
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Lens ((^.), (.~), (&))
import Control.Monad
--import Control.Monad.IO.Class -- MonadIO
import Control.Monad.RWS.Strict (get)
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
import Types
import UI.UIBase
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
Nothing
emptyGraphics
createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
Nothing
emptyGraphics
where
autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
autosize' = do
state <- get
let hmap = state ^. ui . uiMap
-- TODO: local coordinates
determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
determineSize' (x, y, w, h) (x', y', w', h') =
let x'' = if x' < x then x' else x
y'' = if y' < y then y' else y
w'' = if x' + w' > x + w then x' + w' - x'' else x + w - x''
h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y''
in (x'', y'', w'', h'')
case chld of
[] -> return bnd
cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs
foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets
createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m
createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
(Just $ buttonMouseActions action)
emptyGraphics