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

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
 

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)
+                    ++ "}"

src/UI/UIClasses.hs

@@ -1,59 +1,21 @@
 {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
 
-module UI.UITypes where
+module UI.UIClasses where
 
-import Data.List
+import Types
-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
 
 class GUIAnyMap w where
     guiAnyMap :: (w -> b) -> GUIAny -> b
-    toGUIAny :: w -> GUIAny
-    fromGUIAny :: GUIAny -> w
     
-    
+class (GUIAnyMap uiw) => GUIWidget m uiw where
-class (GUIAnyMap uiw) => GUIWidget 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.
+instance (MouseHandler h m w) => MouseHandler (MouseHandlerSwitch w h) w where
-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
     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')
 
-
+instance (GUIClickable w) => MouseHandler (ButtonHandler m w) w where
--- !!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
     -- |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)
 
-
+instance GUIAnyMap (GUIAny m) where
-data GUIAny = GUIAnyC GUIContainer
-            | GUIAnyP GUIPanel
-            | GUIAnyB GUIButton (ButtonHandler GUIButton)
-            deriving (Show)
-instance GUIAnyMap GUIAny 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
+instance GUIWidget m GUIContainer where
-    fromGUIAny (GUIAnyC cnt) = cnt
+    getBoundary :: GUIContainer -> m (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
-    fromGUIAny _ = error "invalid GUIAny type"
+    getBoundary cnt = return (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
-instance GUIWidget GUIContainer where
+    getChildren cnt = return $ _children cnt
-    getBoundary :: GUIContainer -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
+    getPriority cnt = return $ _priority cnt
-    getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
+    getShorthand _ = return $ "CNT"
-    getChildren cnt = _children cnt
-    getPriority cnt = _priority cnt
-    getShorthand _ = "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
+instance GUIWidget m GUIPanel where
-    fromGUIAny (GUIAnyP pnl) = pnl
-    fromGUIAny _ = error "invalid GUIAny type"
-instance GUIWidget 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
+    getChildren pnl = return $ getChildren $ _panelContainer pnl
-    getPriority pnl = getPriority $ _panelContainer pnl
+    getPriority pnl = return $ getPriority $ _panelContainer pnl
-    getShorthand _ = "PNL"
+    getShorthand _ = return $ "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 ()
 
-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
+instance GUIWidget m GUIButton where
-    getBoundary btn = (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn)
+    getBoundary btn = return (_screenXB btn, _screenYB btn, _widthB btn, _heightB btn)
-    getChildren _ = []
+    getChildren _ = return []
-    getPriority btn = _priorityB btn
+    getPriority btn = return $ _priorityB btn
-    getShorthand _ = "BTN"
+    getShorthand _ = return "BTN"

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?