From 73e742e1a298608667740330f95f4acdc376a67d Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 26 Mar 2023 16:44:19 +0100 Subject: [PATCH] Implement floating camera --- src/Dodge/Base/Coordinate.hs | 6 ++++++ src/Dodge/Creature/Impulse/UseItem.hs | 2 +- src/Dodge/Creature/YourControl.hs | 4 ++-- src/Dodge/Data/Input.hs | 7 ++++-- src/Dodge/Default/World.hs | 2 ++ src/Dodge/Event/Input.hs | 8 ++++--- src/Dodge/Menu.hs | 1 + src/Dodge/TestString.hs | 31 +++++++++++++++------------ src/Dodge/Update.hs | 25 ++++++++++++--------- src/Dodge/Update/Camera.hs | 27 ++++++++++++++++++++++- src/Dodge/Update/Input/InGame.hs | 7 +++--- src/Dodge/Update/Input/ScreenLayer.hs | 4 ++-- 12 files changed, 86 insertions(+), 38 deletions(-) diff --git a/src/Dodge/Base/Coordinate.hs b/src/Dodge/Base/Coordinate.hs index b1b422105..0d2e67726 100644 --- a/src/Dodge/Base/Coordinate.hs +++ b/src/Dodge/Base/Coordinate.hs @@ -2,6 +2,7 @@ module Dodge.Base.Coordinate ( mouseWorldPos, cartePosToScreen, worldPosToScreen, + screenToWorldPos, ) where import Control.Lens @@ -47,6 +48,11 @@ mouseWorldPos inp cam = (cam ^. camCenter) +.+ (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) (_mousePos inp) +screenToWorldPos :: Camera -> Point2 -> Point2 +screenToWorldPos cam p = + (cam ^. camCenter) + +.+ (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p + ---- | The mouse position in map coordinates --mouseCartePos :: World -> Point2 --mouseCartePos w = (thehud ^. carteCenter) diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index a87d0e92f..5b15bf1a2 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -55,7 +55,7 @@ itemEffect cr it w = case it ^. itUse of tryReload :: Creature -> Item -> Input -> (World -> World) -> World -> World tryReload cr it theinput f - | cid == 0 && itNeedsLoading it && _mouseButtons theinput M.!? SDL.ButtonLeft == Just False = + | cid == 0 && itNeedsLoading it && _mouseButtons theinput M.!? SDL.ButtonLeft == Just 1 = cWorld . lWorld . creatures . ix cid %~ crToggleReloading | otherwise = (runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . heldHammer .~ HammerDown))) diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index a4b525f5e..2b2d258ef 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -104,7 +104,7 @@ wasdDir :: World -> Point2 wasdDir = foldl' (flip $ (+.+) . wasdM) (V2 0 0) . M.keys . _pressedKeys . _input -- | Set posture according to mouse presses. -mouseActionsCr :: M.Map SDL.MouseButton Bool -> Creature -> Creature +mouseActionsCr :: M.Map SDL.MouseButton Int -> Creature -> Creature mouseActionsCr pkeys cr | rbPressed && noaction = cr & crStance . posture .~ Aiming @@ -115,7 +115,7 @@ mouseActionsCr pkeys cr theaction <- cr ^? crManipulation . manObject . inInventory . iselAction return $ theaction == NoInvSelAction -pressedMBEffectsTopInventory :: M.Map SDL.MouseButton Bool -> World -> World +pressedMBEffectsTopInventory :: M.Map SDL.MouseButton Int -> World -> World pressedMBEffectsTopInventory pkeys w | isDown SDL.ButtonLeft && isDown SDL.ButtonRight && inTopInv = useItem (you w) w | isDown SDL.ButtonLeft && inTopInv = doTopInvLeftClick (you w) w diff --git a/src/Dodge/Data/Input.hs b/src/Dodge/Data/Input.hs index cd01d50d9..3d8b15f7b 100644 --- a/src/Dodge/Data/Input.hs +++ b/src/Dodge/Data/Input.hs @@ -20,7 +20,7 @@ data Input = Input { _mousePos :: Point2 -- in pixels, from the center of the screen , _mouseMoving :: Bool , _pressedKeys :: M.Map Scancode PressType - , _mouseButtons :: M.Map MouseButton Bool -- shortpress False, repeatpress True + , _mouseButtons :: M.Map MouseButton Int -- counts number of frames held down , _scrollAmount :: Int , _previousScrollAmount :: Int , _lLine :: (Point2, Point2) @@ -28,7 +28,10 @@ data Input = Input , _lrLine :: (Point2, Point2) , _lSelect :: Point2 , _rSelect :: Point2 - , _clickMousePos :: Point2 + , _clickMousePos :: Point2 -- is this in world or screen coords? + , _clickPos :: M.Map MouseButton Point2 -- updates when mouse button is pressed + , _heldPos :: M.Map MouseButton Point2 -- updates when mouse button is held + -- ideally, lags ONE FRAME BEHIND the stored mouse position , _textInput :: [Either TermSignal Char] , _scrollTestFloat :: Float , _scrollTestInt :: Int diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 7fbe860ce..c0b2a0d61 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -14,6 +14,8 @@ defaultInput :: Input defaultInput = Input { _clickMousePos = V2 0 0 + , _clickPos = mempty + , _heldPos = mempty , _textInput = mempty , _pressedKeys = mempty , _mouseButtons = mempty diff --git a/src/Dodge/Event/Input.hs b/src/Dodge/Event/Input.hs index eb526aaa2..4baa4a7d5 100644 --- a/src/Dodge/Event/Input.hs +++ b/src/Dodge/Event/Input.hs @@ -12,6 +12,7 @@ import Dodge.Data.Config import Dodge.Data.Input import LensHelp import SDL +--import qualified Data.Map.Strict as M -- annoyingly, the text input event doesn't register backspace, so deletion has to be -- dealt with separately @@ -55,7 +56,8 @@ handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y handleMouseButtonEvent :: MouseButtonEventData -> Input -> Input handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of - Released -> pointtothebutton .~ Nothing - Pressed -> pointtothebutton ?~ False + Released -> mouseButtons . at thebutton .~ Nothing + Pressed -> mouseButtons . at thebutton ?~ 1 -- note that mouse button events are NOT repeating where - pointtothebutton = mouseButtons . at (mouseButtonEventButton mbev) +-- pointtothebutton = mouseButtons . at thebutton + thebutton = mouseButtonEventButton mbev diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index d2ce8a0fb..cd017eba7 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -231,6 +231,7 @@ listControls = , ("x", "EXAMINE ITEMS") , ("c|", "PAUSE AND DISPLAY MENU") , ("q|e", "ROTATE CAMERA") + , ("", "USE NORMAL CAMERA") , ("", "PAUSE AND FLOAT CAMERA") , ("", "PAUSE AND PAN CAMERA") , ("", "QUICKSAVE") diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index a3d03efca..5240bc335 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} module Dodge.TestString where import HelpNum @@ -15,20 +16,22 @@ import Dodge.Data.Universe --import qualified Data.Map.Strict as M --import qualified IntMapHelp as IM testStringInit :: Universe -> [String] -testStringInit u = [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . cwCam) - (u ^. uvWorld . cWorld . lWorld) - , show a - , show $ u ^. uvWorld . input . mousePos - , show $ u ^. uvConfig . windowX - , show $ u ^. uvConfig . windowY - , show $ u ^. uvWorld . input . scrollTestInt - ] - where - w = u ^. uvWorld - a = fromMaybe 0 $ do - cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos - return . toClosestMultiple (pi/ 8) $ argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCam) -.- cpos) - - w ^. cWorld . cwCam . camRot +testStringInit u = [show $ u ^. uvWorld . input . mouseButtons + , show $ u ^. uvWorld . input . heldPos] +-- [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . cwCam) +-- (u ^. uvWorld . cWorld . lWorld) +-- , show a +-- , show $ u ^. uvWorld . input . mousePos +-- , show $ u ^. uvConfig . windowX +-- , show $ u ^. uvConfig . windowY +-- , show $ u ^. uvWorld . input . scrollTestInt +-- ] +-- where +-- w = u ^. uvWorld +-- a = fromMaybe 0 $ do +-- cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos +-- return . toClosestMultiple (pi/ 8) $ argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCam) -.- cpos) +-- - w ^. cWorld . cwCam . camRot --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just] -- [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections] diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index f94368dd4..9d0b84d24 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -105,11 +105,13 @@ gotoTerminal w = case _uvScreenLayers w of _ -> w & uvScreenLayers .:~ InputScreen mempty "Enter command" updateUniverseLast :: Universe -> Universe -updateUniverseLast = - over uvWorld (input . mouseButtons . each .~ True) -- to determine if the mouse button is held - . over uvWorld (input . pressedKeys . each %~ f) - . over uvWorld (input . mouseMoving .~ False) +updateUniverseLast u = u + & uvWorld . input . pressedKeys . each %~ f + & uvWorld . input . mouseMoving .~ False + & uvWorld . input . mouseButtons . each +~ 1 + & uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons)) where + mp = u ^. uvWorld . input . mousePos f LongPress = LongPress f _ = ShortPress @@ -131,25 +133,28 @@ updateUniverseMid u = case _uvScreenLayers u of timeFlowUpdate :: Universe -> Universe timeFlowUpdate u = case u ^. uvWorld . timeFlow of + _ | debugcamera -> u NormalTimeFlow -> functionalUpdate u ScrollTimeFlow smoothing _ _ _ -> over uvWorld (doTimeScroll smoothing) u RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow DeathTime{} -> u PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u + where + debugcamera = CamInGame /= (u ^. uvWorld . cWorld . cwCam . camControl) pauseTime :: Int -> World -> World pauseTime itmloc w | justPressedButtonLeft || outofcharge = w & timeFlow .~ NormalTimeFlow | otherwise = w & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix itmloc) . itUse . leftConsumption . wpCharge -~ 1 where - justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just False + justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just 1 outofcharge = maybe True (== 0) charge charge = w ^? pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix itmloc) . itUse . leftConsumption . wpCharge doTimeScroll :: Int -> World -> World doTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of - Just False -> w & timeFlow .~ NormalTimeFlow + Just 1 -> w & timeFlow .~ NormalTimeFlow _ -> doTimeScroll' smoothing w doTimeScroll' :: Int -> World -> World @@ -286,16 +291,16 @@ updateWorldSelect' w = over input (updateWorldSelect (w ^. cWorld . cwCam)) w updateWorldSelect :: Camera -> Input -> Input updateWorldSelect cam inp = f . g $ case (inp ^? mouseButtons . ix ButtonLeft, inp ^? mouseButtons . ix ButtonRight) of - (Just False, Nothing) -> + (Just 1, Nothing) -> inp & lLine . _1 .~ mwp & lrLine . _1 .~ mwp - (Just True, Nothing) -> + (Just _, Nothing) -> inp & lLine . _2 .~ mwp & lrLine . _1 .~ mwp - (Nothing, Just False) -> + (Nothing, Just 1) -> inp & rLine . _1 .~ mwp & lrLine . _2 .~ mwp - (Nothing, Just True) -> + (Nothing, Just _) -> inp & rLine . _2 .~ mwp & lrLine . _2 .~ mwp _ -> inp diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 76df9d4a8..a4afdd9f9 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -5,6 +5,8 @@ module Dodge.Update.Camera ( updateCamera, ) where +import SDL (MouseButton (..)) +import Dodge.Base.Coordinate import Dodge.InputFocus import Bound import Dodge.Viewpoints @@ -28,9 +30,32 @@ update where your avatar's view is from. -} updateCamera :: Configuration -> World -> World updateCamera cfig w = case w ^. cWorld . cwCam . camControl of CamInGame -> updateInGameCamera cfig w - CamFloat -> w + CamFloat -> updateFloatingCamera cfig w CamPan -> w +updateFloatingCamera :: Configuration -> World -> World +updateFloatingCamera cfig w = w + & updateBounds cfig + & cWorld . cwCam %~ setViewDistance cfig + & cWorld . cwCam %~ translateFloatingCamera theinput + & cWorld . cwCam %~ zoomFloatingCamera theinput + where + theinput = w ^. input + +translateFloatingCamera :: Input -> Camera -> Camera +translateFloatingCamera theinput cam = fromMaybe cam $ do + presstime <- theinput ^. mouseButtons . at ButtonLeft + guard $ presstime > 1 + hpos <- theinput ^? heldPos . ix ButtonLeft + let thetran = + screenToWorldPos cam hpos + -.- + screenToWorldPos cam (theinput ^. mousePos) + return $ cam & camCenter +~ thetran + & camViewFrom +~ thetran + +zoomFloatingCamera theinput cam = cam + updateInGameCamera :: Configuration -> World -> World updateInGameCamera cfig w = w diff --git a/src/Dodge/Update/Input/InGame.hs b/src/Dodge/Update/Input/InGame.hs index 12c0ebce2..3a595163a 100644 --- a/src/Dodge/Update/Input/InGame.hs +++ b/src/Dodge/Update/Input/InGame.hs @@ -61,12 +61,12 @@ updateUseInputInGame h u = case h of where w = u ^. uvWorld pkeys = u ^. uvWorld . input . pressedKeys - lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just False + lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just 1 updatePressedButtonsCarte :: World -> World updatePressedButtonsCarte w = updatePressedButtonsCarte' (_mouseButtons (_input w)) w -updatePressedButtonsCarte' :: M.Map MouseButton Bool -> World -> World +updatePressedButtonsCarte' :: M.Map MouseButton Int -> World -> World updatePressedButtonsCarte' pkeys w | isDown ButtonRight = w @@ -106,6 +106,7 @@ updateKeyInGame uv sc pt = case pt of updateInitialPressInGame :: Universe -> Scancode -> Universe updateInitialPressInGame uv sc = case sc of + ScancodeF1 -> useNormalCamera uv ScancodeF2 -> pauseAndFloatCam uv ScancodeF3 -> pauseAndPanCam uv ScancodeF5 -> doQuicksave uv @@ -149,7 +150,7 @@ doRegexInput u i sss any ((== Just InitialPress) . (`M.lookup` pkeys)) [ScancodeReturn, ScancodeSlash] - endmouse = fromMaybe False $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft + endmouse = maybe False (==1) $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft backspacetonothing = sss ^? sssExtra . sssFilters . ix i . _Just == Just "" && ScancodeBackspace `M.lookup` pkeys == Just InitialPress diff --git a/src/Dodge/Update/Input/ScreenLayer.hs b/src/Dodge/Update/Input/ScreenLayer.hs index 49cf9768e..dfed78747 100644 --- a/src/Dodge/Update/Input/ScreenLayer.hs +++ b/src/Dodge/Update/Input/ScreenLayer.hs @@ -60,12 +60,12 @@ mouseClickOptionsList :: ScreenLayer -> Universe -> Universe mouseClickOptionsList screen u = fromMaybe u $ do sl <- screen ^? scSelectionList Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of - Just False -> fromMaybe u $ do + Just 1 -> fromMaybe u $ do i <- sl ^. slSelPos f <- sl ^? slItems . ix i . siPayload . _1 return $ f u _ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of - Just False -> fromMaybe u $ do + Just 1 -> fromMaybe u $ do i <- sl ^. slSelPos f <- sl ^? slItems . ix i . siPayload . _2 return $ f u