diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 3d240c87f..32e5a2137 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -2,9 +2,7 @@ Module : Dodge.Update Description : Simulation update -} -module Dodge.Update - ( updateUniverse - ) where +module Dodge.Update ( updateUniverse ) where import Dodge.Data import Dodge.Menu import Dodge.Hammer @@ -38,7 +36,7 @@ updateUniverse u = case _menuLayers u of | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail ) (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~ ( updateParticles - . updateProjectiles + . updateIMl _props _pjUpdate . updateLightSources . updateClouds ) (_ : _) -> u @@ -48,44 +46,47 @@ updateUniverse u = case _menuLayers u of functionalUpdate :: Configuration -> World -> World functionalUpdate cfig w = checkEndGame . (worldClock +~ 1) - . updateDistortions - . updateCreatureSoundPositions - . ppEvents - . updateCamera cfig - . colCrsWalls cfig --- . ifConfigWallRotate - . simpleCrSprings - . zoneCreatures - . updateDoors + . updateDistortions + . updateCreatureSoundPositions + . ppEvents + . updateCamera cfig + . colCrsWalls cfig + . simpleCrSprings + . zoneCreatures + . updateIMl _doors _drMech . updateDelayedEvents - . resetWorldEvents - . dbArg _worldEvents - . updateModifications - . updateParticles - . updateProjectiles - . updateLightSources - . updateClouds - . zoneClouds - . updateMachines - . updateCreatures - . updateCreatureGroups - . updateBlocks - . updateSeenWalls - . (lSelHammerPosition %~ moveHammerUp) - $ updateCloseObjects w + . resetWorldEvents + . dbArg _worldEvents + . updateIMl _modifications _mdUpdate + . updateParticles + . updateIMl _props _pjUpdate + . updateLightSources + . updateClouds + . zoneClouds + . updateIMl _machines _mcUpdate + . updateCreatures + . updateCreatureGroups + . updateBlocks + . updateSeenWalls + . (lSelHammerPosition %~ moveHammerUp) + $ updateCloseObjects w where --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w - zoneCreatures = set (creaturesZone . znObjects) - (IM.foldl' (flip creatureInZone) IM.empty (_creatures w)) - creatureInZone cr = insertIMInZone x y cid cr - where - (x,y) = crZoneOfPoint $ _crPos cr - cid = _crID cr zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w)) cloudInZone cl = insertInZoneWith x y (++) [cl] where (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl +zoneCreatures :: World -> World +zoneCreatures w = w + & creaturesZone . znObjects .~ + IM.foldl' (flip creatureInZone) IM.empty (_creatures w) + where + creatureInZone cr = insertIMInZone x y cid cr + where + (x,y) = crZoneOfPoint $ _crPos cr + cid = _crID cr + updateCreatureSoundPositions :: World -> World updateCreatureSoundPositions w = M.foldrWithKey insertSound w . M.mapMaybeWithKey updateSound @@ -97,8 +98,10 @@ updateCreatureSoundPositions w = M.foldrWithKey insertSound w Nothing -> Just s {_soundTime = Just 0} updateSound _ _ = Nothing -updateModifications :: World -> World -updateModifications w = foldr (dbArg _mdUpdate) w (_modifications w) +--updateIMr :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World +--updateIMr fim fup w = foldr (dbArg fup) w (fim w) +updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World +updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w) updateBlocks :: World -> World updateBlocks w = foldr f w $ _blocks w @@ -124,9 +127,6 @@ updateLightSources w = over tempLightSources f w where f = mapMaybe (\b -> _tlsUpdate b w b) -updateProjectiles :: World -> World -updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w - {- Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w' diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 9fb5a2655..dd3cd3fab 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -24,25 +24,10 @@ colCrsWalls cfig w = w & creatures %~ fmap (colCrWall cfig w) colCrWall :: Configuration -> World -> Creature -> Creature colCrWall cfig w c - | noclipIsOn && _crID c == 0 = c -- for noclip - | p1 == p2 = pushOrCrush ls c --- | _crPos c' == _crPos c'' = c' --- | otherwise = c & crPos .~ _crOldPos c - | otherwise = c' - where --- c'' = c' & crPos %~ pushOutFromWalls rad ls - --c' = c & crPos %~ pushOutFromWalls' rad (reverse ls) - c' = c & crPos %~ pushOutFromCorners rad ls - . pushOutFromWalls rad ls - . flip (collidePointWalls p1) wls -- check push throughs - rad = _crRad c + wallBuffer - p1 = _crOldPos c - p2 = _crPos c - ls = IM.elems $ _wlLine <$> wls - wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w - --wallPoints = map fst ls - noclipIsOn = _debug_noclip cfig + | _debug_noclip cfig && _crID c == 0 = c -- for noclip + | otherwise = colCrWall' w c +-- no noclip check, so no need for a configuration file colCrWall' :: World -> Creature -> Creature colCrWall' w c | p1 == p2 = pushOrCrush ls c @@ -114,44 +99,11 @@ pushOutFromWall rad cp2 (wp1,wp2) wp2' = wp2 +.+ rad *.* norm newP = errorClosestPointOnLine 5 wp1' wp2' cp2 isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad ---pushOutFromWall' :: Float -> Point2 -> (Point2,Point2) -> Maybe Point2 ---pushOutFromWall' rad cp2 (wp1,wp2) --- | isOnWall = Just newP --- | otherwise = Nothing --- where --- norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) --- wp1' = wp1 +.+ rad *.* norm --- wp2' = wp2 +.+ rad *.* norm --- newP = errorClosestPointOnLine 5 wp1' wp2' cp2 --- --isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad --- isOnWall = circOnSeg wp1 wp2 cp2 rad - - pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2 pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls ---pushOutFromCorners' :: World -> Creature -> Creature ---pushOutFromCorners' w cr = cr & crPos .~ newPos --- where --- newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls --- ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w - ---collideCorners :: Float -> [Point2] -> Point2 -> Point2 ---collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps - ---safeIntersectCirclePoint :: Float -> Point2 -> Point2 -> Maybe Point2 ---safeIntersectCirclePoint rad p cCen --- | dist cCen p > rad = Just cCen --- | otherwise = (p +.+) <$> ((rad *.*) <$> (safeNormalizeV (cCen -.- p))) - squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 squashIntersectCirclePoint rad p cCen | dist cCen p > rad = cCen | otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p)) - ----- collide circles with points (outer corners) ---intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 ---intersectCirclePoint rad p cCen --- | dist cCen p > rad = cCen --- | otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))