diff --git a/src/Main.hs b/src/Main.hs index 14bdb5e..92184c3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,7 @@ import Control.Lens ((^.), (.~), (%~)) -- data consistency/conversion import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TQueue, newTQueueIO, atomically) -import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar) +import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar, readTVarIO) import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Data.Functor ((<$>)) @@ -89,7 +89,8 @@ main = do initRendering --generate map vertices curMap <- exportedMap - glMap' <- initMapShader 4 =<< getMapBufferObject curMap + (glMap', tex) <- initMapShader 4 =<< getMapBufferObject curMap + tex' <- newTVarIO tex eventQueue <- newTQueueIO :: IO (TQueue SDL.Event) now <- getCurrentTime --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10 @@ -111,7 +112,7 @@ main = do game' <- newTVarIO GameState { _currentMap = curMap } - camStack' <- newTVarIO Map.empty + let camStack' = Map.empty glHud' <- initHud let zDistClosest' = 2 zDistFarthest' = zDistClosest' + 10 @@ -140,18 +141,8 @@ main = do , _tessClockTime = now } , _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 } @@ -188,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 @@ -241,7 +210,7 @@ run = do targetFrametime = 1.0/targetFramerate --targetFrametimeμs = targetFrametime * 1000000.0 now <- getCurrentTime - let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs + let diff = max 0.001 $ diffUTCTime now (state ^. io.clock) -- get time-diffs updatediff = diffUTCTime now (state ^. io.tessClockTime) -- get diff to last update title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"] ddiff = double diff @@ -325,8 +294,8 @@ adjustWindow = do let hudtexid = state ^. gl.glHud.hudTexture - maptexid = state ^. gl.glMap.renderedMapTexture smaptexid = state ^. gl.glMap.shadowMapTexture + maptexid <- liftIO $ readTVarIO (state ^. mapTexture) allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do --default to ugly pink to see if --somethings go wrong. diff --git a/src/Render/Render.hs b/src/Render/Render.hs index cd8b202..1e7de0c 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -62,7 +62,7 @@ initBuffer varray = initMapShader :: Int -- ^ initial Tessallation-Factor -> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor - -> IO GLMapState + -> IO (GLMapState, TextureObject) initMapShader tessFac (buf, vertDes) = do ! vertexSource <- B.readFile mapVertexShaderFile ! tessControlSource <- B.readFile mapTessControlShaderFile @@ -131,7 +131,7 @@ initMapShader tessFac (buf, vertDes) = do testobj <- parseIQM "models/box.iqm" let - objs = [MapObject testobj (L.V3 0 10 0) (MapObjectState ())] + objs = [MapObject testobj (L.V3 0 10 0) (MapObjectState ())] currentProgram $= Nothing @@ -210,11 +210,10 @@ initMapShader tessFac (buf, vertDes) = do , shdrMOTessOuterIndex = UniformLocation 0 --tessLevelOuter' } - return GLMapState + return (GLMapState { _mapProgram = program , _mapShaderData = sdata , _mapObjectShaderData = smodata - , _renderedMapTexture = tex , _stateTessellationFactor = tessFac , _stateMap = buf , _mapVert = vertDes @@ -224,7 +223,7 @@ initMapShader tessFac (buf, vertDes) = do , _mapObjects = objs , _objectProgram = objProgram , _shadowMapProgram = shadowProgram - } + }, tex) initHud :: IO GLHud initHud = do @@ -295,7 +294,7 @@ renderIQM m p@(L.V3 x y z) s@(L.V3 sx sy sz) = do renderObject :: MapObject -> IO () renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) = - renderIQM model pos (L.V3 1 1 1) + renderIQM model pos (L.V3 1 1 1) drawMap :: Pioneers () drawMap = do @@ -445,12 +444,13 @@ render = do ---- RENDER MAP IN TEXTURE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -- COLORMAP - textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) + tex <- liftIO $ readTVarIO (state ^. mapTexture) + textureBinding Texture2D $= Just tex framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D - (state ^. gl.glMap.renderedMapTexture) + tex 0 -- Render to FrameBufferObject @@ -503,7 +503,8 @@ render = do uniform (hud ^. hudTexIndex) $= Index1 (0::GLint) activeTexture $= TextureUnit 1 - textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture) + tex <- liftIO $ readTVarIO (state ^. mapTexture) + textureBinding Texture2D $= Just tex uniform (hud ^. hudBackIndex) $= Index1 (1::GLint) bindBuffer ArrayBuffer $= Just (hud ^. hudVBO) diff --git a/src/Types.hs b/src/Types.hs index 935bf21..e703559 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -11,7 +11,7 @@ import Linear.Matrix (M44) import Linear (V3) import Control.Monad.RWS.Strict (RWST, liftIO, get) import Control.Monad.Writer.Strict -import Control.Monad (when) +--import Control.Monad (when) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types @@ -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 @@ -111,7 +102,6 @@ data GLMapState = GLMapState , _stateMap :: !GL.BufferObject , _mapVert :: !GL.NumArrayIndices , _mapProgram :: !GL.Program - , _renderedMapTexture :: !TextureObject --TODO: Probably move to UI? , _overviewTexture :: !TextureObject , _shadowMapTexture :: !TextureObject , _mapTextures :: ![TextureObject] --TODO: Fix size on list? @@ -174,8 +164,8 @@ data GLState = GLState data UIState = UIState { _uiHasChanged :: !Bool - , _uiMap :: !(Map.HashMap UIId (GUIWidget Pioneers)) - , _uiObserverEvents :: !(Map.HashMap EventKey [EventHandler Pioneers]) + , _uiMap :: Map.HashMap UIId (GUIWidget Pioneers) + , _uiObserverEvents :: Map.HashMap EventKey [EventHandler Pioneers] , _uiRoots :: !([UIId]) , _uiButtonState :: !UIButtonState } @@ -183,9 +173,9 @@ data UIState = UIState data State = State { _window :: !WindowState , _camera :: TVar CameraState - , _camStack :: TVar (Map.HashMap UIId (CameraState, TextureObject)) + , _mapTexture :: TVar TextureObject + , _camStack :: (Map.HashMap UIId (TVar CameraState, TVar 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/Callbacks.hs b/src/UI/Callbacks.hs index 62bf672..924b718 100644 --- a/src/UI/Callbacks.hs +++ b/src/UI/Callbacks.hs @@ -26,11 +26,12 @@ import UI.UIOperations createGUI :: ScreenUnit -> ScreenUnit -> UIState createGUI w h = UIState { _uiHasChanged = True - , _uiMap = Map.fromList [ (UIId 0, createViewport LeftButton (0, 0, w, h) [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) + , _uiMap = Map.fromList [ (UIId 0, createViewport (camera) LeftButton (0, 0, w, h) [UIId 1, UIId 2, UIId 5] 0) -- TODO: automatic resize + , (UIId 1, createContainer (30, 415, 100, 80) [] 1) + , (UIId 2, createPanel (50, 240, 0, 0) [UIId 3, UIId 4] 3) , (UIId 3, createContainer (80, 15, 130, 90) [] 4 ) , (UIId 4, createButton (10, 40, 60, 130) 2 testMessage) + , (UIId 5, createViewport (camera) LeftButton (10, 10, 300, 200) [] 5) -- TODO: wrong camera ] , _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])] , _uiRoots = [UIId 0] @@ -311,6 +312,10 @@ copyGUI tex (vX, vY) widget = do (GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff))) (GL.TextureSize2D (int wWidth) (int wHeight)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr) + prio <- widget ^. baseProperties.priority + when (widget ^. baseProperties.shorthand == "VWP" && prio == 5) $ do + -- copy camera texture on screen + return () nextChildrenIds <- widget ^. baseProperties.children mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds 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..42bf9d2 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, TVar()) +import Control.Lens ((^.), (.~), (%~), (&), (^?), at, Getting()) 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 @@ -46,39 +48,68 @@ createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN") (Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states (Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers -createViewport :: MouseButton -- ^ button to drag with +createViewport :: Getting (TVar CameraState) State (TVar CameraState) +--Setting (->) State State (TVar CameraState) (TVar CameraState) -- ^ lens to connected @TVar CameraState@ + -> MouseButton -- ^ button to drag with -> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers -createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP") +createViewport thelens 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 -> CameraState -> CameraState + updateCamera xStart' yStart' x y sodxa sodya cam = + 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' + in cam & (xAngle .~ newXAngle) . (yAngle .~ newYAngle) + 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 + let camT = state ^. thelens + cam <- liftIO $ readTVarIO camT + let sodxa = cam ^. xAngle + sodya = cam ^. yAngle + liftIO $ atomically $ writeTVar camT $ + updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya cam + 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 + state <- get + let camT = state ^. thelens + cam <- liftIO $ readTVarIO camT + 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 + liftIO $ atomically $ writeTVar camT $ + updateCamera xS yS (fromIntegral x) (fromIntegral y) sodxa sodya cam + Nothing -> return () return w in emptyMouseMotionHandler & onMouseMove .~ move