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

new UI-Widget type: Viewport, removed old hacked code (except mouse wheel) to handle camera movement and using viewport instead

Browse Source
This commit is contained in:
tpajenka
2014-05-21 14:10:47 +02:00
parent 03d99c5fcc
commit 9523e733c6
5 changed files with 90 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/Main.hs
View File

@@ -133,8 +133,7 @@ main =
, _tessClockFactor = 0
}
, _mouse = MouseState
{ _isDown = False
, _isDragging = False
{ _isDragging = False
, _dragStartX = 0
, _dragStartY = 0
, _dragStartXAngle = 0

3
src/Types.hs
View File

@@ -60,8 +60,7 @@ data GameState = GameState
}
data MouseState = MouseState
{ _isDown :: !Bool
, _isDragging :: !Bool
{ _isDragging :: !Bool
, _dragStartX :: !Double
, _dragStartY :: !Double
, _dragStartXAngle :: !Double

41
src/UI/Callbacks.hs
View File

@@ -8,7 +8,7 @@ import Control.Monad (liftM, when, unless)
import Control.Monad.RWS.Strict (ask, get, modify)
import Control.Monad.Trans (liftIO)
import qualified Data.HashMap.Strict as Map
import Data.List (foldl')
--import Data.List (foldl')
import Data.Maybe
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
@@ -22,7 +22,7 @@ import UI.UIOperations
-- TODO: define GUI positions in a file
createGUI :: (Map.HashMap UIId (GUIWidget Pioneers), [UIId])
createGUI = (Map.fromList [ (UIId 0, createPanel (0, 0, 0, 0) [UIId 1, UIId 2] 0)
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 )
@@ -101,38 +101,14 @@ eventCallback e = do
_ ->
return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
do
state <- get
if state ^. mouse.isDown && not (state ^. mouse.isDragging)
then
modify $ (mouse.isDragging .~ True)
. (mouse.dragStartX .~ fromIntegral x)
. (mouse.dragStartY .~ fromIntegral y)
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
else mouseMoveHandler (x, y)
modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
. (mouse.mousePosition. Types._y .~ fromIntegral y)
mouseMoveHandler (x, y)
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
do
case button of
SDL.LeftButton -> do
let pressed = state == SDL.Pressed
modify $ mouse.isDown .~ pressed
if pressed
then mouseReleaseHandler LeftButton (x, y)
else do
st <- get
if st ^. mouse.isDragging then
modify $ mouse.isDragging .~ False
else do
mousePressHandler LeftButton (x, y)
_ -> case state of
SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
_ -> return ()
case state of
SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
_ -> return ()
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do
do -- TODO: MouseWheelHandler
state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
@@ -295,6 +271,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]
"CNT" -> [255,0,0,128]
"BTN" -> [255,255,0,255]
"PNL" -> [128,128,128,128]

44
src/UI/UIBase.hs
View File

@@ -4,7 +4,7 @@
module UI.UIBase where
import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
import Control.Monad (liftM)
import Control.Monad (join,liftM)
import Data.Array
import Data.Bits (xor)
import Data.Hashable
@@ -157,7 +157,7 @@ data EventHandler m =
-- widget’s extent ('isInside') or when the mouse is inside the
-- widget’s extent while another button loses its mouse-active state.
--
-- The function returns the altered widget resulting from the button press
-- The function returns the altered widget resulting from the button press.
_onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseLeave' is invoked when the mouse leaves the
@@ -239,7 +239,45 @@ initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonSta
False (0, 0)
{-# INLINE initialMouseState #-}
-- TODO: combined mouse handler
-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions
-- of two handlers. Thereby, the resulting widget of the first handler is the input widget of the
-- 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 (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" ++
" with constructor MouseHandler"
-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action
-- functions of two handlers. Thereby, the resulting widget of the second handler is the input
-- 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 (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" ++
" with constructor MouseMotionHandler"
-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing.
-- It may be useful as construction kit.
--
-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction
-- >>> emptyMouseHandler { _onMousePress = myPressFunction }
emptyMouseHandler :: (Monad m) => EventHandler m
emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing.
-- It may be useful as construction kit.
--
-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction
-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction }
emptyMouseMotionHandler :: (Monad m) => EventHandler 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,

41
src/UI/UIWidgets.hs
View File

@@ -2,10 +2,10 @@
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Lens ((^.), (.~), (&))
import Control.Lens ((^.), (.~), (%~), (&))
import Control.Monad
--import Control.Monad.IO.Class -- MonadIO
import Control.Monad.RWS.Strict (get)
-- import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify)
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
@@ -43,3 +43,38 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
emptyGraphics
(Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
(Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers
createViewport :: MouseButton -- ^ button to drag with
-> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
emptyGraphics
Map.empty -- widget states
(Map.fromList [(MouseEvent, viewportMouseAction)
,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
where
viewportMouseAction :: EventHandler Pioneers
viewportMouseAction =
let press btn' (x, y) _ w =
do when (btn == btn') $ do
state <- get
modify $ mouse %~ (isDragging .~ True)
. (dragStartX .~ fromIntegral x)
. (dragStartY .~ fromIntegral y)
. (dragStartXAngle .~ (state ^. camera.xAngle))
. (dragStartYAngle .~ (state ^. camera.yAngle))
. (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w
release btn' _ _ w = do when (btn == btn') (modify $ mouse.isDragging .~ False)
return w
in MouseHandler press release
viewportMouseMotionAction :: EventHandler Pioneers
viewportMouseMotionAction =
let move (x, y) w =
do state <- get
when (state ^. mouse.isDragging) $
modify $ mouse %~ (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w
in emptyMouseMotionHandler & onMouseMove .~ move