Remove wall corner collision test for creatures

src/Dodge/Base.hs

@@ -217,8 +217,8 @@ overlapCircWallsReturnWall p rad
 -- | Looks for any collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
 -- note that in this version the circle can overlap the wall
-collidePointAnyWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collidePointAnyWalls p1 p2 
+collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointAnyWallsReflect p1 p2 
     = getFirst
     . foldMap (First . findPoint . _wlLine)
   where 
@@ -226,6 +226,15 @@ collidePointAnyWalls p1 p2
         Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
         Nothing -> Nothing
 
+-- | Looks for collision of a point with walls.
+-- If found, gives collision point
+-- If not found, returns point
+collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+collidePointWalls p1 p2 
+    = foldr findPoint p2 . fmap _wlLine
+  where
+    findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
+
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
 -- note that the "intersection" point is the center of the circle flush against the wall

src/Dodge/Item/Weapon.hs

@@ -165,7 +165,7 @@ teslaGunPic :: SPic
 teslaGunPic = 
     ( colorSH blue $
         upperPrismPoly 5 (rectNESW xb    y xa    (-y))
-        ++ (upperPrismPoly 5 $ rectNESW (-xa) y (-xb) (-y))
+        ++ upperPrismPoly 5 (rectNESW (-xa) y (-xb) (-y))
     , mempty
     )
   where

src/Dodge/Room/Foreground.hs

@@ -42,8 +42,8 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
     lhsPoints = divideLineExact d (pa -.- yN) (pb +.+ yN)
     findDiPoint p = head . sortOn (dist p) $ catMaybes 
         [intersectLineLine' p (p +.+ diVec) pax pbx
-        ,intersectSegLine' pa pax p (p +.+ diVec)
-        ,intersectSegLine' pb pbx p (p +.+ diVec)
+        ,intersectSegLine pa pax p (p +.+ diVec)
+        ,intersectSegLine pb pbx p (p +.+ diVec)
         ]
     yN = d * 0.5 *.* normalizeV (pa -.- pb)
 
@@ -67,7 +67,7 @@ girderZ w x y = setDepth 50 $ color red $ pictures $
     yt = y -.- n
     ps = divideLineExact (w*2) xb yb
     dia = rotateV (pi/4) n
-    ps' = map (\p -> intersectSegLine' xt yt p (p +.+ dia)) ps
+    ps' = map (\p -> intersectSegLine xt yt p (p +.+ dia)) ps
     ls = catMaybes $ zipWith (fmap . (,)) ps ps'
 girderV :: Color -> Float -> Point2 -> Point2 -> Picture
 girderV col w x y = setDepth 50 $ color col $ pictures $
@@ -84,7 +84,7 @@ girderV col w x y = setDepth 50 $ color col $ pictures $
     yt = y -.- n
     ps = divideLineExact (w*2) xb yb
     (as,_) = evenOddSplit ps
-    f a = map (\p -> intersectSegLine' xt yt p (p +.+ rotateV a n))
+    f a = map (\p -> intersectSegLine xt yt p (p +.+ rotateV a n))
     as' = catMaybes $ zipWith (fmap . (,)) as $ f (pi/4) as
     bs' = catMaybes $ zipWith (fmap . (,)) as $ f (3*pi/4) as
 girder :: Color -> Float -> Point2 -> Point2 -> Picture
@@ -103,7 +103,7 @@ girder col w x y = pictures $
     xt = x -.- n
     yt = y -.- n
     ps = divideLineExact (w*2) xb yb
-    ps' = map (\p -> intersectSegLine' xt yt p (p +.+ n)) ps
+    ps' = map (\p -> intersectSegLine xt yt p (p +.+ n)) ps
     ls = catMaybes $ zipWith (fmap . (,)) ps ps'
 
 

src/Dodge/Update.hs

@@ -34,7 +34,6 @@ import qualified Data.Map as M
 import Control.Lens
 import Data.Monoid
 import System.Random
---import Data.Bifunctor
 
 update :: World -> World
 update = (frameClock +~ 1) . functionalUpdate
@@ -200,7 +199,7 @@ updateCloud w c
     newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
     newPos2 = stripZ newPos
     -- the following only tests for the first collision with a wall
-    hitWl = collidePointAnyWalls oldPos2 newPos2 $ wallsNearPoint newPos2 w
+    hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
     finalPos = addZ npz $ maybe newPos2 fst hitWl
     finalVel = addZ nvz $ maybe newVel2 snd hitWl
 

src/Dodge/WallCreatureCollisions.hs

@@ -5,6 +5,7 @@ import Dodge.Data.DamageType
 import Dodge.Creature.State.Data
 import Dodge.Debug.Flag.Data
 import Dodge.Zone
+import Dodge.Base
 import Geometry
 
 import Data.List
@@ -21,15 +22,16 @@ colCrWall w c
     | noclipIsOn && _crID c == 0 = c -- for noclip
     | p1 == p2  = pushOrCrush ls c
     | otherwise = c & crPos %~
-        collideCorners rad wallPoints
-        . collideWalls rad p1 ls 
-        . checkPushThroughs p1 ls 
+--        collideCorners rad wallPoints
+         collideWalls rad p1 ls 
+        . flip (collidePointWalls p1) wls  -- check push throughs
   where 
     rad = _crRad c + wallBuffer
     p1  = _crOldPos c
     p2  = _crPos c
     ls  = IM.elems $ _wlLine <$> wallsNearPoint p2 w
-    wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls
+    wls = wallsNearPoint p2 w
+    --wallPoints = map fst ls
     noclipIsOn = _noClip $ _debugFlags w
 
 -- the amount to push creatures out from walls, extra to their radius
@@ -40,11 +42,12 @@ wallBuffer = 0
 -- out from the wall
 -- this is then repeated if the point ends up on a new wall
 collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
-collideWalls rad cp1 wls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) wls of
+collideWalls rad cp1 wls cp2 = case (listToMaybe . mapMaybe (pushOutFromWall rad cp2)) wls of
     Nothing -> cp2
-    Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) wls of
+    Just cp3 -> case (listToMaybe . reverse . mapMaybe (pushOutFromWall rad cp3)) wls of
         Nothing -> cp3
-        Just cp4 -> 0.5 *.* (cp4 +.+ cp1)
+--        Just cp4 -> 0.5 *.* (cp4 +.+ cp1)
+        Just _ -> cp1
 
 -- pushes a point out from a list of walls
 -- if multiple new points occur, chooses the one closest to the orignal point
@@ -92,13 +95,3 @@ intersectCirclePoint rad p cCen
     | dist cCen p > rad = cCen
     | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
 
-checkPushThroughs :: Point2 -> [(Point2,Point2)] -> Point2 -> Point2
-checkPushThroughs cp1 wls cp2
-    = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough cp1 cp2)) wls
-
-checkPushThrough :: Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2
-checkPushThrough cp1 cp2 (wp1,wp2) 
-    | isPushedThrough = intersectSegSeg cp1 cp2 wp1 wp2
-    | otherwise = Nothing
-  where
-    isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg cp1 cp2 wp1 wp2)