From e7e20277e4532716cc5a443f8af6ea1e4b1f0e3f Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 23 Aug 2022 23:00:12 +0100 Subject: [PATCH] Attempt to fix some space leaks, general cleanup --- src/Dodge/Creature/ChainUpdates.hs | 3 + src/Dodge/Creature/Update.hs | 21 +-- src/Dodge/Hammer.hs | 1 + src/Dodge/Humanoid.hs | 3 +- src/Dodge/Placement/PlaceSpot.hs.orig | 203 -------------------------- src/Dodge/Tesla/Arc.hs | 3 +- src/Dodge/Update.hs | 17 ++- src/Dodge/Update/Camera.hs | 2 +- src/Dodge/Update/WallDamage.hs | 7 +- src/Dodge/Wall/Delete.hs | 3 +- src/Dodge/Wall/Dust.hs | 5 +- src/Loop.hs | 66 +++++---- 12 files changed, 71 insertions(+), 263 deletions(-) delete mode 100644 src/Dodge/Placement/PlaceSpot.hs.orig diff --git a/src/Dodge/Creature/ChainUpdates.hs b/src/Dodge/Creature/ChainUpdates.hs index 8e487ade5..3535e5210 100644 --- a/src/Dodge/Creature/ChainUpdates.hs +++ b/src/Dodge/Creature/ChainUpdates.hs @@ -11,3 +11,6 @@ chainCreatureUpdates :: chainCreatureUpdates ls w cr = foldl' unf cr ls where unf cr' g = g w cr' +--chainCreatureUpdates ls w cr = foldr unf cr ls +-- where +-- unf g cr' = g w cr' diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index d62195ddc..8475a7215 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -1,14 +1,11 @@ -module Dodge.Creature.Update where +module Dodge.Creature.Update + ( updateCreature + ) where import Dodge.Barreloid -import Dodge.Creature.ChainUpdates -import Dodge.Creature.Impulse -import Dodge.Creature.State import Dodge.Data.World import Dodge.Humanoid import Dodge.Lampoid -import LensHelp -import System.Random updateCreature :: Creature -> World -> World updateCreature cr = case _crType cr of @@ -16,15 +13,3 @@ updateCreature cr = case _crType cr of Humanoid{} -> updateHumanoid cr Barreloid{} -> updateBarreloid cr NonDrawnCreature -> id - --- bit of a hack to get new random generators after each creature's update -defaultImpulsive :: - [World -> Creature -> Creature] -> - Creature -> - World -> - World -defaultImpulsive = fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates - where - updateRandGen w = - let (_, g) = randomR (0, 1 :: Int) (_randGen w) - in w & randGen .~ g diff --git a/src/Dodge/Hammer.hs b/src/Dodge/Hammer.hs index 100aa6155..ba305b7db 100644 --- a/src/Dodge/Hammer.hs +++ b/src/Dodge/Hammer.hs @@ -3,5 +3,6 @@ module Dodge.Hammer where import Dodge.Data.Hammer moveHammerUp :: HammerPosition -> HammerPosition +{-# INLINE moveHammerUp #-} moveHammerUp HammerDown = HammerReleased moveHammerUp _ = HammerUp diff --git a/src/Dodge/Humanoid.hs b/src/Dodge/Humanoid.hs index faa6af17d..458b09da7 100644 --- a/src/Dodge/Humanoid.hs +++ b/src/Dodge/Humanoid.hs @@ -187,7 +187,8 @@ defaultImpulsive :: Creature -> World -> World -defaultImpulsive = fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates +defaultImpulsive fs cr = updateRandGen -- . stateUpdate (const id) cr + --fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates where updateRandGen w = let (_, g) = randomR (0, 1 :: Int) (_randGen w) diff --git a/src/Dodge/Placement/PlaceSpot.hs.orig b/src/Dodge/Placement/PlaceSpot.hs.orig deleted file mode 100644 index 7537c2419..000000000 --- a/src/Dodge/Placement/PlaceSpot.hs.orig +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} --- | deals with placement of objects within the world --- after they have had their coordinates set by the layout -module Dodge.Placement.PlaceSpot - ( placeSpot - ) where -import Dodge.Placement.Shift -import Dodge.Data -import Dodge.Path -import Dodge.Placement.PlaceSpot.Block -import Dodge.Placement.PlaceSpot.TriggerDoor -import Dodge.Default.Wall -import Dodge.ShiftPoint -import Dodge.Base.NewID -import Geometry -import qualified IntMapHelp as IM -import Color - -import Data.Foldable -import Data.Maybe -import System.Random -import Control.Monad.State -import Control.Lens -import qualified Data.IntSet as IS -import Data.Bifunctor - --- when placing a placement, we update the world and the room and assign an id --- to the placement -placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] ) -placeSpot (w,rm) plmnt = case plmnt of - Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w - Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback - Placement{} -> placePlainPSSpot w rm plmnt shift - PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) - RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm - PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), []) - where - shift = _rmShift rm - -placePickOne :: Int -> Placement -> Room -> World -> World -placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))] - -placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement]) -placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt' - where - (plmnt', g) = runState rplmnt (_randGen w) - -placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Placement]) -placePlainPSSpot w rm plmnt shift = - let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w - newplmnt = plmnt & plMID ?~ i - in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt) - where - recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl - in (wr,newplmnt:newplmnts) - --- this should be tidied up -placeSpotUsingLink :: World - -> Room - -> Placement - -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) - -> (RoomPos -> Room -> Room) - -> Maybe Placement - -> ((World, Room), [Placement]) -placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of - Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) - Nothing -> case fallback of - Nothing -> ((w,rm),[plmnt]) - Just plmnt' -> placeSpot (w,rm) plmnt' - where - searchedPoss [] = Nothing - searchedPoss (pos:poss) = case extract pos rm of - Nothing -> second (pos:) <$> searchedPoss poss - Just (ps,rmpos) -> Just ( ps,rmpos:poss) - -placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) - -> Placement -> World -> ((World,Room),[Placement]) -placeSpotRoomRand rm i f plmnt w = - let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps) - --- the Int here is some id that is assigned when the placement is placed -placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) -placeSpotID ps pt w = case pt of - PutTrigger cnd -> plNewID triggers cnd w - PutMod mdi -> plNewUpID modifications mdID mdi w - PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w - PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w - PutTerminal tm -> plNewUpID terminals tmID tm w - PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w - PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w - PutForeground fs -> plNewUpID shapes fsID (mvFS p rot fs) w - PutMachine pps mc -> plMachine (map doShift pps) mc p rot w - PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w - PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w - RandPS rgn -> evaluateRandPS rgn ps w - PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w - PutCoord cp -> plNewID coordinates (doShift cp) w - PutSlideDr wl dr off a b - -> plSlideDoor wl dr off (doShift a) (doShift b) w - PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) - wl w - PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w - PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) - PutNothing -> (0,w) - PutID i -> (i, w) - PutWorldUpdate f -> (0, w & f ps) - PutUsingGenParams f -> let (w',pt') = f w - in placeSpotID ps pt' w' - where - p@(V2 px py) = _psPos ps - p' = V3 px py 0 - rot = _psRot ps - doShift = shiftPointBy (p,rot) - -evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World) -evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) - where - (evaluatedType, g) = runState rgen (_randGen w) - -placeWallPoly :: [Point2] -> Wall -> World -> World -<<<<<<< HEAD ---placeWallPoly ps wl = over walls (placeWalls ps wl) -placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl) - where - rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) w $ loopPairs ps -======= -placeWallPoly ps wl = -- rmCrossPaths . - over walls (placeWalls ps wl) --- where --- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps ->>>>>>> efficientRuntime - -placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall -placeWalls qs wl wls = foldl' (addPane wl) wls pairs - where - (p:ps) = orderPolygon qs - pairs = zip (ps ++ [p]) (p:ps) - -addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall -addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls - where - wlid = IM.newKey wls - ----- | place an new object into an intmap and update its id ---plNewUpID :: ALens' World (IM.IntMap a) --- -> ALens' a Int --- -> a --- -> World --- -> (Int,World) ---plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i)) --- where --- i = IM.newKey $ w ^# l - -mvProp :: Point2 -> Float -> Prop -> Prop -mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a )) - -mvButton :: Point2 -> Float -> Button -> Button -mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) - -{- Creates a floor item at a given point.-} -createFlIt :: Point2 -> Float -> Item -> FloorItem -createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm } - -mvPP :: Point2 -> Float -> PressPlate -> PressPlate -mvPP p rot pp = pp {_ppPos = p,_ppRot = rot} - -mvCr :: Point2 -> Float -> Creature -> Creature -mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot} - -mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape -mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a )) - -plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World) -plMachine wallpoly mc p rot gw = (mcid - , gw & machines %~ addMc - & walls %~ placeMachineWalls color wallpoly mcid wlid - ) - where - color = _mcColor mc - w' = gw - mcid = IM.newKey $ _machines w' - wlid = IM.newKey $ _walls w' - wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] - --addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) - addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) - --- TODO correctly remove/shift pathfinding lines (removePathsCrossing) -placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall -placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly - where - f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l} - baseWall = defaultMachineWall - & wlColor .~ col - & wlStructure . wsMachine .~ mcid - & wlTouchThrough .~ True - -mvLS :: Point3 -> Float -> LightSource -> LightSource -mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos - & lsDir .~ rot - where - startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls) diff --git a/src/Dodge/Tesla/Arc.hs b/src/Dodge/Tesla/Arc.hs index 5fbfaedd2..1092e1905 100644 --- a/src/Dodge/Tesla/Arc.hs +++ b/src/Dodge/Tesla/Arc.hs @@ -3,6 +3,7 @@ module Dodge.Tesla.Arc , moveTeslaArc ) where +import Data.Foldable import Dodge.Data.CrWlID import Dodge.Data.ArcStep import Data.Maybe @@ -30,7 +31,7 @@ moveTeslaArc :: TeslaArc -> (World, Maybe TeslaArc) moveTeslaArc w pt - | _taTimer pt == 2 = (makesparks $ foldr damthings w thearc, Just $ pt & taTimer -~ 1) + | _taTimer pt == 2 = (makesparks $ foldl' (flip damthings) w thearc, Just $ pt & taTimer -~ 1) | _taTimer pt < 1 = (w, Nothing) | otherwise = (w, Just $ pt & taTimer -~ 1) where diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index b1bfad2ff..4a811db18 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -90,7 +90,10 @@ functionalUpdate w = . over uvWorld (cWorld . cwTime . worldClock +~ 1) . over uvWorld updateWorldSelect . over uvWorld doRewind - . over uvWorld (hammers . each %~ moveHammerUp) +-- . over uvWorld (hammers . each %~ moveHammerUp) +-- . over (uvWorld . hammers . each) moveHammerUp +-- . over uvWorld (hammers %~ fmap moveHammerUp) + . moveHammersUp . over uvWorld updateDistortions . over uvWorld updateCreatureSoundPositions . over uvWorld ppEvents @@ -138,8 +141,18 @@ functionalUpdate w = . updateBounds -- where should this go? next to update camera? $ over uvWorld updateCloseObjects w +moveHammersUp :: Universe -> Universe +--moveHammersUp = uvWorld . hammers .~ M.empty +moveHammersUp = uvWorld . hammers %~ M.map moveHammerUp +--moveHammersUp = uvWorld . hammers . each %~ (moveHammerUp $!) +--moveHammersUp = uvWorld %~ ( (hammers . each %~ (moveHammerUp $!)) $!) +--moveHammersUp uv = uv { _uvWorld = w' } +-- where +-- w = _uvWorld uv +-- w' = w {_hammers = fmap moveHammerUp (_hammers w)} + doWorldEvents :: World -> World -doWorldEvents w = foldr doWdWd (w & cWorld . worldEvents .~ []) (_worldEvents (_cWorld w)) +doWorldEvents w = foldl' (flip doWdWd) (w & cWorld . worldEvents .~ []) (_worldEvents (_cWorld w)) updateLasers :: World -> World updateLasers w = diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index ed162f742..6136095fc 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -79,7 +79,7 @@ moveZoomCamera uv = wallZoom = min4 (w ^. cWorld . cwCam . cwcBoundDist) min4 (a, b, c, d) = minimum [hh / maxd a, hh / maxd (- b), hw / maxd c, hw / maxd (- d)] maxd = max distFromEqmnt - distFromEqmnt = foldr max 1 $ IM.mapMaybe (_eeViewDist . _equipEffect . _itUse) $ getCrEquipment $ you w + distFromEqmnt = foldl' max 1 $ IM.mapMaybe (_eeViewDist . _equipEffect . _itUse) $ getCrEquipment $ you w hw = halfWidth cfig hh = halfHeight cfig -- = maybe clipZoom zoomFromItem (yourItem w ^? itZoom) wallZoom diff --git a/src/Dodge/Update/WallDamage.hs b/src/Dodge/Update/WallDamage.hs index f28b599c1..02ece64c4 100644 --- a/src/Dodge/Update/WallDamage.hs +++ b/src/Dodge/Update/WallDamage.hs @@ -5,13 +5,14 @@ import Data.Maybe import Dodge.Data.World import Dodge.Wall.Damage import qualified IntMapHelp as IM +import Data.Foldable updateWallDamages :: World -> World updateWallDamages w = w & cWorld . wallDamages .~ IM.empty - & flip (IM.foldrWithKey f) (_wallDamages (_cWorld w)) + & flip (IM.foldlWithKey' f) (_wallDamages (_cWorld w)) where - f k dams w' = fromMaybe w' $ do + f w' k dams = fromMaybe w' $ do wl <- w' ^? cWorld . walls . ix k - return $ foldr (`damageWall` wl) w' dams + return $ foldl' (flip (`damageWall` wl)) w' dams diff --git a/src/Dodge/Wall/Delete.hs b/src/Dodge/Wall/Delete.hs index 863e1e5f0..adb02a691 100644 --- a/src/Dodge/Wall/Delete.hs +++ b/src/Dodge/Wall/Delete.hs @@ -3,6 +3,7 @@ module Dodge.Wall.Delete ( deleteWallID, ) where +import Data.Foldable import Control.Lens import qualified Data.IntSet as IS import Dodge.Data.World @@ -24,4 +25,4 @@ deleteWall wl = i = _wlID wl deleteWallIDs :: IS.IntSet -> World -> World -deleteWallIDs is w = foldr deleteWall w $ IM.restrictKeys (_walls (_cWorld w)) is +deleteWallIDs is w = foldl' (flip deleteWall) w $ IM.restrictKeys (_walls (_cWorld w)) is diff --git a/src/Dodge/Wall/Dust.hs b/src/Dodge/Wall/Dust.hs index cf3b51621..17cc02ef8 100644 --- a/src/Dodge/Wall/Dust.hs +++ b/src/Dodge/Wall/Dust.hs @@ -1,5 +1,6 @@ module Dodge.Wall.Dust where +import Data.Foldable import Control.Lens import Dodge.Data.World import Dodge.WorldEvent.Cloud @@ -12,9 +13,9 @@ wlDustAt wl = smokeCloudAt dustcol 20 200 1 . addZ 20 dustcol = _wlColor wl & _4 .~ 1 muchWlDustAt :: Wall -> Point2 -> World -> World -muchWlDustAt wl p = flip (foldr f) [10, 20 .. 100] +muchWlDustAt wl p = flip (foldl' f) [10, 20 .. 100] where - f h w = + f w h = w & smokeCloudAt dustcol 20 200 1 (addZ h (p +.+ off)) & randGen .~ g diff --git a/src/Loop.hs b/src/Loop.hs index e55f33ab0..5108a619c 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + --{-# LANGUAGE TupleSections #-} {- | @@ -103,7 +105,7 @@ setupConLoop :: -- | Initial simulation state. IO world -> -- | Concurrent effects. Evaluating 'Nothing' exits the loop - (world -> Maybe (world -> world,IO (world -> Maybe world))) -> + (world -> Maybe (world -> world, IO (world -> Maybe world))) -> -- | update, called once per frame. Allows for side effects such as rendering. (world -> IO world) -> -- | SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop. @@ -134,7 +136,7 @@ doConLoop :: Window -> -- | Concurrent effects, the first function in the pair is applied -- immediately - (world -> Maybe (world->world,IO (world -> Maybe world))) -> + (world -> Maybe (world -> world, IO (world -> Maybe world))) -> -- | simulation update. (world -> IO world) -> -- | SDL Event handling. @@ -142,32 +144,34 @@ doConLoop :: -- | Current simulation state. world -> IO () -doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do - startTicks <- ticks - let mconeff = coneffs startWorld - case mconeff of - Nothing -> return () - Just (_,acc) -> do - _ <- forkIO $ do - up <- acc - putMVar themvar up - return () - let startWorld'' = maybe id fst mconeff startWorld - mconupdate <- tryTakeMVar themvar - let mstartWorld' = case mconupdate of - Just conupdate -> conupdate startWorld'' - Nothing -> Just startWorld'' - case mstartWorld' of - Nothing -> return () - Just startWorld' -> do - worldAfterSimStep <- worldSideEffects startWorld' - glSwapWindow window - maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep) - case maybeUpdatedWorld of - Just updatedWorld -> do - performGC - endTicks <- ticks -- it might be better to use System.Clock (monotonic) - let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks) - threadDelay (theDelay * 1000) - doConLoop themvar spf window coneffs worldSideEffects eventFn updatedWorld - Nothing -> return () +doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld + where + go sw = do + startTicks <- ticks + let mconeff = coneffs sw + case mconeff of + Nothing -> return () + Just (_, acc) -> do + _ <- forkIO $ do + up <- acc + putMVar themvar up + return () + let startWorld'' = maybe id fst mconeff sw + mconupdate <- tryTakeMVar themvar + let mstartWorld' = case mconupdate of + Just conupdate -> conupdate startWorld'' + Nothing -> Just startWorld'' + case mstartWorld' of + Nothing -> return () + Just startWorld' -> do + worldAfterSimStep <- worldSideEffects startWorld' + glSwapWindow window + maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep) + case maybeUpdatedWorld of + Just updatedWorld -> do + performGC + endTicks <- ticks -- it might be better to use System.Clock (monotonic) + let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks) + threadDelay (theDelay * 1000) + go $! updatedWorld + Nothing -> return ()