justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
justin
2024-10-22 11:22:38 +01:00
parent 65f05b93f8
commit 9e3d8ae6b0
8 changed files with 425 additions and 407 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Update.hs
+77 -61
View File
@@ -6,41 +6,32 @@ Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
import Dodge.Inventory
import Dodge.ListDisplayParams
import Dodge.SelectionSections
import Data.Monoid
import NewInt
import Control.Monad
import Dodge.Update.Input.InGame
import Dodge.Update.Input.ScreenLayer
import Dodge.Debug
import Dodge.SmoothScroll
import Color
--import Control.Applicative
import Control.Monad
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Dodge.Base
--import Dodge.Beam
import Dodge.Bullet
import Dodge.CrGroupUpdate
import Dodge.Creature.Update
--import Dodge.Data.SelectionList
import Dodge.Data.Universe
import Dodge.Debug
import Dodge.DisplayInventory
import Dodge.Distortion
import Dodge.DrWdWd
import Dodge.EnergyBall
import Dodge.Flame
import Dodge.Inventory
import Dodge.Item.Location
import Dodge.Laser.Update
import Dodge.LightSource.Update
import Dodge.LinearShockwave.Update
import Dodge.ListDisplayParams
import Dodge.Machine.Update
import Dodge.Magnet.Update
import Dodge.Menu
--import Dodge.Menu.Option
import Dodge.ModificationEffect
import Dodge.PosEvent
import Dodge.PressPlate
@@ -49,7 +40,9 @@ import Dodge.Prop.Update
import Dodge.RadarBlip
import Dodge.RadarSweep
import Dodge.ScrollValue
import Dodge.SelectionSections
import Dodge.Shockwave.Update
import Dodge.SmoothScroll
import Dodge.SoundLogic
import Dodge.Spark
import Dodge.Tesla.Arc
@@ -57,6 +50,8 @@ import Dodge.TmTm
import Dodge.TractorBeam.Update
import Dodge.Update.Camera
import Dodge.Update.Cloud
import Dodge.Update.Input.InGame
import Dodge.Update.Input.ScreenLayer
import Dodge.Update.Scroll
import Dodge.Update.WallDamage
import Dodge.WallCreatureCollisions
@@ -66,6 +61,7 @@ import Dodge.Zoning.Creature
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import NewInt
import SDL
import Sound.Data
import StrictHelp
@@ -92,22 +88,23 @@ updateUniverseFirst u =
updateDebugMessageOffset :: Universe -> Universe
updateDebugMessageOffset u
| SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys)
= u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
| SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
| otherwise = u
setClickWorldPos :: Universe -> M.Map MouseButton Point2
setClickWorldPos u = fmap
(const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
(M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
setClickWorldPos u =
fmap
(const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
(M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
updateWorldEventFlags :: Universe -> Universe
updateWorldEventFlags u =
(uvWorld . worldEventFlags .~ mempty)
-- for now update inventory positioning every tick
. updateInventoryPositioning
-- the question is how often to update the close objects section, and if
-- this can be done independently of the other sections
(uvWorld . worldEventFlags .~ mempty)
-- for now update inventory positioning every tick
. updateInventoryPositioning
-- the question is how often to update the close objects section, and if
-- this can be done independently of the other sections
$ foldr updateWorldEventFlag u (u ^. uvWorld . worldEventFlags)
updateWorldEventFlag :: WorldEventFlag -> Universe -> Universe
@@ -136,8 +133,10 @@ updateUniverseLast 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))
& uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
& uvWorld . input . heldPos
%~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
& uvWorld . input . heldWorldPos
%~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
where
mp = u ^. uvWorld . input . mousePos
mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
@@ -165,10 +164,10 @@ timeFlowUpdate :: Universe -> Universe
timeFlowUpdate u = case u ^. uvWorld . timeFlow of
NormalTimeFlow -> functionalUpdate u
ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u
CameraScrollTimeFlow smoothing _ _
| SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys)
-> over uvWorld (doTimeScroll smoothing) u
CameraScrollTimeFlow {} -> u
CameraScrollTimeFlow smoothing _ _
| SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) ->
over uvWorld (doTimeScroll smoothing) u
CameraScrollTimeFlow{} -> u
RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
DeathTime{} -> u
@@ -214,8 +213,9 @@ scrollTimeBack w = case w ^? pastWorlds . _head of
mupdateitem x = fromMaybe id $ do
i <- w ^? timeFlow . scrollItemID . unNInt
let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
return $ (pointituse . leftConsumption . wpCharge .~ (x -1))
. ( pointituse . leftHammer .~ HammerDown)
return $
(pointituse . leftConsumption . wpCharge .~ (x -1))
. (pointituse . leftHammer .~ HammerDown)
scrollTimeForward :: World -> World
scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
@@ -225,7 +225,7 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
& pastWorlds .:~ (w ^. cWorld . lWorld)
& cWorld . lWorld .~ lw
& timeFlow . reverseAmount .~ ramount
& mupdateitem
& mupdateitem
where
ramount = (w ^?! timeFlow . reverseAmount) + 1
mupdateitem = fromMaybe id $ do
@@ -254,7 +254,7 @@ functionalUpdate u =
. over uvWorld updateEnergyBalls
. over uvWorld updateBullets
. over uvWorld updateRadarBlips
-- . over uvWorld updateBeams
-- . over uvWorld updateBeams
. over uvWorld updateLasers
. over uvWorld updateTeslaArcs
. over uvWorld updateTractorBeams
@@ -278,7 +278,7 @@ functionalUpdate u =
. over uvWorld updateRBList
. over uvWorld updateCloseObjects
. over uvWorld updateWheelEvents
. over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
. over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
. over uvWorld (updateMouseOverInventory (u ^. uvConfig))
. over uvWorld zoneClouds
. over uvWorld zoneCreatures
@@ -308,26 +308,34 @@ updateMouseInventorySelection' sss cfig w
return $ w & hud . hudElement . subInventory . nsSelected .~ MouseInvSelect ysel Nothing
Just p -> w & hud . hudElement . subInventory . nsSelected %~ startdrag p
| leftclickheld = case w ^? hud . hudElement . subInventory . nsSelected of
Just MouseInvSelect{} -> w
& hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
Just MouseInvSelect{} ->
w
& hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
Just (MouseInvChosen ssel esel)
| maybe False (<ssel) $ inverseSelBoundaryUp cfig ldp sss mpos -> w
& shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
| maybe False (< ssel) $ inverseSelBoundaryUp cfig ldp sss mpos ->
w
& shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
Just (MouseInvChosen ssel esel)
| maybe False (>esel) $ inverseSelBoundaryDown cfig ldp sss mpos -> w
& shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
| maybe False (> esel) $ inverseSelBoundaryDown cfig ldp sss mpos ->
w
& shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
Just (MouseInvChosen{}) -> w
_ -> w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
_ ->
w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
| otherwise = case w ^? hud . hudElement . subInventory . nsSelected of
Just (MouseInvSelect ssel (Just esel)) -> w
& hud . hudElement . subInventory . nsSelected .~ MouseInvChosen (min ssel esel)
(max ssel esel)
Just (MouseInvSelect _ Nothing) -> w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
Just (MouseInvSelect ssel (Just esel)) ->
w
& hud . hudElement . subInventory . nsSelected
.~ MouseInvChosen
(min ssel esel)
(max ssel esel)
Just (MouseInvSelect _ Nothing) ->
w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
_ -> w
where
startdrag p (MouseInvChosen s e) | s <= p && p <= e = MouseInvChosen s e
startdrag p (MouseInvChosen s e) | s <= p && p <= e = MouseInvChosen s e
startdrag p _ = MouseInvChosen p p
leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0 && nobuttonright
leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons) && nobuttonright
@@ -337,21 +345,23 @@ updateMouseInventorySelection' sss cfig w
msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
mysel = inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
shiftInvItemsUp :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
shiftInvItemsUp (_,i) (_,j) Just{} w = w
& flip (foldl' f) [i..j]
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
shiftInvItemsUp :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
shiftInvItemsUp (_, i) (_, j) Just{} w =
w
& flip (foldl' f) [i .. j]
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
where
f w' i' = swapInvItems g i' w'
g i' m = fmap fst $ IM.cycleLT i' m
shiftInvItemsUp _ _ Nothing w = w
shiftInvItemsDown :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
shiftInvItemsDown (_,i) (_,j) Just{} w = w
& flip (foldl' f) (reverse [i..j])
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
shiftInvItemsDown :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
shiftInvItemsDown (_, i) (_, j) Just{} w =
w
& flip (foldl' f) (reverse [i .. j])
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
where
f w' i' = swapInvItems g i' w'
g i' m = fmap fst $ IM.cycleGT i' m
@@ -360,8 +370,9 @@ shiftInvItemsDown _ _ Nothing w = w
updateMouseOverInventory :: Configuration -> World -> World
updateMouseOverInventory cfig w = fromMaybe w $ do
sss <- w ^? hud . hudElement . diSections
return $ w & hud . hudElement . subInventory . nsMouseOver .~
inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
return $
w & hud . hudElement . subInventory . nsMouseOver
.~ inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
where
ldp = invDisplayParams w
@@ -380,6 +391,7 @@ advanceScrollAmount u =
updatePastWorlds :: World -> World
updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 600 . ((w ^. cWorld . lWorld) :))
doWorldEvents :: World -> World
@@ -462,10 +474,12 @@ updateCreatureSoundPositions w =
--updateIMr fim fup w = foldr (dbArg fup) w (fim w)
updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World
updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
--updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w
--updateIMl' fim fup w = foldl' (flip fup) w (fim w)
updateCreatureGroups :: World -> World
@@ -638,10 +652,12 @@ ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ w
updateSeenWalls :: World -> World
updateSeenWalls w = alaf Endo foldMap (markWallSeen . _wlID . snd) (allVisibleWalls w) w
--updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
markWallSeen :: Int -> World -> World
markWallSeen i = cWorld . seenWalls . at i ?~ ()
--markWallSeen :: World -> Int -> World
--markWallSeen w i = w & cWorld . seenWalls . at i ?~ ()