Work on mouse wheel scrolling

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
     _ -> []

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

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

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
+    , _ieWhileAiming :: ItInvEffect
-    , _ieOnStash :: ItInvEffect
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data ItInvEffect
     = NoInvEffect
     | RewindEffect
+    | TimeScrollEffect
     | EffectIfHeld ItInvEffect ItInvEffect
     | CreateHeldLight
     | CreateShieldWall

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)
 

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

src/Dodge/Default/Item/Effect.hs

@@ -8,6 +8,5 @@ defaultItEffect =
         { _ieInv = NoInvEffect
         , _ieOnInsert = NoInvEffect
         , _ieOnDrop = NoInvEffect
-        , _ieOnHeld = NoInvEffect
+        , _ieWhileAiming = NoInvEffect
-        , _ieOnStash = NoInvEffect
         }

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
         }

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

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
+doScrollTime _ _ w = w
-    | x > 0 = case _futureWorlds $ _cwTime w of
+--    | x > 0 = case _futureWorlds $ _cwTime w of
-        (w':ws) -> w -- & cWorld .~ w' 
+--        (w':ws) -> w -- & cWorld .~ w' 
-            -- & cwTime . futureWorlds %~ tail
+--            -- & cwTime . futureWorlds %~ tail
-            -- & cwTime . rewindWorlds .:~ _cWorld w
+--            -- & cwTime . rewindWorlds .:~ _cWorld w
-        _ -> w
+--        _ -> w
-    | otherwise = w
+--    | otherwise = w
 cycleSignum :: Float -> Seq a -> Seq a
 cycleSignum x
     | x > 0 = cycleL

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
+rewindEffect _ _ w = w
-    | Just invid == _crLeftInvSel cr =
+--rewindEffect itm cr w =
-        w & cwTime . rewindWorlds %~ (take maxcharge . (cw :))
+--    | Just invid == _crLeftInvSel cr =
-            & ptrWpCharge .~ length (w ^. cwTime . rewindWorlds)
+--        w & cwTime . rewindWorlds %~ (take maxcharge . (cw :))
-    | otherwise =
+--            & ptrWpCharge .~ length (w ^. cwTime . rewindWorlds)
-        w & cwTime . rewindWorlds .~ []
+--    | otherwise =
-            & ptrWpCharge .~ 0
+--        w & cwTime . rewindWorlds .~ []
-  where
+--            & ptrWpCharge .~ 0
-    invid = _ipInvID $ _itLocation itm
+--  where
-    ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge
+--    invid = _ipInvID $ _itLocation itm
-    maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge
+--    ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge
-    cw =
+--    maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge
-        _cWorld w
+--    cw =
+--        _cWorld w
 
 --resetAttachmentEffect :: Item -> Creature -> World -> World
 --resetAttachmentEffect itm cr w

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 .~
-        , _itUse =
+            (defaultLeftUse
-            defaultLeftUse
                 & leftUse .~ LRewind --useRewindGun
                 & equipEffect . eeSite .~ GoesOnWrist
-        }
+            )
+        & itInvColor .~ cyan
         & itEffect . ieInv .~ RewindEffect
         & itType . iyBase .~ LEFT REWINDER
         & itUse . leftConsumption

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
+useRewindGun _ _ w = w
-    [w'] -> w & cwTime . maybeWorld .~ Just' w'
+--useRewindGun _ _ w = case w ^. cwTime . rewindWorlds of
-    (w' : ws) -> w
+--    [w'] -> w & cwTime . maybeWorld .~ Just' w'
-            & cwTime . maybeWorld
+--    (w' : ws) -> w
-                .~ Just' w'
+--            & cwTime . maybeWorld
-            & cwTime . rewindWorlds .~ ws
+--                .~ Just' w'
-    _ -> w
+--            & cwTime . rewindWorlds .~ ws
+--    _ -> w
 
 -- be careful changing this around; potential problems include updating the
 -- creature but using the old crInvSel value

src/Dodge/TestString.hs

@@ -6,8 +6,9 @@ import Control.Lens
 import ShortShow
 
 testStringInit :: Universe -> [String]
-testStringInit u = [
+testStringInit u = [show $ u ^. uvWorld . scrollAmount
-    shortShow $ u ^?! uvWorld . cWorld . creatures . ix 0 . crPos
+    , 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

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 =
+functionalUpdate w = checkEndGame
-    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 :: World -> World
-doRewind w = case w ^. cwTime .  maybeWorld of
+--doRewind w = case w ^. cwTime .  maybeWorld of
-    Just' cw ->
+--    Just' cw ->
-        w & cWorld .~ cw
+--        w & cWorld .~ cw
-            & timeFlow .~ RewindingLastFrame
+--            & timeFlow .~ RewindingLastFrame
-    Nothing' -> w & timeFlow .~ NormalTimeFlow
+--    Nothing' -> w & timeFlow .~ NormalTimeFlow
 
 zoneCreatures :: World -> World
 zoneCreatures w =