new UI-Widget type: Viewport, removed old hacked code (except mouse wheel) to handle camera movement and using viewport instead
This commit is contained in:
tpajenka
parent
03d99c5fcc
commit
9523e733c6
@ -133,8 +133,7 @@ main =
|
||||
, _tessClockFactor = 0
|
||||
}
|
||||
, _mouse = MouseState
|
||||
{ _isDown = False
|
||||
, _isDragging = False
|
||||
{ _isDragging = False
|
||||
, _dragStartX = 0
|
||||
, _dragStartY = 0
|
||||
, _dragStartXAngle = 0
|
||||
|
||||
@ -60,8 +60,7 @@ data GameState = GameState
|
||||
}
|
||||
|
||||
data MouseState = MouseState
|
||||
{ _isDown :: !Bool
|
||||
, _isDragging :: !Bool
|
||||
{ _isDragging :: !Bool
|
||||
, _dragStartX :: !Double
|
||||
, _dragStartY :: !Double
|
||||
, _dragStartXAngle :: !Double
|
||||
|
||||
@ -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
|
||||
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]
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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
|
||||
Loading…
Reference in New Issue
Block a user