Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

finished storing ui widgets into a HashMap and referencing them by UIId.

Browse Source 
Additionally, widgets functions now use the Pioneers monad.
Branch is compiling again and works.
This commit is contained in:
tpajenka 2014-04-26 19:16:53 +02:00
parent 6879201c53
commit 2d80c92384
6 changed files with 166 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Main.hs
View File

@ -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
}
}

1
src/Types.hs
View File

@ -115,6 +115,7 @@ data GLState = GLState
data UIState = UIState
{ _uiHasChanged :: !Bool
, _uiMap :: Map.HashMap UIId (GUIAny Pioneers)
, _uiRoots :: [UIId]
}
data State = State

106
src/UI/Callbacks.hs
View File

@ -2,55 +2,87 @@
module UI.Callbacks where
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])
testMessage :: (Show w) => w -> ScreenUnit -> ScreenUnit -> IO w
getGUI :: Map.HashMap UIId (GUIAny Pioneers) -> [GUIAny Pioneers]
getGUI hmap = Map.elems hmap
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)
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
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,")"]
hit -> liftIO $ do
_ <- sequence $ map (\w ->
_ -> 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
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
(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.
-- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
alternateClickHandler :: Pixel -> Pioneers ()
@ -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?

2
src/UI/UIBaseData.hs
View File

@ -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

12
src/UI/UIClasses.hs
View File

@ -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

79
src/UI/UIOperations.hs
View File

@ -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
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
-> [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
-> 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?