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

started referencing ui widgets by id via hashmap, WIP, does not compile

Browse Source
This commit is contained in:
tpajenka 2014-04-23 13:08:18 +02:00
parent 8e59e10b86
commit a9a97f7544
4 changed files with 138 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Pioneers.cabal
View File

@ -46,7 +46,8 @@ executable Pioneers
time >=1.4.0,
GLUtil >= 0.7,
attoparsec >= 0.11.2,
unordered-containers >= 0.2.1
unordered-containers >= 0.2.1,
hashable >= 1.0.1.1
other-modules: Render.Types
Default-Language: Haskell2010

75
src/UI/UIBaseData.hs Normal file
View File

@ -0,0 +1,75 @@
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
module UI.UIBaseData where
import Data.Hashable
import Data.List
import Foreign.C (CFloat)
import Linear.Matrix (M44)
-- |Unit of screen/window
type ScreenUnit = Int
newtype 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 w 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 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 { _screenX :: ScreenUnit, _screenY :: ScreenUnit
, _width :: ScreenUnit, _height :: ScreenUnit
, _children :: [UIId]
, _priority :: 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 { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit
, _widthB :: ScreenUnit, _heightB :: ScreenUnit
, _priorityB :: Int
, _buttonState :: UIButtonState
} deriving ()
instance Show GUIButton where
show w = "GUIButton {_screenXB = " ++ show (_screenXB w)
++ " _screenYB = " ++ show (_screenYB w)
++ " _widthB = " ++ show (_widthB w)
++ " _heightB = " ++ show (_heightB w)
++ " _priorityB = " ++ show (_screenYB w)
++ " _buttonState = " ++ show (_buttonState w)
++ "}"

182
src/UI/UITypes.hs → src/UI/UIClasses.hs
View File

@ -1,59 +1,21 @@
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
module UI.UITypes where
module UI.UIClasses where
import Data.List
import Foreign.C (CFloat)
import Linear.Matrix (M44)
-- |Unit of screen/window
type ScreenUnit = Int
-- |A viewport to an OpenGL scene.
data Viewport = Viewport
{ _viewportXAngle :: !Double
, _viewportYAngle :: !Double
, _viewportZDist :: !Double
, _viewportFrustum :: !(M44 CFloat)
, _viewportPositionX :: !ScreenUnit -- ^x position in window
, _viewportPositionY :: !ScreenUnit -- ^y position in window
, _viewportWidth :: !ScreenUnit -- ^viewport width in window
, _viewportHeight :: !ScreenUnit -- ^viewport height in window
} deriving (Eq, Show)
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)
defaultUIState :: UIButtonState
defaultUIState = UIButtonState False False False False False False
import Types
class GUIAnyMap w where
guiAnyMap :: (w -> b) -> GUIAny -> b
toGUIAny :: w -> GUIAny
fromGUIAny :: GUIAny -> w
class (GUIAnyMap uiw) => GUIWidget uiw where
class (GUIAnyMap uiw) => GUIWidget m uiw where
-- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
-- The bounding box wholly contains all children components.
getBoundary :: uiw -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
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 -> [GUIAny]
getChildren :: uiw -> m [UIId]
getChildren _ = []
-- |The function 'isInsideSelf' tests whether a point is inside the widget itself.
@ -65,34 +27,18 @@ class (GUIAnyMap uiw) => GUIWidget uiw where
isInsideSelf :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> uiw -- ^the parent widget
-> Bool
-> m Bool
isInsideSelf x' y' wg = let (x, y, w, h) = getBoundary wg
in (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
-- |The function 'isInside' tests whether a point is inside the widget or any child.
-- 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 have no hit children or 'Nothing' if the point neither hits any
-- component nor the parent widget itself.
isInside :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> uiw -- ^the parent widget
-> [GUIAny]
isInside x' y' wg =
case isInsideSelf x' y' wg of -- test inside parent's bounding box
False -> []
True -> case concat $ map (isInside x' y') (getChildren wg) of
[] -> [toGUIAny wg]
l -> l
--TODO: Priority queue?
-- |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 -> Int
getPriority :: uiw -> m Int
getPriority _ = 0
-- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose.
-- The shorthand should be unique for each instance.
getShorthand :: uiw -> String
getShorthand :: uiw -> m String
-- |A 'GUIClickable' represents a widget with a 'UIButtonState'.
--
@ -104,13 +50,13 @@ class GUIClickable w where
setButtonState s = updateButtonState (\_ -> s)
getButtonState :: w -> UIButtonState
class MouseHandler a w where
class 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 -> IO (w, a) -- ^widget after the event and the altered handler
-> 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
@ -120,7 +66,7 @@ class MouseHandler a w where
onMouseReleased :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen x coordinate
-> w -- ^wdiget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler
-> 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
@ -128,7 +74,7 @@ class MouseHandler a w where
onMousePressedAlt :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler
-> 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
@ -138,7 +84,7 @@ class MouseHandler a w where
onMouseReleasedAlt :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen x coordinate
-> w -- ^wdiget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler
-> 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
@ -146,7 +92,7 @@ class MouseHandler a w where
onMouseMove :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler
-> 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
@ -154,7 +100,7 @@ class MouseHandler a w where
onMouseEnter :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler
-> 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
@ -162,20 +108,10 @@ class MouseHandler a w where
onMouseLeave :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> w -- ^widget the event is invoked on
-> a -> IO (w, a) -- ^widget after the event and the altered handler
-> a -> m (w, a) -- ^widget after the event and the altered handler
onMouseLeave _ _ wg a = return (wg, a)
-- |Switches primary and secondary mouse actions.
data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show)
instance Functor (MouseHandlerSwitch w) where
fmap :: (h1 -> h2) -> MouseHandlerSwitch w h1 -> MouseHandlerSwitch w h2
fmap f (MouseHandlerSwitch h) = MouseHandlerSwitch (f h)
instance Monad (MouseHandlerSwitch w) where
(>>=) :: (MouseHandlerSwitch w h1) -> (h1 -> MouseHandlerSwitch w h2) -> MouseHandlerSwitch w h2
(MouseHandlerSwitch h) >>= f = f h
return :: h -> MouseHandlerSwitch w h
return h = MouseHandlerSwitch h
instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where
instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch w h) w where
onMousePressed x y w (MouseHandlerSwitch h) = do
(w', h') <- onMousePressedAlt x y w h
return (w', MouseHandlerSwitch h')
@ -198,13 +134,7 @@ instance (MouseHandler h w) => MouseHandler (MouseHandlerSwitch w h) w where
(w', h') <- onMouseLeave x y w h
return (w', MouseHandlerSwitch h')
-- !!Important: one handler can only handle one single widget!!
data ButtonHandler w = ButtonHandler
{ _action :: (w -> ScreenUnit -> ScreenUnit -> IO w) }
instance Show (ButtonHandler w) where
show _ = "ButtonHandler ***"
instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where
instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where
-- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@.
onMousePressed _ _ wg h = do
return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h)
@ -243,17 +173,10 @@ instance (GUIClickable w) => MouseHandler (ButtonHandler w) w where
}) wg
, h)
data GUIAny = GUIAnyC GUIContainer
| GUIAnyP GUIPanel
| GUIAnyB GUIButton (ButtonHandler GUIButton)
deriving (Show)
instance GUIAnyMap GUIAny where
instance GUIAnyMap (GUIAny m) where
guiAnyMap f w = f w
toGUIAny = id
fromGUIAny = id
instance GUIWidget GUIAny where
instance GUIWidget m (GUIAny m) where
getBoundary (GUIAnyC w) = getBoundary w
getBoundary (GUIAnyP w) = getBoundary w
getBoundary (GUIAnyB w _) = getBoundary w
@ -273,26 +196,15 @@ instance GUIWidget GUIAny where
getShorthand (GUIAnyP w) = "A" ++ getShorthand w
getShorthand (GUIAnyB w _) = "A" ++ getShorthand w
-- |A 'GUIContainer' is a widget that may contain additional widgets but does not have a
-- functionality itself.
data GUIContainer = GUIContainer { _screenX :: ScreenUnit, _screenY :: ScreenUnit
, _width :: ScreenUnit, _height :: ScreenUnit
, _children :: [GUIAny]
, _priority :: Int
} deriving (Show)
instance GUIAnyMap GUIContainer where
guiAnyMap f (GUIAnyC c) = f c
guiAnyMap _ _ = error "invalid types in guiAnyMap"
toGUIAny cnt = GUIAnyC cnt
fromGUIAny (GUIAnyC cnt) = cnt
fromGUIAny _ = error "invalid GUIAny type"
instance GUIWidget GUIContainer where
getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
getChildren cnt = _children cnt
getPriority cnt = _priority cnt
getShorthand _ = "CNT"
instance GUIWidget m GUIContainer where
getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
getBoundary cnt = return (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
getChildren cnt = return $ _children cnt
getPriority cnt = return $ _priority cnt
getShorthand _ = return $ "CNT"
-- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its
-- children components.
@ -300,10 +212,7 @@ data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show)
instance GUIAnyMap GUIPanel where
guiAnyMap f (GUIAnyP p) = f p
guiAnyMap _ _ = error "invalid types in guiAnyMap"
toGUIAny pnl = GUIAnyP pnl
fromGUIAny (GUIAnyP pnl) = pnl
fromGUIAny _ = error "invalid GUIAny type"
instance GUIWidget GUIPanel where
instance GUIWidget m GUIPanel where
getBoundary pnl = case getChildren $ _panelContainer pnl of
[] -> getBoundary $ _panelContainer pnl
cs -> foldl1' determineSize $ map getBoundary cs
@ -316,39 +225,18 @@ instance GUIWidget GUIPanel where
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 _ = "PNL"
-- |A 'GUIButton' is a dummy datatype for a clickable 'GUIWidget'. Its functinality must be
-- provided by an appropriate 'MouseHanlder'.
data GUIButton = GUIButton { _screenXB :: ScreenUnit, _screenYB :: ScreenUnit
, _widthB :: ScreenUnit, _heightB :: ScreenUnit
, _priorityB :: Int
, _buttonState :: UIButtonState
, _buttonAction :: (GUIButton -> ScreenUnit -> ScreenUnit -> IO GUIButton)
} deriving ()
getChildren pnl = return $ getChildren $ _panelContainer pnl
getPriority pnl = return $ getPriority $ _panelContainer pnl
getShorthand _ = return $ "PNL"
instance Show GUIButton where
show w = "GUIButton {_screenXB = " ++ show (_screenXB w)
++ " _screenYB = " ++ show (_screenYB w)
++ " _widthB = " ++ show (_widthB w)
++ " _heightB = " ++ show (_heightB w)
++ " _priorityB = " ++ show (_screenYB w)
++ " _buttonState = " ++ show (_buttonState w)
++ " _buttonAction = " ++ "***"
++ "}"
instance GUIAnyMap GUIButton where
guiAnyMap f (GUIAnyB btn _) = f btn
guiAnyMap _ _ = error "invalid types in guiAnyMap"
toGUIAny btn = GUIAnyB btn $ ButtonHandler $ _buttonAction btn
fromGUIAny (GUIAnyB btn _) = btn
fromGUIAny _ = error "invalid GUIAny type"
instance GUIClickable GUIButton where
getButtonState = _buttonState
updateButtonState f btn = btn {_buttonState = f $ _buttonState btn}
instance GUIWidget GUIButton where
getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn)
getChildren _ = []
getPriority btn = _priorityB btn
getShorthand _ = "BTN"
instance GUIWidget m GUIButton where
getBoundary btn = return (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn)
getChildren _ = return []
getPriority btn = return $ _priorityB btn
getShorthand _ = return "BTN"

26
src/UI/UIOperations.hs Normal file
View File

@ -0,0 +1,26 @@
module UI.UIOperations where
import Data.HashMap.Strict
import UI.UIBaseData
import UI.UIClasses
defaultUIState :: UIButtonState
defaultUIState = UIButtonState False False False False False False
--TODO
-- |The function 'isInside' tests whether a point is inside the widget or any child.
-- 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 have no hit children or 'Nothing' if the point neither hits any
-- component nor the parent widget itself.
isInside :: ScreenUnit -- ^screen x coordinate
-> ScreenUnit -- ^screen y coordinate
-> UIId -- ^the parent widget
-> [UIId]
isInside x' y' wg =
case isInsideSelf x' y' wg of -- test inside parent's bounding box
False -> []
True -> case concat $ map (isInside x' y') (getChildren wg) of
[] -> [toGUIAny wg]
l -> l
--TODO: Priority queue?