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

Refactor updates

Browse Source
This commit is contained in:
justin
2022-10-28 23:13:36 +01:00
parent 14e2b5cf8f
commit 82e2a5a234
8 changed files with 64 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
-1
View File
@@ -89,7 +89,6 @@ firstWorldLoad theConfig = do
, _uvScreenLayers = [splashMenu] , _uvScreenLayers = [splashMenu]
, _uvIOEffects = return , _uvIOEffects = return
, _uvTestString = testStringInit , _uvTestString = testStringInit
, _quickSave = Nothing
, _uvConcEffects = NoConcEffect , _uvConcEffects = NoConcEffect
, _uvCanContinue = cancontinue , _uvCanContinue = cancontinue
, _uvMSeed = mseed , _uvMSeed = mseed
src/Dodge/Base/You.hs
+3
View File
@@ -7,6 +7,9 @@ import Control.Lens
you :: World -> Creature you :: World -> Creature
you w = w ^?! cWorld . lWorld . creatures . ix 0 you w = w ^?! cWorld . lWorld . creatures . ix 0
youc :: CWorld -> Creature
youc w = w ^?! lWorld . creatures . ix 0
yourItem :: World -> Maybe Item yourItem :: World -> Maybe Item
yourItem w = _crInv (you w) IM.!? crSel (you w) yourItem w = _crInv (you w) IM.!? crSel (you w)
src/Dodge/Data/Universe.hs
-1
View File
@@ -26,7 +26,6 @@ data Universe = Universe
{ _uvWorld :: World { _uvWorld :: World
, _preloadData :: PreloadData , _preloadData :: PreloadData
, _uvScreenLayers :: [ScreenLayer] , _uvScreenLayers :: [ScreenLayer]
, _quickSave :: Maybe World
, _uvIOEffects :: Universe -> IO Universe , _uvIOEffects :: Universe -> IO Universe
, _uvConcEffects :: ConcEffect , _uvConcEffects :: ConcEffect
, _uvConfig :: Configuration , _uvConfig :: Configuration
src/Dodge/Render/InfoBox.hs
+9 -7
View File
@@ -1,24 +1,26 @@
module Dodge.Render.InfoBox where module Dodge.Render.InfoBox
( renderInfoListAt
, renderInfoListsAt
) where
import Control.Lens
import Dodge.Base import Dodge.Base
import Dodge.Data.Universe import Dodge.Data.CamPos
import Dodge.Data.Config
import Dodge.Render.Connectors import Dodge.Render.Connectors
import Dodge.Render.List import Dodge.Render.List
import Geometry import Geometry
import Picture import Picture
renderInfoListAt :: Float -> Float -> Configuration -> World -> (Point2, [String]) -> Picture renderInfoListAt :: Float -> Float -> Configuration -> CamPos -> (Point2, [String]) -> Picture
renderInfoListAt x y cfig w (p, ss) = renderInfoListAt x y cfig cam (p, ss) =
renderListAt x y cfig (zip ss (repeat white)) renderListAt x y cfig (zip ss (repeat white))
<> winScale cfig (color white $ lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) <> winScale cfig (color white $ lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p))
<> listCursorNSW x y cfig 0 white 19 (length ss) <> listCursorNSW x y cfig 0 white 19 (length ss)
where where
hw = halfWidth cfig hw = halfWidth cfig
hh = halfHeight 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 = renderInfoListsAt x y cfig w =
fst . foldr f (mempty, 0) fst . foldr f (mempty, 0)
where where
src/Dodge/Render/List.hs
+3 -3
View File
@@ -4,7 +4,7 @@ import Data.Foldable
import Data.Maybe import Data.Maybe
import Dodge.Base.WinScale import Dodge.Base.WinScale
import Dodge.Base.Window import Dodge.Base.Window
import Dodge.Data.Universe import Dodge.Data.Config
import Geometry import Geometry
import Picture 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 -- displays a cursor that should match up to list text pictures
-- the width of a character appears to be 9(?!) -- the width of a character appears to be 9(?!)
-- this is probably because it is 8 pixels plus one for the border -- 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 = listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize =
winScale cfig winScale cfig
. translate . translate
@@ -71,7 +72,6 @@ fillScreenText cfig str =
hw = halfWidth cfig hw = halfWidth cfig
hh = halfHeight cfig hh = halfHeight cfig
fillWidthText :: Configuration -> String -> Picture fillWidthText :: Configuration -> String -> Picture
fillWidthText cfig str = fillWidthText cfig str =
winScale cfig winScale cfig
src/Dodge/Render/ShapePicture.hs
+9 -8
View File
@@ -167,7 +167,7 @@ debugDraw' cfig w bl = case bl of
Close_shape_culling -> mempty Close_shape_culling -> mempty
Bound_box_screen -> mempty Bound_box_screen -> mempty
Show_ms_frame -> mempty Show_ms_frame -> mempty
View_boundaries -> viewBoundaries w View_boundaries -> viewBoundaries (w ^. cWorld)
Show_bound_box -> drawBoundingBox w Show_bound_box -> drawBoundingBox w
Show_wall_search_rays -> drawWallSearchRays w Show_wall_search_rays -> drawWallSearchRays w
Show_dda_test -> drawDDATest w Show_dda_test -> drawDDATest w
@@ -176,7 +176,7 @@ debugDraw' cfig w bl = case bl of
Inspect_wall -> drawInspectWalls w Inspect_wall -> drawInspectWalls w
Cr_awareness -> drawCreatureDisplayTexts w Cr_awareness -> drawCreatureDisplayTexts w
Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds 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 Mouse_position -> drawMousePosition cfig w
Walls_info -> drawWlIDs cfig w Walls_info -> drawWlIDs cfig w
Pathing -> drawPathing 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 :: (Show a, Functor f) => String -> f a -> f String
fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show) fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
drawCrInfo :: Configuration -> World -> Picture drawCrInfo :: Configuration -> LWorld -> Picture
drawCrInfo cfig w = drawCrInfo cfig w =
setLayer FixedCoordLayer $ setLayer FixedCoordLayer $
renderInfoListsAt (2 * hw - 400) 0 cfig w $ renderInfoListsAt (2 * hw - 400) 0 cfig cam $
mapMaybe (crDisplayInfo cfig (w ^. cWorld . lWorld . camPos)) $ IM.elems $ w ^. cWorld . lWorld . creatures mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. creatures
where where
cam = w ^. camPos
hw = halfWidth cfig hw = halfWidth cfig
viewBoundaries :: World -> Picture viewBoundaries :: CWorld -> Picture
viewBoundaries w = viewBoundaries w =
setLayer DebugLayer $ setLayer DebugLayer $
color green (foldMap (polygonWire . _grBound) grs) color green (foldMap (polygonWire . _grBound) grs)
<> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w) <> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w)
where where
p = _crPos $ you w p = _crPos $ youc w
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen (_cWorld w)) grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w)
viewClipBounds :: Configuration -> World -> Picture viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w viewClipBounds cfig w
src/Dodge/Update.hs
+35 -38
View File
@@ -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' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
updateIMl' fim fup w = foldl' (flip fup) w (fim w) updateIMl' fim fup w = foldl' (flip fup) w (fim w)
updateCreatureGroups :: World -> World updateCreatureGroups :: World -> World
updateCreatureGroups w = updateCreatureGroups w =
w & cWorld . lWorld . creatureGroups w & cWorld . lWorld . creatureGroups
%~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp) %~ 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 :: World -> World
updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion updateDistortions = updateObjMapMaybe distortions updateDistortion
--updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion
updateLightSources :: World -> World updateLightSources :: World -> World
updateLightSources = cWorld . lWorld . tempLightSources %~ f updateLightSources = updateObjMapMaybe tempLightSources (\b -> updateTempLightSource (_tlsUpdate b) b)
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
updateTeslaArcs :: World -> World updateTeslaArcs :: World -> World
updateTeslaArcs w = w' & cWorld . lWorld . teslaArcs .~ catMaybes newtas updateTeslaArcs = updateObjCatMaybes teslaArcs moveTeslaArc
where
(w', newtas) = mapAccumR moveTeslaArc w $ w ^. cWorld . lWorld . teslaArcs updateRadarBlips :: World -> World
updateRadarBlips = updateObjMapMaybe radarBlips updateRadarBlip
updateFlares :: World -> World
updateFlares = updateObjMapMaybe flares updateFlare
updateTractorBeams :: World -> World updateTractorBeams :: World -> World
updateTractorBeams w = w' & cWorld . lWorld . tractorBeams .~ catMaybes newtas updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam
where
(w', newtas) = mapAccumR updateTractorBeam w $ w ^. cWorld . lWorld . tractorBeams
{- Apply internal particle updates, delete 'Nothing's. -} {- Apply internal particle updates, delete 'Nothing's. -}
updateBullets :: World -> World updateBullets :: World -> World
@@ -384,34 +396,22 @@ updateBullets w = updateInstantBullets $ set (cWorld . lWorld . bullets) (catMay
(w', ps) = mapAccumR updateBullet w $ w ^. cWorld . lWorld . bullets (w', ps) = mapAccumR updateBullet w $ w ^. cWorld . lWorld . bullets
updateShockwaves :: World -> World updateShockwaves :: World -> World
updateShockwaves w = w' & cWorld . lWorld . shockwaves .~ catMaybes newflames updateShockwaves = updateObjCatMaybes shockwaves updateShockwave
where
(w', newflames) = mapAccumR updateShockwave w $ w ^. cWorld . lWorld . shockwaves
updateFlames :: World -> World updateFlames :: World -> World
updateFlames w = w' & cWorld . lWorld . flames .~ catMaybes newflames updateFlames = updateObjCatMaybes flames moveFlame
where
(w', newflames) = mapAccumR moveFlame w $ w ^. cWorld . lWorld . flames
updateEnergyBalls :: World -> World updateEnergyBalls :: World -> World
updateEnergyBalls w = w' & cWorld . lWorld . energyBalls .~ catMaybes newebs updateEnergyBalls = updateObjCatMaybes energyBalls moveEnergyBall
where
(w', newebs) = mapAccumR moveEnergyBall w $ w ^. cWorld . lWorld . energyBalls
updateRadarSweeps :: World -> World updateRadarSweeps :: World -> World
updateRadarSweeps w = w' & cWorld . lWorld . radarSweeps .~ catMaybes newradarSweeps updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep
where
(w', newradarSweeps) = mapAccumR updateRadarSweep w $ w ^. cWorld . lWorld . radarSweeps
updateSparks :: World -> World updateSparks :: World -> World
updateSparks w = w' & cWorld . lWorld . sparks .~ catMaybes newsparks updateSparks = updateObjCatMaybes sparks moveSpark
where
(w', newsparks) = mapAccumR moveSpark w $ w ^. cWorld . lWorld . sparks
updatePosEvents :: World -> World updatePosEvents :: World -> World
updatePosEvents w = w' & cWorld . lWorld . posEvents .~ catMaybes newposEvents updatePosEvents = updateObjCatMaybes posEvents updatePosEvent
where
(w', newposEvents) = mapAccumR updatePosEvent w $ w ^. cWorld . lWorld . posEvents
{- Apply internal particle updates, delete 'Nothing's. -} {- Apply internal particle updates, delete 'Nothing's. -}
--updateParticles :: World -> World --updateParticles :: World -> World
@@ -562,10 +562,7 @@ mvGust _ gu
& guTime -~ 1 & guTime -~ 1
updateClouds :: World -> World updateClouds :: World -> World
updateClouds w = w' & cWorld . lWorld . clouds .~ catMaybes mclouds updateClouds = updateObjCatMaybes clouds updateCloud
where
-- cls = _clouds w
(w', mclouds) = mapAccumR updateCloud w (w ^. cWorld . lWorld . clouds)
cloudEffect :: Cloud -> World -> World cloudEffect :: Cloud -> World -> World
cloudEffect cl = case _clType cl of cloudEffect cl = case _clType cl of
src/Dodge/Update/Camera.hs
+2 -2
View File
@@ -254,10 +254,10 @@ extendedViewPoints p grs =
extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p) extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p)
addDir a = p +.+ unitVectorAtAngle a addDir a = p +.+ unitVectorAtAngle a
farWallPoints :: Point2 -> World -> [Point2] farWallPoints :: Point2 -> CWorld -> [Point2]
farWallPoints p w = concatMap _grViewpoints grs ++ extendedViewPoints p grs farWallPoints p w = concatMap _grViewpoints grs ++ extendedViewPoints p grs
where where
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen (_cWorld w)) grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w)
maxViewDistance :: Float maxViewDistance :: Float
maxViewDistance = 800 maxViewDistance = 800