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

Attempt to fix some space leaks, general cleanup

Browse Source
This commit is contained in:
justin
2022-08-23 23:00:12 +01:00
parent 9f00e67298
commit e7e20277e4
12 changed files with 71 additions and 263 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/ChainUpdates.hs
+3
View File
@@ -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
+3 -18
View File
@@ -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
+1
View File
@@ -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
+2 -1
View File
@@ -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
-203
View File
@@ -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
+2 -1
View File
@@ -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
+15 -2
View File
@@ -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
+1 -1
View File
@@ -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
+4 -3
View File
@@ -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
+2 -1
View File
@@ -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
+3 -2
View File
@@ -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
+35 -31
View File
@@ -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 ()