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

camera is recalculated on mouse action instead of at every frame

Browse Source
This commit is contained in:
tpajenka 2014-06-19 22:24:58 +02:00
parent 8605440539
commit 702ea19253
4 changed files with 65 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Main.hs
View File

@ -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
View File

@ -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)

19
src/UI/UIBase.hs
View File

@ -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
@ -85,6 +85,7 @@ data MouseButtonState = MouseButtonState
{ _mouseIsDragging :: Bool -- ^firing if pressed but not confirmed
, _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'.

65
src/UI/UIWidgets.hs
View File

@ -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)
@ -12,6 +13,7 @@ import Data.Maybe
import qualified Data.HashMap.Strict as Map
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
do if (btn == btn')
then 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
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