Attempt to fix some space leaks, general cleanup

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'

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

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

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)

src/Dodge/Placement/PlaceSpot.hs.orig

@@ -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)

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

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 =

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

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

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

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

src/Loop.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
+
 --{-# LANGUAGE TupleSections #-}
 
 {- |
@@ -142,9 +144,11 @@ doConLoop ::
     -- | Current simulation state.
     world ->
     IO ()
-doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do
+doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld
+  where
+    go sw = do
         startTicks <- ticks
-    let mconeff = coneffs startWorld
+        let mconeff = coneffs sw
         case mconeff of
             Nothing -> return ()
             Just (_, acc) -> do
@@ -152,7 +156,7 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do
                     up <- acc
                     putMVar themvar up
                 return ()
-    let startWorld'' = maybe id fst mconeff startWorld
+        let startWorld'' = maybe id fst mconeff sw
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
                 Just conupdate -> conupdate startWorld''
@@ -169,5 +173,5 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn startWorld = do
                         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
+                        go $! updatedWorld
                     Nothing -> return ()