From 4ffd361f11fe72028eeceb92da4b4a28499d72ae Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 25 Oct 2022 22:59:01 +0100 Subject: [PATCH] Work on mouse wheel scrolling --- src/Dodge/Creature.hs | 1 + src/Dodge/Creature/State.hs | 11 ++++ src/Dodge/Data/CWorld.hs | 1 - src/Dodge/Data/Item/Effect.hs | 4 +- src/Dodge/Data/Item/Use/Consumption.hs | 2 + src/Dodge/Data/World.hs | 7 ++- src/Dodge/Default/Item/Effect.hs | 3 +- src/Dodge/Default/World.hs | 5 +- src/Dodge/Event.hs | 8 ++- src/Dodge/HeldScroll.hs | 16 +++--- src/Dodge/ItEffect.hs | 31 +++++----- src/Dodge/Item/Weapon/Utility.hs | 9 +-- src/Dodge/Luse.hs | 17 +++--- src/Dodge/TestString.hs | 5 +- src/Dodge/Update.hs | 80 +++++++++++++++++++++----- 15 files changed, 143 insertions(+), 57 deletions(-) diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 3dd70a4ce..a61919cc9 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -214,6 +214,7 @@ inventoryX c = case c of , makeTypeCraftNum 1 CONCUSSMODULE , makeTypeCraftNum 1 STATICMODULE ] + 'L' -> [timeScrollGun] 'M' -> stackedInventory 'T' -> testInventory _ -> [] diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 8293c2686..33c1047c3 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -3,6 +3,7 @@ module Dodge.Creature.State ( doDamage, ) where +import Dodge.Creature.Test import Data.Foldable import Dodge.Base import Dodge.Corpse.Make @@ -59,8 +60,18 @@ stateUpdate f = , upInv -- upInv must be called before invSideEff 22.05.23 , invSideEff , equipmentEffects + , heldAimEffects ] +heldAimEffects :: Creature -> World -> World +heldAimEffects cr + | crIsAiming cr = case cr ^? crInv . ix (cr ^. crInvSel . iselPos) of + Just itm -> case itm ^? itEffect . ieWhileAiming of + Just f -> doInvEffect f itm cr + _ -> id + _ -> id + | otherwise = id + checkDeath :: Creature -> World -> World checkDeath cr w | _crHP cr > 0 = w diff --git a/src/Dodge/Data/CWorld.hs b/src/Dodge/Data/CWorld.hs index 3351bec14..8bb3b92f8 100644 --- a/src/Dodge/Data/CWorld.hs +++ b/src/Dodge/Data/CWorld.hs @@ -99,7 +99,6 @@ import Dodge.GameRoom import Geometry.ConvexPoly import Geometry.Data import qualified IntMapHelp as IM -import MaybeHelp import Picture.Data data CWCam = CWCam diff --git a/src/Dodge/Data/Item/Effect.hs b/src/Dodge/Data/Item/Effect.hs index 8b9203eec..ba06cdaad 100644 --- a/src/Dodge/Data/Item/Effect.hs +++ b/src/Dodge/Data/Item/Effect.hs @@ -13,14 +13,14 @@ data ItEffect = ItEffect { _ieInv :: ItInvEffect --Item -> Creature -> World -> World , _ieOnInsert :: ItInvEffect , _ieOnDrop :: ItInvEffect --Item -> Creature -> World -> World - , _ieOnHeld :: ItInvEffect - , _ieOnStash :: ItInvEffect + , _ieWhileAiming :: ItInvEffect } deriving (Eq, Ord, Show, Read) --Generic, Flat) data ItInvEffect = NoInvEffect | RewindEffect + | TimeScrollEffect | EffectIfHeld ItInvEffect ItInvEffect | CreateHeldLight | CreateShieldWall diff --git a/src/Dodge/Data/Item/Use/Consumption.hs b/src/Dodge/Data/Item/Use/Consumption.hs index e23efae6c..fdfdbb1f8 100644 --- a/src/Dodge/Data/Item/Use/Consumption.hs +++ b/src/Dodge/Data/Item/Use/Consumption.hs @@ -26,6 +26,8 @@ data HeldConsumption , _laCycle :: [LoadAction] , _laProgress :: Maybe [LoadAction] } + | ChargingAmmo { _caCharge :: Int + , _caMax :: Int } | NoConsumption deriving (Eq, Show, Read) --Generic, Flat) diff --git a/src/Dodge/Data/World.hs b/src/Dodge/Data/World.hs index f01445aed..4a9ee0933 100644 --- a/src/Dodge/Data/World.hs +++ b/src/Dodge/Data/World.hs @@ -34,6 +34,8 @@ data World = World , _mousePos :: Point2 , _keys :: S.Set Scancode , _mouseButtons :: M.Map MouseButton Bool + , _scrollAmount :: Int + , _previousScrollAmount :: Int , _hammers :: M.Map WorldHammer HammerPosition , _testFloat :: Float , _lLine :: (Point2, Point2) @@ -53,6 +55,7 @@ data TimeFlowStatus | RewindingLastFrame | NormalTimeFlow | ScrollTimeFlow + { _scrollSmoothing :: Int } deriving (Eq, Ord, Show, Read) --Generic, Flat) data WorldHammer @@ -62,7 +65,8 @@ data WorldHammer data CWTime = CWTime { _maybeWorld :: Maybe' CWorld - , _rewindWorlds :: [CWorld] + , _pastWorlds :: [CWorld] + , _pastWorldsNum :: Int , _futureWorlds :: [CWorld] , _worldClock :: Int , _deathDelay :: Maybe Int @@ -70,3 +74,4 @@ data CWTime = CWTime makeLenses ''World makeLenses ''CWTime +makeLenses ''TimeFlowStatus diff --git a/src/Dodge/Default/Item/Effect.hs b/src/Dodge/Default/Item/Effect.hs index 194223740..6e9fe3e3a 100644 --- a/src/Dodge/Default/Item/Effect.hs +++ b/src/Dodge/Default/Item/Effect.hs @@ -8,6 +8,5 @@ defaultItEffect = { _ieInv = NoInvEffect , _ieOnInsert = NoInvEffect , _ieOnDrop = NoInvEffect - , _ieOnHeld = NoInvEffect - , _ieOnStash = NoInvEffect + , _ieWhileAiming = NoInvEffect } diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index d0d2712bb..18e860de2 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -22,6 +22,8 @@ defaultWorld = , _keys = S.empty , _mouseButtons = mempty , _mousePos = V2 0 0 + , _scrollAmount = 0 + , _previousScrollAmount = 0 , _hammers = defaultWorldHammers , _testFloat = 0 , _lrLine = (0, 0) @@ -133,7 +135,8 @@ defaultCWTime = CWTime { _worldClock = 0 , _maybeWorld = Nothing' - , _rewindWorlds = [] + , _pastWorlds = [] + , _pastWorldsNum = 0 , _futureWorlds = [] , _deathDelay = Nothing } diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 35aa0f33e..eaa87ce7a 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -15,7 +15,7 @@ module Dodge.Event ( handleEvent, ) where -import Control.Lens +import LensHelp import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S @@ -93,8 +93,14 @@ handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe handleMouseWheelEvent mwev w = case _uvScreenLayers w of [] -> case mouseWheelEventPos mwev of V2 _ y -> Just $ w & uvWorld %~ wheelEvent (fromIntegral y) + & uvWorld . scrollAmount +~ fromIntegral y _ -> Just w +--wheelEvent' :: Int -> World -> World +--wheelEvent' y w = case w ^. timeFlow of +-- ScrollTimeFlow -> wheelTimeEvent y w +-- _ -> wheelEvent y w + wheelEvent :: Float -> World -> World wheelEvent y w = case _hudElement $ _hud (_cWorld w) of DisplayCarte diff --git a/src/Dodge/HeldScroll.hs b/src/Dodge/HeldScroll.hs index f76273a65..3742ac242 100644 --- a/src/Dodge/HeldScroll.hs +++ b/src/Dodge/HeldScroll.hs @@ -8,7 +8,7 @@ import Data.Sequence import Dodge.Data.Creature import Dodge.Data.World import Dodge.Item.Weapon.ZoomScope -import LensHelp hiding ((|>), (<|)) +--import LensHelp hiding ((|>), (<|)) -- should be able to just import data.item doHeldScroll :: HeldScroll -> Float -> Creature -> World -> World @@ -22,13 +22,13 @@ doHeldScroll hs = case hs of overYourItem f x cr w = w & cWorld . creatures . ix 0 . crInv . ix (crSel $ you w) %~ f x cr doScrollTime :: Float -> Creature -> World -> World -doScrollTime x _ w - | x > 0 = case _futureWorlds $ _cwTime w of - (w':ws) -> w -- & cWorld .~ w' - -- & cwTime . futureWorlds %~ tail - -- & cwTime . rewindWorlds .:~ _cWorld w - _ -> w - | otherwise = w +doScrollTime _ _ w = w +-- | x > 0 = case _futureWorlds $ _cwTime w of +-- (w':ws) -> w -- & cWorld .~ w' +-- -- & cwTime . futureWorlds %~ tail +-- -- & cwTime . rewindWorlds .:~ _cWorld w +-- _ -> w +-- | otherwise = w cycleSignum :: Float -> Seq a -> Seq a cycleSignum x | x > 0 = cycleL diff --git a/src/Dodge/ItEffect.hs b/src/Dodge/ItEffect.hs index a2ee90457..bba026198 100644 --- a/src/Dodge/ItEffect.hs +++ b/src/Dodge/ItEffect.hs @@ -9,6 +9,7 @@ doInvEffect :: ItInvEffect -> Item -> Creature -> World -> World doInvEffect iie = case iie of NoInvEffect -> const $ const id RewindEffect -> rewindEffect + TimeScrollEffect -> timeScrollEffect EffectIfHeld f g -> onOffEff f g CreateHeldLight -> createHeldLight CreateShieldWall -> createShieldWall @@ -23,20 +24,24 @@ onOffEff f g it | _itIsHeld it = doInvEffect f it | otherwise = doInvEffect g it +timeScrollEffect :: Item -> Creature -> World -> World +timeScrollEffect _ _ w = w & timeFlow .~ ScrollTimeFlow 0 + rewindEffect :: Item -> Creature -> World -> World -rewindEffect itm cr w - | Just invid == _crLeftInvSel cr = - w & cwTime . rewindWorlds %~ (take maxcharge . (cw :)) - & ptrWpCharge .~ length (w ^. cwTime . rewindWorlds) - | otherwise = - w & cwTime . rewindWorlds .~ [] - & ptrWpCharge .~ 0 - where - invid = _ipInvID $ _itLocation itm - ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge - maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge - cw = - _cWorld w +rewindEffect _ _ w = w +--rewindEffect itm cr w = +-- | Just invid == _crLeftInvSel cr = +-- w & cwTime . rewindWorlds %~ (take maxcharge . (cw :)) +-- & ptrWpCharge .~ length (w ^. cwTime . rewindWorlds) +-- | otherwise = +-- w & cwTime . rewindWorlds .~ [] +-- & ptrWpCharge .~ 0 +-- where +-- invid = _ipInvID $ _itLocation itm +-- ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge +-- maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge +-- cw = +-- _cWorld w --resetAttachmentEffect :: Item -> Creature -> World -> World --resetAttachmentEffect itm cr w diff --git a/src/Dodge/Item/Weapon/Utility.hs b/src/Dodge/Item/Weapon/Utility.hs index 2590a9e93..e16193042 100644 --- a/src/Dodge/Item/Weapon/Utility.hs +++ b/src/Dodge/Item/Weapon/Utility.hs @@ -17,16 +17,17 @@ import ShapePicture timeScrollGun :: Item timeScrollGun = defaultHeldItem + & itEffect . ieWhileAiming .~ TimeScrollEffect rewindGun :: Item rewindGun = defaultLeftItem - { _itInvColor = cyan - , _itUse = - defaultLeftUse + & itUse .~ + (defaultLeftUse & leftUse .~ LRewind --useRewindGun & equipEffect . eeSite .~ GoesOnWrist - } + ) + & itInvColor .~ cyan & itEffect . ieInv .~ RewindEffect & itType . iyBase .~ LEFT REWINDER & itUse . leftConsumption diff --git a/src/Dodge/Luse.hs b/src/Dodge/Luse.hs index 86c1de585..0cb214444 100644 --- a/src/Dodge/Luse.hs +++ b/src/Dodge/Luse.hs @@ -3,7 +3,7 @@ module Dodge.Luse where import Dodge.Base import Dodge.Creature.Action import Dodge.Data.World -import MaybeHelp +--import MaybeHelp import Dodge.Default.Creature import Dodge.Item.Weapon.TriggerType import Geometry @@ -20,13 +20,14 @@ useL lu = case lu of LBoost -> boostSelfL 10 useRewindGun :: Item -> Creature -> World -> World -useRewindGun _ _ w = case w ^. cwTime . rewindWorlds of - [w'] -> w & cwTime . maybeWorld .~ Just' w' - (w' : ws) -> w - & cwTime . maybeWorld - .~ Just' w' - & cwTime . rewindWorlds .~ ws - _ -> w +useRewindGun _ _ w = w +--useRewindGun _ _ w = case w ^. cwTime . rewindWorlds of +-- [w'] -> w & cwTime . maybeWorld .~ Just' w' +-- (w' : ws) -> w +-- & cwTime . maybeWorld +-- .~ Just' w' +-- & cwTime . rewindWorlds .~ ws +-- _ -> w -- be careful changing this around; potential problems include updating the -- creature but using the old crInvSel value diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 93beb3b91..1a4fc1397 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -6,8 +6,9 @@ import Control.Lens import ShortShow testStringInit :: Universe -> [String] -testStringInit u = [ - shortShow $ u ^?! uvWorld . cWorld . creatures . ix 0 . crPos +testStringInit u = [show $ u ^. uvWorld . scrollAmount + , show $ u ^. uvWorld . previousScrollAmount + , shortShow $ u ^?! uvWorld . cWorld . creatures . ix 0 . crPos ] -- [ show $ u ^? uvWorld . hammers . ix DoubleMouseHam -- , show $ u ^? uvWorld . cWorld . creatures . ix 0 . crLeftInvSel . _Just diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index a52165dce..37b3178cd 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -6,6 +6,7 @@ Description : Simulation update -} module Dodge.Update (updateUniverse) where +import StrictHelp import Color --import Dodge.Zone @@ -56,14 +57,14 @@ import Dodge.Zoning.Creature import Geometry import qualified IntMapHelp as IM import LensHelp -import MaybeHelp +--import MaybeHelp import SDL import Sound.Data {- For most menus the only way to change the world is using event handling. -} updateUniverse :: Universe -> Universe updateUniverse u - | isblocking = u + | concurrentblocking = u | otherwise = case _uvScreenLayers u of (OptionScreen{_scOptionFlag = GameOverOptions} : _) -> u & uvWorld @@ -75,21 +76,63 @@ updateUniverse u . updateClouds ) (_ : _) -> u - [] -> functionalUpdate u + [] -> functionalUpdate'' u where - isblocking = case u ^. uvConcEffects of + concurrentblocking = case u ^. uvConcEffects of BlockingConcEffect{} -> True _ -> False +functionalUpdate'' :: Universe -> Universe +functionalUpdate'' = advanceScrollAmount . functionalUpdate' + +functionalUpdate' :: Universe -> Universe +functionalUpdate' u = case u ^. uvWorld . timeFlow of + NormalTimeFlow -> functionalUpdate u + ScrollTimeFlow smoothing -> over uvWorld (doTimeScroll smoothing) u + _ -> u + +timeScrollAmount :: World -> Int +timeScrollAmount w + | x == 0 = 0 + | x > 0 && y > 0 = x * y + | x < 0 && y < 0 = negate (x * y) + | otherwise = x + where + x = w ^. scrollAmount + y = w ^. previousScrollAmount + +doTimeScroll :: Int -> World -> World +doTimeScroll smoothing w = case timeScrollAmount w of + x | x > 1 -> (foldr ($) w $ replicate x scrollTimeBack) & timeFlow . scrollSmoothing .~ 20 + x | x > 0 -> foldr ($) w $ replicate x scrollTimeBack + x | x < (-1) -> (foldr ($) w $ replicate x scrollTimeForward) & timeFlow . scrollSmoothing .~ negate 20 + x | x < 0 -> foldr ($) w $ replicate (negate x) scrollTimeForward + _ | smoothing > 0 -> scrollTimeBack w & timeFlow . scrollSmoothing -~ 1 + _ | smoothing < 0 -> scrollTimeForward w & timeFlow . scrollSmoothing +~ 1 + _ -> w + +scrollTimeBack :: World -> World +scrollTimeBack w = case w ^? cwTime . pastWorlds . _head of + Nothing -> w + Just cw -> w & cwTime . pastWorlds %~ tail + & cwTime . futureWorlds .:~ _cWorld w + & cWorld .~ cw + +scrollTimeForward :: World -> World +scrollTimeForward w = case w ^? cwTime . futureWorlds . _head of + Nothing -> w + Just cw -> w & cwTime . futureWorlds %~ tail + & cwTime . pastWorlds .:~ _cWorld w + & cWorld .~ cw + -- | The update step. functionalUpdate :: Universe -> Universe -functionalUpdate w = - checkEndGame +functionalUpdate w = checkEndGame -- . updateRandGen . over uvWorld (mouseButtons . each .~ True) -- to determine if the mouse button is held . over uvWorld (cwTime . worldClock +~ 1) . over uvWorld updateWorldSelect - . over uvWorld doRewind +-- . over uvWorld doRewind -- . over uvWorld (hammers . each %~ moveHammerUp) -- . over (uvWorld . hammers . each) moveHammerUp -- . over uvWorld (hammers %~ fmap moveHammerUp) @@ -139,7 +182,16 @@ functionalUpdate w = . over uvWorld updateTerminal . over uvWorld updateRBList . updateBounds -- where should this go? next to update camera? - $ over uvWorld updateCloseObjects w + . over uvWorld updateCloseObjects + $ over uvWorld updatePastWorlds w + +advanceScrollAmount :: Universe -> Universe +advanceScrollAmount u = u + & uvWorld . previousScrollAmount .~ _scrollAmount (_uvWorld u) + & uvWorld . scrollAmount .~ 0 + +updatePastWorlds :: World -> World +updatePastWorlds w = w & cwTime . pastWorlds %~ (forceFoldable . take 100 . (_cWorld w :)) moveHammersUp :: Universe -> Universe --moveHammersUp = uvWorld . hammers .~ M.empty @@ -230,12 +282,12 @@ setOldPos cr = --updateRandGen :: World -> World --updateRandGen = randGen %~ (snd . (uniform :: StdGen -> (Int,StdGen))) -doRewind :: World -> World -doRewind w = case w ^. cwTime . maybeWorld of - Just' cw -> - w & cWorld .~ cw - & timeFlow .~ RewindingLastFrame - Nothing' -> w & timeFlow .~ NormalTimeFlow +--doRewind :: World -> World +--doRewind w = case w ^. cwTime . maybeWorld of +-- Just' cw -> +-- w & cWorld .~ cw +-- & timeFlow .~ RewindingLastFrame +-- Nothing' -> w & timeFlow .~ NormalTimeFlow zoneCreatures :: World -> World zoneCreatures w =