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

introducing window resize event, main viewport resizing to actual window size

Browse Source
This commit is contained in:
tpajenka
2014-05-24 13:47:47 +02:00
parent 9761e7c6c2
commit c7ea247b70
6 changed files with 153 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
src/Main.hs
View File

@@ -45,7 +45,6 @@ import UI.Callbacks
import Map.Graphics
import Map.Creation (exportedMap)
import Types
import qualified UI.UIBase as UI
import Importer.IQM.Parser
--import Data.Attoparsec.Char8 (parseTest)
--import qualified Data.ByteString as B
@@ -66,15 +65,18 @@ testParser a = print =<< parseIQM a
--------------------------------------------------------------------------------
main :: IO ()
main =
main = do
let initialWidth = 1024
initialHeight = 600
SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size 1024 600) [SDL.WindowOpengl -- we want openGL
,SDL.WindowShown -- window should be visible
,SDL.WindowResizable -- and resizable
,SDL.WindowInputFocus -- focused (=> active)
,SDL.WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window' -> do
SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight)
[SDL.WindowOpengl -- we want openGL
,SDL.WindowShown -- window should be visible
,SDL.WindowResizable -- and resizable
,SDL.WindowInputFocus -- focused (=> active)
,SDL.WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window' -> do
SDL.withOpenGL window' $ do
--Create Renderbuffer & Framebuffer
@@ -114,7 +116,6 @@ main =
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage
(guiMap, guiRoots) = createGUI
aks = ArrowKeyState {
_up = False
, _down = False
@@ -159,12 +160,7 @@ main =
, _glFramebuffer = frameBuffer
}
, _game = game'
, _ui = UIState
{ _uiHasChanged = True
, _uiMap = guiMap
, _uiRoots = guiRoots
, _uiButtonState = UI.UIButtonState 0 Nothing False
}
, _ui = createGUI initialWidth initialHeight
}
putStrLn "init done."
@@ -243,7 +239,7 @@ run = do
targetFrametime = 1.0/targetFramerate
--targetFrametimeμs = targetFrametime * 1000000.0
now <- getCurrentTime
let diff = max 0.1 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
ddiff = double diff
SDL.setWindowTitle (env ^. windowObject) title

1
src/Types.hs
View File

@@ -155,6 +155,7 @@ data GLState = GLState
data UIState = UIState
{ _uiHasChanged :: !Bool
, _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers))
, _uiObserverEvents :: !(Map.HashMap EventKey [EventHandler Pioneers])
, _uiRoots :: !([UIId])
, _uiButtonState :: !UIButtonState
}

46
src/UI/Callbacks.hs
View File

@@ -3,7 +3,7 @@ module UI.Callbacks where
import qualified Graphics.Rendering.OpenGL.GL as GL
import Control.Lens ((^.), (.~), (%~), (^?), at)
import Control.Lens ((^.), (.~), (%~), (^?), at, ix)
import Control.Monad (liftM, when, unless)
import Control.Monad.RWS.Strict (ask, get, modify)
import Control.Monad.Trans (liftIO)
@@ -13,7 +13,7 @@ import Data.Maybe
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL
import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar)
import Control.Concurrent.STM.TVar (readTVar, writeTVar)
import Control.Concurrent.STM (atomically)
@@ -23,13 +23,19 @@ import UI.UIWidgets
import UI.UIOperations
-- TODO: define GUI positions in a file
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, 1024, 600) [UIId 1, UIId 2] 0) -- TODO: automatic resize
, (UIId 1, createContainer (30, 215, 100, 80) [] 1)
, (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
], [UIId 0])
createGUI :: ScreenUnit -> ScreenUnit -> UIState
createGUI w h = UIState
{ _uiHasChanged = True
, _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [UIId 1, UIId 2] 0) -- TODO: automatic resize
, (UIId 1, createContainer (30, 215, 100, 80) [] 1)
, (UIId 2, createPanel (50, 40, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
]
, _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
, _uiRoots = [UIId 0]
, _uiButtonState = UIButtonState 0 Nothing False
}
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
getGUI = Map.elems
@@ -69,9 +75,10 @@ eventCallback :: SDL.Event -> Pioneers ()
eventCallback e = do
env <- ask
case SDL.eventData e of
SDL.Window _ _ -> -- windowID event
-- TODO: resize GUI
return ()
SDL.Window _ ev -> -- windowID event
case ev of
SDL.Resized (SDL.Size x y) -> windowResizeHandler x y
_ -> return ()
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
-- need modifiers? use "keyModifiers key" to get them
let aks = keyboard.arrowsPressed in
@@ -125,7 +132,18 @@ eventCallback e = do
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
mouseButtonHandler :: (EventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
windowResizeHandler :: ScreenUnit -> ScreenUnit -> Pioneers ()
windowResizeHandler x y = do
state <- get
case state ^. ui.uiObserverEvents.(at WindowEvent) of
Just evs -> let handle :: EventHandler Pioneers -> Pioneers (EventHandler Pioneers)
handle (WindowHandler h _) = h x y
handle h = return h -- TODO: may log invalid event mapping
in do newEvs <- mapM handle evs
modify $ ui.uiObserverEvents.(ix WindowEvent) .~ newEvs
Nothing -> return ()
mouseButtonHandler :: (WidgetEventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
-> MouseButton -> Pixel -> Pioneers ()
mouseButtonHandler transFunc btn px = do
state <- get
@@ -279,7 +297,7 @@ copyGUI tex (vX, vY) widget = do
--temporary color here. lateron better some getData-function to
--get a list of pixel-data or a texture.
color = case widget ^. baseProperties.shorthand of
"VWP" -> [0,128,128,30]
"VWP" -> [0,128,128,0]
"CNT" -> [255,0,0,128]
"BTN" -> [255,255,0,255]
"PNL" -> [128,128,128,128]

71
src/UI/UIBase.hs
View File

@@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-}
-- widget data is separated into several modules to avoid cyclic dependencies with the Type module
-- TODO: exclude UIMouseState constructor from export?
module UI.UIBase where
@@ -87,7 +87,7 @@ data MouseButtonState = MouseButtonState
-- ^deferred if e. g. dragging but outside component
} deriving (Eq, Show)
-- |An applied state a widget may take, depending on its usage and event handlers.
-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'.
data WidgetState =
-- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
MouseState
@@ -101,18 +101,18 @@ data WidgetState =
--- events
---------------------------
-- |A key to reference a specific 'EventHandler'.
data EventKey = MouseEvent | MouseMotionEvent
-- |A key to reference a specific 'WidgetEventHandler'.
data WidgetEventKey = MouseEvent | MouseMotionEvent
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
instance Hashable WidgetEventKey where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
--- event handlers
-- |A handler to react on certain events.
data EventHandler m =
-- |A handler to react on certain events. Corresponding key: 'WidgetEventKey'.
data WidgetEventHandler m =
-- |Handler to control the functionality of a 'GUIWidget' on mouse button events.
--
-- All screen coordinates are widget-local coordinates.
@@ -168,6 +168,34 @@ data EventHandler m =
}
deriving ()
-- |A key to reference a specific 'EventHandler'.
data EventKey = WindowEvent | WidgetPositionEvent
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
-- |A handler to react on certain events. Corresponding key: 'EventKey'.
data EventHandler (m :: * -> *) =
WindowHandler
{
-- |The function '_onWindowResize' is invoked when the global application window changes size.
--
-- The input is the window’s new width and height in that order.
--
-- The returned handler is resulting handler that may change by the event. Its type must
-- remain @WindowHandler@.
_onWindowResize :: ScreenUnit -> ScreenUnit -> m (EventHandler m)
,
-- |Unique id to identify an event instance.
_eventId :: UIId
}
instance Eq (EventHandler m) where
WindowHandler _ id' == WindowHandler _ id'' = id' == id''
_ == _ = False
---------------------------
--- widgets
@@ -178,7 +206,7 @@ data GUIWidget m = Widget
{_baseProperties :: GUIBaseProperties m
,_graphics :: GUIGraphics m
,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
,_eventHandlers :: Map.HashMap EventKey (EventHandler m) -- no guarantee that data match key
,_eventHandlers :: Map.HashMap WidgetEventKey (WidgetEventHandler m) -- no guarantee that data match key
}
-- |Base properties are fundamental settings of any 'GUIWidget'.
@@ -217,13 +245,12 @@ data GUIBaseProperties m = BaseProperties
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
data GUIGraphics m = Graphics
{temp :: m Int}
data GUIGraphics (m :: * -> *) = Graphics
$(makeLenses ''UIButtonState)
$(makeLenses ''WidgetState)
$(makeLenses ''MouseButtonState)
$(makeLenses ''EventHandler)
$(makeLenses ''WidgetEventHandler)
$(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIGraphics)
@@ -244,11 +271,11 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta
-- second handler and all other parameters are the same for both function calls.
--
-- If not both input handlers are of type @MouseHandler@ an error is raised.
combinedMouseHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m
combinedMouseHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) =
MouseHandler (comb p1 p2) (comb r1 r2)
where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside
combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two EventHandler" ++
combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two WidgetEventHandler" ++
" with constructor MouseHandler"
-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action
@@ -256,11 +283,11 @@ combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two Eve
-- widget of the second handler and all other parameters are the same for both function calls.
--
-- If not both input handlers are of type @MouseMotionHandler@ an error is raised.
combinedMouseMotionHandler :: (Monad m) => EventHandler m -> EventHandler m -> EventHandler m
combinedMouseMotionHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) =
MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2)
where comb h1 h2 px = join . liftM (h2 px) . h1 px
combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two EventHandler" ++
combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two WidgetEventHandler" ++
" with constructor MouseMotionHandler"
-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing.
@@ -268,7 +295,7 @@ combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only com
--
-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction
-- >>> emptyMouseHandler { _onMousePress = myPressFunction }
emptyMouseHandler :: (Monad m) => EventHandler m
emptyMouseHandler :: (Monad m) => WidgetEventHandler m
emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing.
@@ -276,13 +303,13 @@ emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
--
-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction
-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction }
emptyMouseMotionHandler :: (Monad m) => EventHandler m
emptyMouseMotionHandler :: (Monad m) => WidgetEventHandler m
emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return)
-- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export
-- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present,
-- only fully functional in conjunction with 'setMouseMotionStateActions'.
setMouseStateActions :: (Monad m) => EventHandler m
setMouseStateActions :: (Monad m) => WidgetEventHandler m
setMouseStateActions = MouseHandler press' release'
where
-- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@.
@@ -296,7 +323,7 @@ setMouseStateActions = MouseHandler press' release'
-- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present,
-- only fully functional in conjunction with 'setMouseStateActions'.
setMouseMotionStateActions :: (Monad m) => EventHandler m
setMouseMotionStateActions :: (Monad m) => WidgetEventHandler m
setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
where
-- |Updates mouse position.
@@ -324,7 +351,7 @@ setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
--
-- Does /not/ update the widget’s 'MouseState'!
buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> EventHandler m
-> WidgetEventHandler m
buttonMouseActions a = MouseHandler press' release'
where
press' _ _ _ = return
@@ -336,7 +363,7 @@ buttonMouseActions a = MouseHandler press' release'
--
-- Does /not/ update the widget’s 'MouseState'!
buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> MouseButton -> EventHandler m
-> MouseButton -> WidgetEventHandler m
buttonSingleMouseActions a btn = MouseHandler press' release'
where
press' _ _ _ = return
@@ -344,7 +371,7 @@ buttonSingleMouseActions a btn = MouseHandler press' release'
release' b p inside w = if inside && b == btn then a w p else return w
emptyGraphics :: (Monad m) => GUIGraphics m
emptyGraphics = Graphics (return 3)
emptyGraphics = Graphics
-- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit)

41
src/UI/UIOperations.hs
View File

@@ -1,10 +1,12 @@
module UI.UIOperations where
import Control.Lens ((^.))
import Control.Lens ((^.), (%~))
import Control.Monad (liftM)
--import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get)
import Control.Monad.RWS.Strict (get, modify)
import qualified Data.HashMap.Strict as Map
import Data.Hashable
--import qualified Data.List as L
import Data.Maybe
import Types
@@ -29,6 +31,41 @@ isInsideFast wg px = do
(_, _, w, h) <- wg ^. baseProperties.boundary
liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
-- |Adds an event to the given map. The new event is concatenated to present events. Does not test
-- if the map already contains the given element.
addEvent :: (Eq k, Hashable k) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
addEvent k v eventMap = Map.insertWith (++) k [v] eventMap
-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
registerEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
registerEvent k v = modify $ ui.uiObserverEvents %~ addEvent k v
-- |The 'deleteQualitative' function behaves like 'Data.List.deleteBy' but reports @True@ if the
-- list contained the relevant object.
deleteQualitative :: (a -> a -> Bool) -> a -> [a] -> ([a], Bool)
deleteQualitative _ _ [] = ([], False)
deleteQualitative eq x (y:ys) = if x `eq` y then (ys, True) else
let (zs, b) = deleteQualitative eq x ys
in (y:zs, b)
-- |Removes the first occurrence of an event from the given map if it is within the event list of
-- the key.
removeEvent :: (Eq k, Hashable k, Eq v) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
removeEvent k v eventMap =
case Map.lookup k eventMap of
Just list -> case deleteQualitative (==) v list of
(_, False) -> eventMap
(ys, _) -> case ys of
[] -> Map.delete k eventMap
_ -> Map.insert k ys eventMap
Nothing -> Map.insert k [v] eventMap
-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
deregisterEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
deregisterEvent k v = modify $ ui.uiObserverEvents %~ removeEvent k v
-- |The function 'getInsideId' returns child widgets that overlap with a
-- specific screen position and the pixel’s local coordinates.

22
src/UI/UIWidgets.hs
View File

@@ -13,6 +13,7 @@ import qualified Data.HashMap.Strict as Map
import Types
import UI.UIBase
import UI.UIOperations
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
@@ -53,7 +54,7 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
(Map.fromList [(MouseEvent, viewportMouseAction)
,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
where
viewportMouseAction :: EventHandler Pioneers
viewportMouseAction :: WidgetEventHandler Pioneers
viewportMouseAction =
let press btn' (x, y) _ w =
do when (btn == btn') $ do
@@ -71,7 +72,7 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
return w
in MouseHandler press release
viewportMouseMotionAction :: EventHandler Pioneers
viewportMouseMotionAction :: WidgetEventHandler Pioneers
viewportMouseMotionAction =
let move (x, y) w =
do state <- get
@@ -79,4 +80,19 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w
in emptyMouseMotionHandler & onMouseMove .~ move
in emptyMouseMotionHandler & onMouseMove .~ move
resizeToScreenHandler :: UIId -- ^id of a widget
-> EventHandler Pioneers
resizeToScreenHandler id' = WindowHandler resize (UIId 0) -- TODO: unique id
where resize :: ScreenUnit -> ScreenUnit -> Pioneers (EventHandler Pioneers)
resize w h = do
state <- get
let wg = toGUIAny (state ^. ui.uiMap) id'
(x, y, _, _) <- wg ^. baseProperties.boundary
let wg' = wg & baseProperties.boundary .~ return (x, y, w-x, h-y)
modify $ ui.uiMap %~ Map.insert id' wg'
return $ WindowHandler resize (UIId 0)