Refactor updates

appDodge/Main.hs

@@ -89,7 +89,6 @@ firstWorldLoad theConfig = do
             , _uvScreenLayers = [splashMenu]
             , _uvIOEffects = return
             , _uvTestString = testStringInit
-            , _quickSave = Nothing
             , _uvConcEffects = NoConcEffect
             , _uvCanContinue = cancontinue
             , _uvMSeed = mseed

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)
 

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

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

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

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

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

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