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?)!!
This commit is contained in:
tpajenka
parent
a9a97f7544
commit
6879201c53
@ -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
|
||||
|
||||
@ -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 ((^.), (.~), (%~))
|
||||
|
||||
@ -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)
|
||||
++ "}"
|
||||
|
||||
@ -2,12 +2,21 @@
|
||||
|
||||
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 uiw) => GUIWidget m uiw where
|
||||
class GUIAnyMap m w where
|
||||
guiAnyMap :: (w -> b) -> GUIAny m -> b
|
||||
|
||||
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)
|
||||
@ -16,7 +25,7 @@ class (GUIAnyMap uiw) => GUIWidget m uiw where
|
||||
--
|
||||
-- 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"
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user