finished storing ui widgets into a HashMap and referencing them by UIId.
Additionally, widgets functions now use the Pioneers monad. Branch is compiling again and works.
This commit is contained in:
tpajenka
parent
6879201c53
commit
2d80c92384
@ -103,6 +103,7 @@ main =
|
||||
far = 500 --far plane
|
||||
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
||||
frust = createFrustum fov near far ratio
|
||||
(guiMap, guiRoots) = createGUI
|
||||
aks = ArrowKeyState {
|
||||
_up = False
|
||||
, _down = False
|
||||
@ -174,6 +175,8 @@ main =
|
||||
}
|
||||
, _ui = UIState
|
||||
{ _uiHasChanged = True
|
||||
, _uiMap = guiMap
|
||||
, _uiRoots = guiRoots
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -115,6 +115,7 @@ data GLState = GLState
|
||||
data UIState = UIState
|
||||
{ _uiHasChanged :: !Bool
|
||||
, _uiMap :: Map.HashMap UIId (GUIAny Pioneers)
|
||||
, _uiRoots :: [UIId]
|
||||
}
|
||||
|
||||
data State = State
|
||||
|
||||
@ -2,53 +2,85 @@
|
||||
|
||||
module UI.Callbacks where
|
||||
|
||||
import Control.Monad.Trans (liftIO)
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import Control.Lens ((^.), (.~))
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.RWS.Strict (get, modify)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe
|
||||
import Foreign.Marshal.Array (pokeArray)
|
||||
import Foreign.Marshal.Alloc (allocaBytes)
|
||||
import Render.Misc (genColorData)
|
||||
|
||||
import Types
|
||||
import UI.UIBaseData
|
||||
import UI.UIClasses
|
||||
import UI.UIOperations
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import Control.Lens ((^.), (.~), (%~))
|
||||
import Render.Misc (genColorData)
|
||||
import Foreign.Marshal.Array (pokeArray)
|
||||
import Foreign.Marshal.Alloc (allocaBytes)
|
||||
import Control.Monad.RWS.Strict (get, liftIO, modify)
|
||||
|
||||
|
||||
data Pixel = Pixel Int Int
|
||||
|
||||
getGUI :: [GUIAny]
|
||||
getGUI = [ toGUIAny $ GUIContainer 0 0 120 80 [] 1
|
||||
, toGUIAny $ GUIPanel $ GUIContainer 0 0 0 0
|
||||
[toGUIAny $ GUIContainer 0 80 100 200 [] 4
|
||||
,toGUIAny $GUIButton 50 400 200 175 2 defaultUIState testMessage
|
||||
] 3
|
||||
]
|
||||
createGUI :: (Map.HashMap UIId (GUIAny Pioneers), [UIId])
|
||||
createGUI = (Map.fromList [ (UIId 0, GUIAnyP $ GUIPanel $ GUIContainer 0 0 0 0 [UIId 1, UIId 2] 0)
|
||||
, (UIId 1, GUIAnyC $ GUIContainer 20 50 120 80 [] 1)
|
||||
, (UIId 2, GUIAnyP $ GUIPanel $ GUIContainer 100 140 0 0 [UIId 3, UIId 4] 3)
|
||||
, (UIId 3, GUIAnyC $ GUIContainer 100 140 130 200 [] 4 )
|
||||
, (UIId 4, GUIAnyB (GUIButton 30 200 60 175 2 defaultUIState ) (ButtonHandler testMessage))
|
||||
], [UIId 0])
|
||||
|
||||
getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers]
|
||||
getGUI hmap = Map.elems hmap
|
||||
|
||||
testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w
|
||||
getRootIds :: Pioneers [UIId]
|
||||
getRootIds = do
|
||||
state <- get
|
||||
return $ state ^. ui.uiRoots
|
||||
|
||||
getRoots :: Pioneers [GUIAny Pioneers]
|
||||
getRoots = do
|
||||
state <- get
|
||||
rootIds <- getRootIds
|
||||
let hMap = state ^. ui.uiMap
|
||||
return $ toGUIAnys hMap rootIds
|
||||
|
||||
testMessage :: w -> ScreenUnit -> ScreenUnit -> Pioneers w
|
||||
testMessage w x y = do
|
||||
putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
|
||||
return w
|
||||
liftIO $ putStrLn ("\tclick on " ++ show x ++ "," ++ show y)
|
||||
return w
|
||||
|
||||
-- | 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) = case concatMap (isInside x y) getGUI of
|
||||
[] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
|
||||
hit -> liftIO $ do
|
||||
_ <- sequence $ map (\w ->
|
||||
case w of
|
||||
(GUIAnyB b h) -> do
|
||||
putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
|
||||
++ " at ["++show x++","++show y++"]"
|
||||
(b', h') <- onMousePressed x y b h
|
||||
_ <- onMouseReleased x y b' h'
|
||||
return ()
|
||||
_ -> putStrLn $ "hitting " ++ getShorthand w ++ ": " ++ show (getBoundary w) ++ " " ++ show (getPriority w)
|
||||
++ " at ["++show x++","++show y++"]"
|
||||
) hit
|
||||
return ()
|
||||
clickHandler (Pixel x y) = do
|
||||
state <- get
|
||||
let hMap = state ^. ui.uiMap
|
||||
roots <- getRootIds
|
||||
hits <- liftM concat $ mapM (getInsideId hMap x y) roots
|
||||
case hits of
|
||||
[] -> liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
|
||||
_ -> do
|
||||
changes <- sequence $ map (\uid -> do
|
||||
let w = toGUIAny hMap uid
|
||||
short <- getShorthand w
|
||||
bound <- getBoundary w
|
||||
prio <- getPriority w
|
||||
liftIO $ putStrLn $ "hitting " ++ short ++ ": " ++ show bound ++ " " ++ show prio
|
||||
++ " at [" ++ show x ++ "," ++ show y ++ "]"
|
||||
case w of
|
||||
(GUIAnyB b h) -> do
|
||||
(b', h') <- onMousePressed x y b h
|
||||
(b'', h'') <- onMouseReleased x y b' h'
|
||||
return $ Just (uid, GUIAnyB b'' h'')
|
||||
_ -> return Nothing
|
||||
) $ hits
|
||||
let newMap :: Map.HashMap UIId (GUIAny Pioneers)
|
||||
newMap = foldl' (\hm (uid, w') -> Map.insert uid w' hm) hMap $ catMaybes changes
|
||||
modify $ ui.uiMap .~ newMap
|
||||
return ()
|
||||
|
||||
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
@ -69,36 +101,40 @@ alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate pres
|
||||
prepareGUI :: Pioneers ()
|
||||
prepareGUI = do
|
||||
state <- get
|
||||
roots <- getRoots
|
||||
let tex = (state ^. gl.glHud.hudTexture)
|
||||
liftIO $ do
|
||||
-- bind texture - all later calls work on this one.
|
||||
GL.textureBinding GL.Texture2D GL.$= Just tex
|
||||
mapM_ (copyGUI tex) getGUI
|
||||
mapM_ (copyGUI tex) roots
|
||||
modify $ ui.uiHasChanged .~ False
|
||||
|
||||
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
|
||||
copyGUI :: GL.TextureObject -> GUIAny -> IO ()
|
||||
copyGUI :: GL.TextureObject -> GUIAny Pioneers -> Pioneers ()
|
||||
copyGUI tex widget = do
|
||||
let (xoff, yoff, width, height) = getBoundary widget
|
||||
(xoff, yoff, wWidth, wHeight) <- getBoundary widget
|
||||
state <- get
|
||||
let
|
||||
hMap = state ^. ui.uiMap
|
||||
int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
|
||||
--temporary color here. lateron better some getData-function to
|
||||
--get a list of pixel-data or a texture.
|
||||
color = case widget of
|
||||
(GUIAnyC _) -> [255,0,0,128]
|
||||
(GUIAnyB _ _) -> [255,255,0,255]
|
||||
(GUIAnyP _) -> [128,128,128,255]
|
||||
(GUIAnyP _) -> [128,128,128,128]
|
||||
_ -> [255,0,255,255]
|
||||
allocaBytes (width*height*4) $ \ptr -> do
|
||||
liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
|
||||
--copy data into C-Array
|
||||
pokeArray ptr (genColorData (width*height) color)
|
||||
pokeArray ptr (genColorData (wWidth*wHeight) color)
|
||||
GL.texSubImage2D
|
||||
GL.Texture2D
|
||||
0
|
||||
(GL.TexturePosition2D (int xoff) (int yoff))
|
||||
(GL.TextureSize2D (int width) (int height))
|
||||
(GL.TextureSize2D (int wWidth) (int wHeight))
|
||||
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
|
||||
mapM_ (copyGUI tex) (getChildren widget)
|
||||
copyGUI _ _ = return ()
|
||||
nextChildrenIds <- getChildren widget
|
||||
mapM_ (copyGUI tex) $ toGUIAnys hMap $ nextChildrenIds
|
||||
|
||||
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
|
||||
--TODO: Maybe queues are better?
|
||||
--TODO: Maybe queues are better?
|
||||
@ -9,7 +9,7 @@ import Data.Ix
|
||||
type ScreenUnit = Int
|
||||
|
||||
|
||||
newtype UIId = UId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
|
||||
newtype UIId = UIId Int deriving (Eq,Ord,Show,Read,Bounded,Ix,Hashable)
|
||||
|
||||
-- |The state of a clickable ui widget.
|
||||
data UIButtonState = UIButtonState
|
||||
@ -35,7 +35,7 @@ data MouseHandlerSwitch h = MouseHandlerSwitch h deriving (Eq, Show)
|
||||
data ButtonHandler m w = ButtonHandler
|
||||
{ _action :: (w -> ScreenUnit -> ScreenUnit -> m w) }
|
||||
instance Show (ButtonHandler m w) where
|
||||
show _ = "ButtonHandler ***"
|
||||
show _ = "ButtonHandler ***"
|
||||
|
||||
-- |A collection data type that may hold any usable ui element. @m@ is a monad.
|
||||
data GUIAny m = GUIAnyC GUIContainer
|
||||
@ -64,10 +64,10 @@ data GUIButton = GUIButton { _uiScreenXB :: ScreenUnit, _uiScreenYB :: ScreenUni
|
||||
, _uiButtonState :: UIButtonState
|
||||
} deriving ()
|
||||
instance Show GUIButton where
|
||||
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)
|
||||
++ "}"
|
||||
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)
|
||||
++ "}"
|
||||
|
||||
@ -27,17 +27,17 @@ class (Monad m) => GUIWidget m uiw where
|
||||
getChildren :: uiw -> m [UIId]
|
||||
getChildren _ = return []
|
||||
|
||||
-- |The function 'isInsideSelf' tests whether a point is inside the widget itself.
|
||||
-- |The function 'isInside' 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.
|
||||
--
|
||||
-- The default implementations tests if the point is within the rectangle specified by the
|
||||
-- 'getBoundary' function.
|
||||
isInsideSelf :: ScreenUnit -- ^screen x coordinate
|
||||
isInside :: ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> uiw -- ^the parent widget
|
||||
-> m Bool
|
||||
isInsideSelf x' y' wg = do
|
||||
isInside x' y' wg = do
|
||||
(x, y, w, h) <- getBoundary wg
|
||||
return $ (x' - x <= w) && (x' - x >= 0) && (y' - y <= h) && (y' - y >= 0)
|
||||
|
||||
@ -193,9 +193,9 @@ instance GUIWidget T.Pioneers (GUIAny T.Pioneers) where
|
||||
getChildren (GUIAnyC w) = getChildren w
|
||||
getChildren (GUIAnyP w) = getChildren w
|
||||
getChildren (GUIAnyB w _) = getChildren w
|
||||
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
|
||||
|
||||
@ -1,26 +1,79 @@
|
||||
module UI.UIOperations where
|
||||
|
||||
import Control.Monad (liftM)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.Maybe
|
||||
|
||||
import Types
|
||||
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
|
||||
toGUIAny :: Map.HashMap UIId (GUIAny m) -> UIId -> GUIAny m
|
||||
toGUIAny m uid = case Map.lookup uid m of
|
||||
Just w -> w
|
||||
Nothing -> error "map does not contain requested key" --TODO: better error handling
|
||||
{-# INLINE toGUIAny #-}
|
||||
|
||||
toGUIAnys :: Map.HashMap UIId (GUIAny m) -> [UIId] -> [GUIAny m]
|
||||
toGUIAnys m ids = mapMaybe (flip Map.lookup m) ids
|
||||
{-# INLINE toGUIAnys #-}
|
||||
-- TODO: check for missing components?
|
||||
|
||||
|
||||
-- |The function 'getInside' returns child widgets that overlap with a specific
|
||||
-- screen position.
|
||||
--
|
||||
-- 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, which may be the input widget itself,
|
||||
-- or @[]@ if the point does not hit the widget.
|
||||
--
|
||||
-- This function returns the widgets themselves unlike 'getInsideId'.
|
||||
getInside :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
|
||||
-> ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> GUIAny Pioneers -- ^the parent widget
|
||||
-> Pioneers [GUIAny Pioneers]
|
||||
getInside hMap x' y' wg = do
|
||||
inside <- isInside x' y' wg
|
||||
if inside -- test inside parent's bounding box
|
||||
then do
|
||||
childrenIds <- getChildren wg
|
||||
hitChildren <- liftM concat $ mapM (getInside hMap x' y') (toGUIAnys hMap childrenIds)
|
||||
case hitChildren of
|
||||
[] -> return [wg]
|
||||
_ -> return hitChildren
|
||||
else return []
|
||||
--TODO: Priority queue?
|
||||
|
||||
-- |The function 'getInsideId' returns child widgets that overlap with a
|
||||
-- specific screen position.
|
||||
--
|
||||
-- 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, which may be the input widget itself,
|
||||
-- or @[]@ if the point does not hit the widget.
|
||||
--
|
||||
-- This function returns the 'UIId's of the widgets unlike 'getInside'.
|
||||
getInsideId :: Map.HashMap UIId (GUIAny Pioneers) -- ^map containing ui widgets
|
||||
-> ScreenUnit -- ^screen x coordinate
|
||||
-> ScreenUnit -- ^screen y coordinate
|
||||
-> UIId -- ^the parent widget
|
||||
-> Pioneers [UIId]
|
||||
getInsideId hMap x' y' uid = do
|
||||
let wg = toGUIAny hMap uid
|
||||
inside <- isInside x' y' wg
|
||||
if inside -- test inside parent's bounding box
|
||||
then do
|
||||
childrenIds <- getChildren wg
|
||||
hitChildren <- liftM concat $ mapM (getInsideId hMap x' y') childrenIds
|
||||
case hitChildren of
|
||||
[] -> return [uid]
|
||||
_ -> return hitChildren
|
||||
else return []
|
||||
--TODO: Priority queue?
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user