Work on mouse wheel scrolling

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 =