Move most wheelEvent functionality into update function

2022-10-27 23:29:49 +01:00
parent c6b500c219
commit 5f6bd43599
3 changed files with 171 additions and 6 deletions
@@ -92,15 +92,10 @@ handleResizeEvent sev u =
 handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe
 handleMouseWheelEvent mwev w = case _uvScreenLayers w of
    [] -> case mouseWheelEventPos mwev of
-        V2 _ y -> Just $ w & uvWorld %~ wheelEvent (fromIntegral y)
+        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
@@ -9,9 +9,11 @@ module Dodge.Update (updateUniverse) where
 import Color
 --import Dodge.Zone

+import Dodge.Update.Scroll
 import Control.Applicative
 import Data.List
 import qualified Data.Map.Strict as M
+import qualified Data.Set as S
 import Data.Maybe
 import Dodge.Base
 import Dodge.Beam
@@ -61,6 +63,7 @@ import LensHelp
 import SDL
 import Sound.Data
 import StrictHelp
+import qualified Data.Text as T

 updateUniverse :: Universe -> Universe
 updateUniverse = updateUniverseLast . updateUniverseFirst
@@ -198,8 +201,15 @@ functionalUpdate w =
        . over uvWorld updateRBList
        . updateBounds -- where should this go? next to update camera?
        . over uvWorld updateCloseObjects
+        . over uvWorld updateWheelEvents
        $ over uvWorld updatePastWorlds w

+updateWheelEvents :: World -> World
+updateWheelEvents w = foldr ($) w (replicate (abs y) (updateWheelEvent (signum y)))
+  where
+    y = w ^. scrollAmount
+
+
 advanceScrollAmount :: Universe -> Universe
 advanceScrollAmount u =
    u
@@ -0,0 +1,160 @@
+module Dodge.Update.Scroll where
+import Dodge.Terminal
+import Dodge.Tweak
+import Dodge.Combine
+import Dodge.Event.Keyboard
+import Control.Applicative
+import Data.List
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Maybe
+import Dodge.Base
+import Dodge.Beam
+import Dodge.InputFocus
+import Dodge.Bullet
+import Dodge.HeldScroll
+import Dodge.CrGroupUpdate
+import Dodge.Creature.Update
+import Dodge.CullBox
+import Dodge.Data.Universe
+import Dodge.Distortion
+import Dodge.DrWdWd
+import Dodge.EnergyBall
+import Dodge.Flame
+import Dodge.Flare
+import Dodge.Hammer
+import Dodge.Inventory
+import Dodge.Item.Location
+import Dodge.Laser.Update
+import Dodge.LightSource.Update
+import Dodge.LinearShockwave.Update
+import Dodge.Machine.Update
+import Dodge.Magnet.Update
+import Dodge.Menu
+import Dodge.ModificationEffect
+import Dodge.PosEvent
+import Dodge.PressPlate
+import Dodge.Projectile.Update
+import Dodge.Prop.Update
+import Dodge.RadarBlip
+import Dodge.RadarSweep
+import Dodge.Shockwave.Update
+import Dodge.SoundLogic
+import Dodge.Spark
+import Dodge.Tesla.Arc
+import Dodge.TmTm
+import Dodge.TractorBeam.Update
+import Dodge.Update.Camera
+import Dodge.Update.Cloud
+import Dodge.Update.WallDamage
+import Dodge.WallCreatureCollisions
+import Dodge.WorldEffect
+import Dodge.Zoning.Cloud
+import Dodge.Zoning.Creature
+import Geometry
+import qualified IntMapHelp as IM
+import LensHelp
+--import MaybeHelp
+import SDL
+import Sound.Data
+import StrictHelp
+import qualified Data.Text as T
+
+updateWheelEvent :: Int -> World -> World
+updateWheelEvent yi w = case w ^. cWorld . hud . hudElement of
+    DisplayCarte
+        | rbDown -> w & cWorld . hud . carteZoom %~ min 0.75 . max 0.05 . ((1 + y * 0.1) *)
+        | otherwise -> w & cWorld . selLocation %~ (`mod` numLocs) . (+ yi)
+    DisplayInventory NoSubInventory
+        -- functions that modify the inventory should be centralised so that
+        -- this lock can be sensibly applied, perhaps
+        | _crInvLock (_creatures (_cWorld w) IM.! _yourID (_cWorld w)) -> w
+        | rbDown -> case (yourItem w ^? _Just . itUse . heldScroll, _rbOptions w) of
+            (_, EquipOptions{}) -> scrollRBOption y w
+            (Nothing, _) -> closeObjScrollDir y w
+            (Just f, _) -> doHeldScroll f y (you w) w
+        | lbDown -> w & cWorld . cwCam . cwcZoom +~ y
+        | invKeyDown -> changeSwapInvSel yi w
+        | otherwise -> stopSoundFrom (CrReloadSound 0) $ changeAugInvSel yi w
+    DisplayInventory (TweakInventory mi)
+        | invKeyDown && rbDown -> w & moveTweakSel yi
+        | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvSel yi w
+        | rbDown -> w & changeTweakParam mi yi
+        | otherwise -> w & moveTweakSel yi
+    DisplayInventory CombineInventory{} ->
+        w
+            & cWorld . hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
+    DisplayInventory (DisplayTerminal tmid)
+        | rbDown && inTermFocus w ->
+            guardDisconnectedID tmid w $
+                w
+                    & cWorld . terminals . ix tmid %~ updatetermsubsel
+        | inTermFocus w ->
+            w
+                & cWorld . terminals . ix tmid %~ updatetermsel
+    _ -> w
+  where
+    updatetermsel tm = case tm ^? tmInput . tiSel of
+        Nothing -> tm & tmInput . tiSel .~ (0, 0)
+        Just (i, _) ->
+            let newi = (i - yi) `mod` length (scrollCommands tm)
+             in tm & setInput newi 0 w
+    updatetermsubsel tm = case tm ^? tmInput . tiSel of
+        Nothing -> tm & tmInput . tiSel .~ (0, 0)
+        Just (i, j) ->
+            let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
+             in tm & setInput i newj w
+    setInput i j w' tm =
+        tm
+            & tmInput . tiSel .~ (i, j)
+            & tmInput . tiText .~ T.pack (_tcString tc ++ " " ++ arg)
+      where
+        tc = scrollCommands tm !! i
+        arg = getArguments' tc tm w' !! j
+    numcombs = length $ combineItemListYou w
+    y = fromIntegral yi
+    numLocs = (fst . IM.findMax $ _seenLocations (_cWorld w)) + 1
+    rbDown = ButtonRight `M.member` _mouseButtons w
+    lbDown = ButtonLeft `M.member` _mouseButtons w
+    invKeyDown = ScancodeCapsLock `S.member` _keys w
+
+scrollRBOption :: Float -> World -> World
+scrollRBOption y w
+    | y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w)) -1) . (+ 1))
+    | y > 0 = w & rbOptions . opSel %~ (max 0 . subtract 1)
+    | otherwise = w
+
+moveTweakSel :: Int -> World -> World
+moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of
+    Just l -> w & cWorld . hud . hudElement . subInventory . tweakInvSel . _Just %~ (`mod` length l) . subtract i
+    _ -> w
+
+changeTweakParam :: Maybe Int -> Int -> World -> World
+changeTweakParam mi i w = fromMaybe w $ do
+    paramid <- mi
+    params <- yourItem w ^? _Just . itTweaks . tweakParams . ix paramid
+    let x = (_tweakVal params + i) `mod` _tweakMax params
+    return $
+        w & cWorld . creatures . ix (_yourID (_cWorld w)) . crInv . ix (crSel (you w))
+            %~ ( (itTweaks . tweakParams . ix paramid . tweakVal .~ x)
+                    . doTweak (_tweakType params) x
+               )
+scrollCommands :: Terminal -> [TerminalCommand]
+scrollCommands = (nullCommand :) . _tmScrollCommands
+
+getArguments' :: TerminalCommand -> Terminal -> World -> [String]
+getArguments' tc tm = ("" :) . getArguments tc tm
+
+nullCommand :: TerminalCommand
+nullCommand =
+    TerminalCommand
+        { _tcString = ""
+        , _tcAlias = []
+        , _tcHelp = ""
+        , _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
+        }
+
+getArguments :: TerminalCommand -> Terminal -> World -> [String]
+getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
+    NoArguments{} -> []
+    OneArgument _ m -> M.keys m