diff --git a/Pioneers.cabal b/Pioneers.cabal index f9f638a..190a349 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -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 diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs new file mode 100644 index 0000000..f51d534 --- /dev/null +++ b/src/UI/UIBaseData.hs @@ -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) + ++ "}" diff --git a/src/UI/UITypes.hs b/src/UI/UIClasses.hs similarity index 59% rename from src/UI/UITypes.hs rename to src/UI/UIClasses.hs index 7a2a14c..7081044 100644 --- a/src/UI/UITypes.hs +++ b/src/UI/UIClasses.hs @@ -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" \ No newline at end of file +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" \ No newline at end of file diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs new file mode 100644 index 0000000..15d5dc2 --- /dev/null +++ b/src/UI/UIOperations.hs @@ -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?