diff --git a/src/Main.hs b/src/Main.hs index 41b5533..d0da614 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -143,17 +143,6 @@ main = do , _camera = cam' , _mapTexture = tex' , _camStack = camStack' - , _mouse = MouseState - { _isDragging = False - , _dragStartX = 0 - , _dragStartY = 0 - , _dragStartXAngle = 0 - , _dragStartYAngle = 0 - , _mousePosition = Types.Position - { Types.__x = 5 - , Types.__y = 5 - } - } , _keyboard = KeyboardState { _arrowsPressed = aks } @@ -190,28 +179,6 @@ run = do -- update State state <- get - -- change in camera-angle - when (state ^. mouse.isDragging) $ do - let sodx = state ^. mouse.dragStartX - sody = state ^. mouse.dragStartY - sodxa = state ^. mouse.dragStartXAngle - sodya = state ^. mouse.dragStartYAngle - x' = state ^. mouse.mousePosition._x - y' = state ^. mouse.mousePosition._y - myrot = (x' - sodx) / 2 - mxrot = (y' - sody) / 2 - newXAngle = curb (pi/12) (0.45*pi) newXAngle' - newXAngle' = sodxa + mxrot/100 - newYAngle - | newYAngle' > pi = newYAngle' - 2 * pi - | newYAngle' < (-pi) = newYAngle' + 2 * pi - | otherwise = newYAngle' - newYAngle' = sodya + myrot/100 - - liftIO $ atomically $ do - cam <- readTVar (state ^. camera) - cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam - writeTVar (state ^. camera) cam' -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle diff --git a/src/Types.hs b/src/Types.hs index 3236c7d..e9fb681 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -64,15 +64,6 @@ data GameState = GameState { _currentMap :: !PlayMap } -data MouseState = MouseState - { _isDragging :: !Bool - , _dragStartX :: !Double - , _dragStartY :: !Double - , _dragStartXAngle :: !Double - , _dragStartYAngle :: !Double - , _mousePosition :: !Position --TODO: Get rid of mouse-prefix - } - data ArrowKeyState = ArrowKeyState { _up :: !Bool ,_down :: !Bool @@ -185,7 +176,6 @@ data State = State , _mapTexture :: TVar TextureObject , _camStack :: TVar (Map.HashMap UIId (CameraState, TextureObject)) , _io :: !IOState - , _mouse :: !MouseState , _keyboard :: !KeyboardState , _gl :: !GLState , _game :: TVar GameState @@ -208,7 +198,6 @@ $(makeLenses ''GLMapState) $(makeLenses ''GLHud) $(makeLenses ''KeyboardState) $(makeLenses ''ArrowKeyState) -$(makeLenses ''MouseState) $(makeLenses ''GameState) $(makeLenses ''IOState) $(makeLenses ''CameraState) diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index f3ad69e..465630b 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -63,7 +63,7 @@ instance Hashable MouseButton where -- TODO: generic deriving creates functions --- widget state --------------------------- -- |A key to reference a specific type of 'WidgetState'. -data WidgetStateKey = MouseStateKey +data WidgetStateKey = MouseStateKey | ViewportStateKey deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read) instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever @@ -83,8 +83,9 @@ data UIButtonState = UIButtonState -- |The button dependant state of a 'MouseState'. data MouseButtonState = MouseButtonState { _mouseIsDragging :: Bool -- ^firing if pressed but not confirmed - , _mouseIsDeferred :: Bool + , _mouseIsDeferred :: Bool -- ^deferred if e. g. dragging but outside component + , _dragStart :: (ScreenUnit, ScreenUnit) } deriving (Eq, Show) -- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'. @@ -95,6 +96,15 @@ data WidgetState = , _mouseIsReady :: Bool -- ^ready if mouse is above component , _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component } + | + -- |A position to store screen units. Referenced by 'ViewportStateKey'. + ViewportState + { _isDragging :: Bool + , _dragStartX :: Double + , _dragStartY :: Double + , _dragAngleX :: Double + , _dragAngleY :: Double + } deriving (Eq, Show) --------------------------- @@ -176,7 +186,7 @@ instance Hashable EventKey where -- TODO: generic deriving creates functions tha hash = fromEnum hashWithSalt salt x = (salt * 16777619) `xor` hash x - -- |A handler to react on certain events. Corresponding key: 'EventKey'. +-- |A handler to react on certain events. Corresponding key: 'EventKey'. data EventHandler (m :: * -> *) = WindowHandler { @@ -255,9 +265,12 @@ $(makeLenses ''GUIWidget) $(makeLenses ''GUIBaseProperties) $(makeLenses ''GUIGraphics) +initialViewportState :: WidgetState +initialViewportState = ViewportState False 0 0 0 0 + -- |Creates a default @MouseButtonState@. initialButtonState :: MouseButtonState -initialButtonState = MouseButtonState False False +initialButtonState = MouseButtonState False False (0, 0) {-# INLINE initialButtonState #-} -- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'. diff --git a/src/UI/UIWidgets.hs b/src/UI/UIWidgets.hs index 9ab9215..b44a98e 100644 --- a/src/UI/UIWidgets.hs +++ b/src/UI/UIWidgets.hs @@ -2,8 +2,9 @@ module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where -import Control.Concurrent.STM.TVar (readTVarIO) -import Control.Lens ((^.), (.~), (%~), (&)) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (readTVarIO, writeTVar) +import Control.Lens ((^.), (.~), (%~), (&), (^?), at) import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.RWS.Strict (get, modify) @@ -11,7 +12,8 @@ import Data.List import Data.Maybe import qualified Data.HashMap.Strict as Map -import Types +import Types +import Render.Misc (curb) import UI.UIBase import UI.UIOperations @@ -50,35 +52,60 @@ 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 [(ViewportStateKey, initialViewportState)]) -- widget states (Map.fromList [(MouseEvent, viewportMouseAction) ,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers where + updateCamera :: Double -> Double -> Double -> Double -> Double -> Double -> Pioneers () + updateCamera xStart' yStart' x y sodxa sodya = do + state <- get + cam <- liftIO $ readTVarIO (state ^. camera) + let myrot = (x - xStart') / 2 + mxrot = (y - yStart') / 2 + newXAngle' = sodxa + mxrot/100 + newXAngle = curb (pi/12) (0.45*pi) newXAngle' + newYAngle' = sodya + myrot/100 + newYAngle + | newYAngle' > pi = newYAngle' - 2 * pi + | newYAngle' < (-pi) = newYAngle' + 2 * pi + | otherwise = newYAngle' + + liftIO $ atomically $ + writeTVar (state ^. camera) $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam + viewportMouseAction :: WidgetEventHandler Pioneers viewportMouseAction = let press btn' (x, y) _ w = - do when (btn == btn') $ do - state <- get - cam <- liftIO $ readTVarIO (state ^. camera) - modify $ mouse %~ (isDragging .~ True) - . (dragStartX .~ fromIntegral x) - . (dragStartY .~ fromIntegral y) - . (dragStartXAngle .~ (cam ^. xAngle)) - . (dragStartYAngle .~ (cam ^. 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 + do if (btn == btn') + then do state <- get + cam <- liftIO $ readTVarIO (state ^. camera) + let sodxa = cam ^. xAngle + sodya = cam ^. yAngle + updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya + return $ w & widgetStates . at ViewportStateKey .~ + Just (ViewportState True (fromIntegral x) (fromIntegral y) sodxa sodya) + else return w + release btn' _ _ w = if (btn' == btn) + then + -- modify ViewportState to "not dragging" or recreate ViewportState state if not present + return $ w & widgetStates . at ViewportStateKey %~ + maybe (Just $ initialViewportState) (\s -> Just (s & isDragging .~ False)) + else return w in MouseHandler press release viewportMouseMotionAction :: WidgetEventHandler 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) + do let mbPosState = w ^. widgetStates.(at ViewportStateKey) + case mbPosState of + Just posState -> + when (maybe False id (posState ^? isDragging)) $ do + let xS = fromJust $ posState ^? dragStartX -- fromJust is safe + yS = fromJust $ posState ^? dragStartY -- fromJust is safe + sodxa = fromJust $ posState ^? dragAngleX -- fromJust is safe + sodya = fromJust $ posState ^? dragAngleY -- fromJust is safe + updateCamera xS yS (fromIntegral x) (fromIntegral y) sodxa sodya + Nothing -> return () return w in emptyMouseMotionHandler & onMouseMove .~ move