Cleanup

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'

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