From 6879201c53a4b80bffeb2453669e5ae51d5e6d6c Mon Sep 17 00:00:00 2001 From: tpajenka Date: Thu, 24 Apr 2014 23:42:05 +0200 Subject: [PATCH] worked on storing widgets in HashMap and referencing via Id incorporated Pioneers monad into ui operations !!still WIP, does not compile (TODO: UIOperations, Callbacks, Main?, Types?)!! --- src/Types.hs | 8 +++- src/UI/Callbacks.hs | 4 +- src/UI/UIBaseData.hs | 40 +++++++++---------- src/UI/UIClasses.hs | 91 +++++++++++++++++++++++------------------- src/UI/UIOperations.hs | 2 +- 5 files changed, 79 insertions(+), 66 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 3c0ea54..a251151 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -5,12 +5,14 @@ import Control.Concurrent.STM (TQueue) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) +import qualified Data.HashMap.Strict as Map import Data.Time (UTCTime) import Linear.Matrix (M44) import Control.Monad.RWS.Strict (RWST) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types +import UI.UIBaseData --Static Read-Only-State @@ -112,6 +114,7 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool + , _uiMap :: Map.HashMap UIId (GUIAny Pioneers) } data State = State @@ -125,6 +128,9 @@ data State = State , _ui :: !UIState } +type Pioneers = RWST Env () State IO + +-- when using TemplateHaskell order of declaration matters $(makeLenses ''State) $(makeLenses ''GLState) $(makeLenses ''GLMapState) @@ -140,5 +146,3 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) - -type Pioneers = RWST Env () State IO diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs index ad7a825..1e7f23b 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -4,7 +4,9 @@ module UI.Callbacks where import Control.Monad.Trans (liftIO) import Types -import UI.UITypes +import UI.UIBaseData +import UI.UIClasses +import UI.UIOperations import qualified Graphics.Rendering.OpenGL.GL as GL import Control.Lens ((^.), (.~), (%~)) diff --git a/src/UI/UIBaseData.hs b/src/UI/UIBaseData.hs index f51d534..de7f78f 100644 --- a/src/UI/UIBaseData.hs +++ b/src/UI/UIBaseData.hs @@ -1,17 +1,15 @@ -{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module UI.UIBaseData where import Data.Hashable -import Data.List -import Foreign.C (CFloat) -import Linear.Matrix (M44) +import Data.Ix -- |Unit of screen/window type ScreenUnit = Int -newtype UIId = Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) +newtype UIId = UId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable) -- |The state of a clickable ui widget. data UIButtonState = UIButtonState @@ -31,12 +29,12 @@ data UIButtonState = UIButtonState -- |Switches primary and secondary mouse actions. -- "monad type" "widget type" "original handler" -data MouseHandlerSwitch w h = MouseHandlerSwitch h deriving (Eq, Show) +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 w) where +instance Show (ButtonHandler m w) where show _ = "ButtonHandler ***" -- |A collection data type that may hold any usable ui element. @m@ is a monad. @@ -48,10 +46,10 @@ data GUIAny m = GUIAnyC GUIContainer -- |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 +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 @@ -60,16 +58,16 @@ 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 +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 (_screenXB w) - ++ " _screenYB = " ++ show (_screenYB w) - ++ " _widthB = " ++ show (_widthB w) - ++ " _heightB = " ++ show (_heightB w) - ++ " _priorityB = " ++ show (_screenYB w) - ++ " _buttonState = " ++ show (_buttonState w) + 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) ++ "}" diff --git a/src/UI/UIClasses.hs b/src/UI/UIClasses.hs index 7081044..09bc982 100644 --- a/src/UI/UIClasses.hs +++ b/src/UI/UIClasses.hs @@ -2,21 +2,30 @@ module UI.UIClasses where -import Types +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 -class GUIAnyMap w where - guiAnyMap :: (w -> b) -> GUIAny -> b +import qualified Types as T +import UI.UIBaseData + +class GUIAnyMap m w where + guiAnyMap :: (w -> b) -> GUIAny m -> b -class (GUIAnyMap uiw) => GUIWidget m uiw where +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) + 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 _ = [] + getChildren _ = return [] -- |The function 'isInsideSelf' 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 @@ -28,13 +37,14 @@ class (GUIAnyMap uiw) => GUIWidget m uiw where -> ScreenUnit -- ^screen y coordinate -> uiw -- ^the parent widget -> 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) + isInsideSelf 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 _ = 0 + getPriority _ = return 0 -- |The 'getShorthand' function returns a descriptive 'String' mainly for debuggin prupose. -- The shorthand should be unique for each instance. @@ -50,7 +60,7 @@ class GUIClickable w where setButtonState s = updateButtonState (\_ -> s) getButtonState :: w -> UIButtonState -class MouseHandler a m w where +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 @@ -111,7 +121,7 @@ class MouseHandler a m w where -> 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 w h) w where +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') @@ -134,9 +144,9 @@ instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch w h) w where (w', h') <- onMouseLeave x y w h return (w', MouseHandlerSwitch h') -instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where +instance (Monad m, GUIClickable w) => MouseHandler (ButtonHandler m w) m w where -- |Change 'UIButtonState's '_buttonstateIsFiring' to @True@. - onMousePressed _ _ wg h = do + onMousePressed _ _ wg h = return (updateButtonState (\s -> s {_buttonstateIsFiring = True}) wg, h) -- |Change 'UIButtonState's '_buttonstateIsFiring' to @False@ and @@ -173,10 +183,10 @@ instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where }) wg , h) -instance GUIAnyMap (GUIAny m) where +instance (Monad m) => GUIAnyMap m (GUIAny m) where guiAnyMap f w = f w -instance GUIWidget m (GUIAny m) where +instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where getBoundary (GUIAnyC w) = getBoundary w getBoundary (GUIAnyP w) = getBoundary w getBoundary (GUIAnyB w _) = getBoundary w @@ -186,36 +196,35 @@ instance GUIWidget m (GUIAny m) where isInsideSelf x y (GUIAnyC w) = (isInsideSelf x y) w isInsideSelf x y (GUIAnyP w) = (isInsideSelf x y) w isInsideSelf x y (GUIAnyB w _) = (isInsideSelf x y) 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) = "A" ++ getShorthand w - getShorthand (GUIAnyP w) = "A" ++ getShorthand w - getShorthand (GUIAnyB w _) = "A" ++ getShorthand 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 GUIAnyMap GUIContainer where +instance (Monad m) => GUIAnyMap m GUIContainer where guiAnyMap f (GUIAnyC c) = f c guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance GUIWidget m GUIContainer where +instance (Monad m) => 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 + getBoundary cnt = return (_uiScreenX cnt, _uiScreenY cnt, _uiWidth cnt, _uiHeight cnt) + getChildren cnt = return $ _uiChildren cnt + getPriority cnt = return $ _uiPriority cnt getShorthand _ = return $ "CNT" --- |A 'GUIPanel' is much like a 'GUIContainer' but it resizes automatically according to its --- children components. -data GUIPanel = GUIPanel { _panelContainer :: GUIContainer} deriving (Show) -instance GUIAnyMap GUIPanel where +instance GUIAnyMap m GUIPanel where guiAnyMap f (GUIAnyP p) = f p guiAnyMap _ _ = error "invalid types in guiAnyMap" -instance GUIWidget m GUIPanel where - getBoundary pnl = case getChildren $ _panelContainer pnl of +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 -> foldl1' determineSize $ map getBoundary cs + 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') = @@ -225,18 +234,18 @@ instance GUIWidget m GUIPanel where h'' = if y' + h' > y + h then y' + h' - y'' else y + h - y'' in (x'', y'', w'', h'') - getChildren pnl = return $ getChildren $ _panelContainer pnl - getPriority pnl = return $ getPriority $ _panelContainer pnl + getChildren pnl = getChildren $ _panelContainer pnl + getPriority pnl = getPriority $ _panelContainer pnl getShorthand _ = return $ "PNL" -instance GUIAnyMap GUIButton where +instance (Monad m) => GUIAnyMap m GUIButton where guiAnyMap f (GUIAnyB btn _) = f btn guiAnyMap _ _ = error "invalid types in guiAnyMap" instance GUIClickable GUIButton where - getButtonState = _buttonState - updateButtonState f btn = btn {_buttonState = f $ _buttonState btn} -instance GUIWidget m GUIButton where - getBoundary btn = return (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn) + 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 $ _priorityB btn + getPriority btn = return $ _uiPriorityB btn getShorthand _ = return "BTN" \ No newline at end of file diff --git a/src/UI/UIOperations.hs b/src/UI/UIOperations.hs index 15d5dc2..a7b95a7 100644 --- a/src/UI/UIOperations.hs +++ b/src/UI/UIOperations.hs @@ -1,6 +1,6 @@ module UI.UIOperations where -import Data.HashMap.Strict +import qualified Data.HashMap.Strict as Map import UI.UIBaseData import UI.UIClasses