camera is recalculated on mouse action instead of at every frame
This commit is contained in:
tpajenka
33
src/Main.hs
33
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
|
||||
|
||||
11
src/Types.hs
11
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)
|
||||
|
||||
@@ -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'.
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user