Merge remote-tracking branch 'origin/ui' into tessallation

Pioneers.cabal

@@ -6,13 +6,19 @@ author:         sdressel
 
 executable Pioneers
   hs-source-dirs:  src
-  ghc-options:     -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm
-  other-modules:   
+  if os(windows) {
+    ghc-options:     -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3
+  } else {
+    ghc-options:     -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm
+  }
+  other-module
                    Map.Map,
                    Render.Misc,
                    Render.Render,
                    Render.RenderObject,
                    UI.Callbacks,
+                   Types,
+                   UI.SurfaceOverlay
                    Types
   main-is:         Main.hs
   build-depends:   

src/Main.hs

@@ -42,6 +42,7 @@ import           Render.Misc                          (checkError,
 import           Render.Render                        (initRendering,
                                                        initShader)
 import           UI.Callbacks
+import           UI.GUIOverlay
 import           Types
 
 import qualified Debug.Trace                          as D (trace)
@@ -55,7 +56,7 @@ main = do
                                                                              ,WindowResizable  -- and resizable 
                                                                              ,WindowInputFocus -- focused (=> active)
                                                                              ,WindowMouseFocus -- Mouse into it
-                                                                             ,WindowInputGrabbed-- never let go of input (KB/Mouse)
+                                                                             --,WindowInputGrabbed-- never let go of input (KB/Mouse)
                                                                              ] $ \window -> do
         withOpenGL window $ do
         --TTF.withInit $ do

src/UI/Callbacks.hs

@@ -1,14 +1,22 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
 module UI.Callbacks where
 
 import Control.Monad.Trans (liftIO)
 import Types
+import UI.UITypes
 
 data Pixel = Pixel Int Int
 
+getGUI :: [GUIAny]
+getGUI = (GUIAny $ GUIContainer 0 0 120 80 [] 1):(GUIAny $ GUIContainer 50 60 300 700 [(GUIAny $ GUIContainer 55 65 200 400 [] 5)] 1):[]
+
 -- | 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) = liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
+clickHandler (Pixel x y) = case concat $ map (isInside x y) getGUI of
+    [] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
+    hit -> liftIO $ putStrLn $ unwords $ foldl (++) ["hitting"] ([map (\w -> (show.getBoundary) w ++ ' ':(show.getPriority) w) hit])
 
 -- | Handler for UI-Inputs.
 --   Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...

src/UI/GUIOverlay.hs

@@ -0,0 +1,22 @@
+module UI.GUIOverlay where
+
+import Data.Int
+import Graphics.UI.SDL.Surface
+import Graphics.UI.SDL.Color
+import Graphics.UI.SDL.Rect
+import Graphics.UI.SDL.Types
+import UI.UITypes
+
+--createRGBSurface :: Int32 -> Int32 -> Int32 -> Word32 -> Word32 -> Word32 -> Word32 -> IO Surface
+--                    width    height   depth    rFilter   gFilter   bFilter   aFilter
+-- createRGBSurface width height 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF
+
+updateGUI :: Int32 -> Int32 -> IO Surface
+updateGUI width height = do
+      overlay <- createRGBSurface width height 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF
+      fillRect overlay (Rect 10 10 400 300) (Color 255 0 128 255)
+      return overlay
+      
+      
+--createTextureFromSurface :: Renderer -> Surface -> IO Texture
+--createSoftwareRenderer :: Surface -> IO Renderer

src/UI/UITypes.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE InstanceSigs, ExistentialQuantification #-}
+
+module UI.UITypes where
+
+
+type IntScreen = Int
+
+data GUIAny = forall wg. GUIWidget wg => GUIAny wg
+
+class GUIWidget uiw where
+    -- |The 'getBoundary' function gives the outer extents of the 'UIWidget'.
+    --  The bounding box wholly contains all children components.
+    getBoundary :: uiw -> (IntScreen, IntScreen, IntScreen ,IntScreen) -- ^@(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 _ = []
+
+    -- |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 component.
+    isInsideSelf :: IntScreen -- ^screen x coordinate
+                 -> IntScreen -- ^screen y coordinate
+                 -> uiw       -- ^the parent widget
+                 -> 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 :: IntScreen -- ^screen x coordinate
+             -> IntScreen -- ^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
+                [] -> [GUIAny 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 _ = 0
+
+
+instance GUIWidget GUIAny where
+    getBoundary (GUIAny wg) = getBoundary wg
+    isInsideSelf x y (GUIAny wg) = isInsideSelf x y wg
+    isInside x y (GUIAny wg) = isInside x y wg
+    getChildren (GUIAny wg) = getChildren wg
+    getPriority (GUIAny wg) = getPriority wg
+
+data GUIContainer = GUIContainer {_screenX :: IntScreen, _screenY :: IntScreen
+                                 , _width :: IntScreen, _height :: IntScreen
+                                 , _children :: [GUIAny]
+                                 , _priority :: Int}
+
+instance GUIWidget GUIContainer where
+    getBoundary :: GUIContainer -> (IntScreen, IntScreen, IntScreen ,IntScreen)
+    getBoundary cnt = (_screenX cnt, _screenY cnt, _width cnt, _height cnt)
+    getChildren cnt = _children cnt
+    getPriority cnt = _priority cnt