From 82e2a5a23460f1249c115277b02306c4120d1717 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 28 Oct 2022 23:13:36 +0100 Subject: [PATCH] Refactor updates --- appDodge/Main.hs | 1 - src/Dodge/Base/You.hs | 3 ++ src/Dodge/Data/Universe.hs | 1 - src/Dodge/Render/InfoBox.hs | 16 ++++--- src/Dodge/Render/List.hs | 12 +++--- src/Dodge/Render/ShapePicture.hs | 17 ++++---- src/Dodge/Update.hs | 73 +++++++++++++++----------------- src/Dodge/Update/Camera.hs | 4 +- 8 files changed, 64 insertions(+), 63 deletions(-) diff --git a/appDodge/Main.hs b/appDodge/Main.hs index d7dbd0c54..1c5451faa 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -89,7 +89,6 @@ firstWorldLoad theConfig = do , _uvScreenLayers = [splashMenu] , _uvIOEffects = return , _uvTestString = testStringInit - , _quickSave = Nothing , _uvConcEffects = NoConcEffect , _uvCanContinue = cancontinue , _uvMSeed = mseed diff --git a/src/Dodge/Base/You.hs b/src/Dodge/Base/You.hs index c8421b147..a65dce00c 100644 --- a/src/Dodge/Base/You.hs +++ b/src/Dodge/Base/You.hs @@ -7,6 +7,9 @@ import Control.Lens you :: World -> Creature you w = w ^?! cWorld . lWorld . creatures . ix 0 +youc :: CWorld -> Creature +youc w = w ^?! lWorld . creatures . ix 0 + yourItem :: World -> Maybe Item yourItem w = _crInv (you w) IM.!? crSel (you w) diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 525cef7f7..c9657cad3 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -26,7 +26,6 @@ data Universe = Universe { _uvWorld :: World , _preloadData :: PreloadData , _uvScreenLayers :: [ScreenLayer] - , _quickSave :: Maybe World , _uvIOEffects :: Universe -> IO Universe , _uvConcEffects :: ConcEffect , _uvConfig :: Configuration diff --git a/src/Dodge/Render/InfoBox.hs b/src/Dodge/Render/InfoBox.hs index 497d9a503..f3448d5f3 100644 --- a/src/Dodge/Render/InfoBox.hs +++ b/src/Dodge/Render/InfoBox.hs @@ -1,24 +1,26 @@ -module Dodge.Render.InfoBox where +module Dodge.Render.InfoBox + ( renderInfoListAt + , renderInfoListsAt + ) where -import Control.Lens import Dodge.Base -import Dodge.Data.Universe +import Dodge.Data.CamPos +import Dodge.Data.Config import Dodge.Render.Connectors import Dodge.Render.List import Geometry import Picture -renderInfoListAt :: Float -> Float -> Configuration -> World -> (Point2, [String]) -> Picture -renderInfoListAt x y cfig w (p, ss) = +renderInfoListAt :: Float -> Float -> Configuration -> CamPos -> (Point2, [String]) -> Picture +renderInfoListAt x y cfig cam (p, ss) = renderListAt x y cfig (zip ss (repeat white)) <> winScale cfig (color white $ lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) <> listCursorNSW x y cfig 0 white 19 (length ss) where hw = halfWidth cfig hh = halfHeight cfig - cam = w ^. cWorld . lWorld . camPos -renderInfoListsAt :: Float -> Float -> Configuration -> World -> [(Point2, [String])] -> Picture +renderInfoListsAt :: Float -> Float -> Configuration -> CamPos -> [(Point2, [String])] -> Picture renderInfoListsAt x y cfig w = fst . foldr f (mempty, 0) where diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 862f5a866..5fe492ca0 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -4,7 +4,7 @@ import Data.Foldable import Data.Maybe import Dodge.Base.WinScale import Dodge.Base.Window -import Dodge.Data.Universe +import Dodge.Data.Config import Geometry import Picture @@ -19,7 +19,8 @@ listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig -- displays a cursor that should match up to list text pictures -- the width of a character appears to be 9(?!) -- this is probably because it is 8 pixels plus one for the border -listCursorChooseBorder :: [Bool] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture +listCursorChooseBorder :: + [Bool] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize = winScale cfig . translate @@ -66,12 +67,11 @@ fillScreenText cfig str = . centerText $ str where - wscale = hw*0.02/fromIntegral (length str) - hscale = hh*0.01 + wscale = hw * 0.02 / fromIntegral (length str) + hscale = hh * 0.01 hw = halfWidth cfig hh = halfHeight cfig - fillWidthText :: Configuration -> String -> Picture fillWidthText cfig str = winScale cfig @@ -79,7 +79,7 @@ fillWidthText cfig str = . centerText $ str where - thescale = hw*0.02/fromIntegral (length str) + thescale = hw * 0.02 / fromIntegral (length str) hw = halfWidth cfig listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 497dfcfb7..a85a677a8 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -167,7 +167,7 @@ debugDraw' cfig w bl = case bl of Close_shape_culling -> mempty Bound_box_screen -> mempty Show_ms_frame -> mempty - View_boundaries -> viewBoundaries w + View_boundaries -> viewBoundaries (w ^. cWorld) Show_bound_box -> drawBoundingBox w Show_wall_search_rays -> drawWallSearchRays w Show_dda_test -> drawDDATest w @@ -176,7 +176,7 @@ debugDraw' cfig w bl = case bl of Inspect_wall -> drawInspectWalls w Cr_awareness -> drawCreatureDisplayTexts w Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds w - Cr_status -> drawCrInfo cfig w + Cr_status -> drawCrInfo cfig (w ^. cWorld . lWorld) Mouse_position -> drawMousePosition cfig w Walls_info -> drawWlIDs cfig w Pathing -> drawPathing cfig w @@ -436,22 +436,23 @@ crDisplayInfo cfig cam cr fpreShow :: (Show a, Functor f) => String -> f a -> f String fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show) -drawCrInfo :: Configuration -> World -> Picture +drawCrInfo :: Configuration -> LWorld -> Picture drawCrInfo cfig w = setLayer FixedCoordLayer $ - renderInfoListsAt (2 * hw - 400) 0 cfig w $ - mapMaybe (crDisplayInfo cfig (w ^. cWorld . lWorld . camPos)) $ IM.elems $ w ^. cWorld . lWorld . creatures + renderInfoListsAt (2 * hw - 400) 0 cfig cam $ + mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. creatures where + cam = w ^. camPos hw = halfWidth cfig -viewBoundaries :: World -> Picture +viewBoundaries :: CWorld -> Picture viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs) <> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w) where - p = _crPos $ you w - grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen (_cWorld w)) + p = _crPos $ youc w + grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w) viewClipBounds :: Configuration -> World -> Picture viewClipBounds cfig w diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index cb232e212..e9fefe170 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -348,34 +348,46 @@ 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 = foldl' (flip fup) w (fim w) + updateCreatureGroups :: World -> World updateCreatureGroups w = w & cWorld . lWorld . creatureGroups %~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp) +updateObjMapMaybe + :: (([a] -> Identity [a]) -> LWorld -> Identity LWorld) + -> (a -> Maybe a) + -> World + -> World +updateObjMapMaybe p f = cWorld . lWorld . p %~ mapMaybe f + +updateObjCatMaybes + :: ALens' LWorld [a] + -> (World -> a -> (World, Maybe a)) + -> World + -> World +updateObjCatMaybes p f w = w' & cWorld . lWorld . p #~ catMaybes newxs + where + (w', newxs) = mapAccumR f w $ w ^# cWorld . lWorld . p + updateDistortions :: World -> World -updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion +updateDistortions = updateObjMapMaybe distortions updateDistortion +--updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion updateLightSources :: World -> World -updateLightSources = cWorld . lWorld . tempLightSources %~ f - where - f = mapMaybe (\b -> updateTempLightSource (_tlsUpdate b) b) - -updateRadarBlips :: World -> World -updateRadarBlips = cWorld . lWorld . radarBlips %~ mapMaybe updateRadarBlip - -updateFlares :: World -> World -updateFlares = cWorld . lWorld . flares %~ mapMaybe updateFlare +updateLightSources = updateObjMapMaybe tempLightSources (\b -> updateTempLightSource (_tlsUpdate b) b) updateTeslaArcs :: World -> World -updateTeslaArcs w = w' & cWorld . lWorld . teslaArcs .~ catMaybes newtas - where - (w', newtas) = mapAccumR moveTeslaArc w $ w ^. cWorld . lWorld . teslaArcs +updateTeslaArcs = updateObjCatMaybes teslaArcs moveTeslaArc + +updateRadarBlips :: World -> World +updateRadarBlips = updateObjMapMaybe radarBlips updateRadarBlip + +updateFlares :: World -> World +updateFlares = updateObjMapMaybe flares updateFlare updateTractorBeams :: World -> World -updateTractorBeams w = w' & cWorld . lWorld . tractorBeams .~ catMaybes newtas - where - (w', newtas) = mapAccumR updateTractorBeam w $ w ^. cWorld . lWorld . tractorBeams +updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam {- Apply internal particle updates, delete 'Nothing's. -} updateBullets :: World -> World @@ -384,34 +396,22 @@ updateBullets w = updateInstantBullets $ set (cWorld . lWorld . bullets) (catMay (w', ps) = mapAccumR updateBullet w $ w ^. cWorld . lWorld . bullets updateShockwaves :: World -> World -updateShockwaves w = w' & cWorld . lWorld . shockwaves .~ catMaybes newflames - where - (w', newflames) = mapAccumR updateShockwave w $ w ^. cWorld . lWorld . shockwaves +updateShockwaves = updateObjCatMaybes shockwaves updateShockwave updateFlames :: World -> World -updateFlames w = w' & cWorld . lWorld . flames .~ catMaybes newflames - where - (w', newflames) = mapAccumR moveFlame w $ w ^. cWorld . lWorld . flames +updateFlames = updateObjCatMaybes flames moveFlame updateEnergyBalls :: World -> World -updateEnergyBalls w = w' & cWorld . lWorld . energyBalls .~ catMaybes newebs - where - (w', newebs) = mapAccumR moveEnergyBall w $ w ^. cWorld . lWorld . energyBalls +updateEnergyBalls = updateObjCatMaybes energyBalls moveEnergyBall updateRadarSweeps :: World -> World -updateRadarSweeps w = w' & cWorld . lWorld . radarSweeps .~ catMaybes newradarSweeps - where - (w', newradarSweeps) = mapAccumR updateRadarSweep w $ w ^. cWorld . lWorld . radarSweeps +updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep updateSparks :: World -> World -updateSparks w = w' & cWorld . lWorld . sparks .~ catMaybes newsparks - where - (w', newsparks) = mapAccumR moveSpark w $ w ^. cWorld . lWorld . sparks +updateSparks = updateObjCatMaybes sparks moveSpark updatePosEvents :: World -> World -updatePosEvents w = w' & cWorld . lWorld . posEvents .~ catMaybes newposEvents - where - (w', newposEvents) = mapAccumR updatePosEvent w $ w ^. cWorld . lWorld . posEvents +updatePosEvents = updateObjCatMaybes posEvents updatePosEvent {- Apply internal particle updates, delete 'Nothing's. -} --updateParticles :: World -> World @@ -562,10 +562,7 @@ mvGust _ gu & guTime -~ 1 updateClouds :: World -> World -updateClouds w = w' & cWorld . lWorld . clouds .~ catMaybes mclouds - where - -- cls = _clouds w - (w', mclouds) = mapAccumR updateCloud w (w ^. cWorld . lWorld . clouds) +updateClouds = updateObjCatMaybes clouds updateCloud cloudEffect :: Cloud -> World -> World cloudEffect cl = case _clType cl of diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 479196a36..4c98dae8e 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -254,10 +254,10 @@ extendedViewPoints p grs = extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p) addDir a = p +.+ unitVectorAtAngle a -farWallPoints :: Point2 -> World -> [Point2] +farWallPoints :: Point2 -> CWorld -> [Point2] farWallPoints p w = concatMap _grViewpoints grs ++ extendedViewPoints p grs where - grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen (_cWorld w)) + grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w) maxViewDistance :: Float maxViewDistance = 800