Fix more edge cases in circle collision

src/Dodge/Base/Collide.hs

@@ -18,7 +18,7 @@ module Dodge.Base.Collide (
     collideCircWalls,
     overlapSegWalls,
     overlapSegCrs,
-    bounceBall,
+--    bounceBall,
     bouncePoint,
     circOnSomeWall,
     circOnAnyCr,
@@ -75,15 +75,15 @@ doBounce x sp ep (p, mwl) =
         , reflVelWallDamp x wl (ep -.- sp)
         )
 
-bounceBall ::
-    Float ->
-    Point2 ->
-    Point2 ->
-    Float ->
-    [Wall] ->
-    Maybe (Point2, Point2)
-{-# INLINE bounceBall #-}
-bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
+--bounceBall ::
+--    Float ->
+--    Point2 ->
+--    Point2 ->
+--    Float ->
+--    [Wall] ->
+--    Maybe (Point2, Point2)
+--{-# INLINE bounceBall #-}
+--bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
 
 bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2, Point2)
 {-# INLINE bouncePoint #-}
@@ -146,6 +146,11 @@ overlapCircWalls p r = mapMaybe dointersect
     dointersect wl = f (_wlLine wl) <&> (,wl)
     f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
 
+circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
+circHitWall sp ep r w = any (uncurry (intersectSegSegTest sp ep) . _wlLine)
+        (wlsNearSeg sp ep w)
+    || any (uncurry (circOnSeg ep r) . _wlLine) (wlsNearPoint ep w)
+
 -- | note that this does not push the circle away from the wall at all
 collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
 {-# INLINE collideCircWalls #-}
@@ -241,7 +246,8 @@ canSeeIndirect i j w = hasLOSIndirect ipos jpos w
     jpos = w ^?! cWorld . lWorld . creatures . ix j . crPos
 
 anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
-anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
+--anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
+anythingHitCirc rad sp ep w = hitCr || circHitWall sp ep rad w
   where
     x = rad *.* normalizeV (ep - sp)
     xsp = sp - x
@@ -253,6 +259,6 @@ anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
             (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
             (w ^? cWorld . lWorld . creatures . ix cid)
             || bl
-    hitWl = collideCircWalls sp ep rad $ wlsNearSeg xsp xep w
+--    hitWl = collideCircWalls sp ep rad $ wlsNearSeg xsp xep w
 
 -- this should probably be wallsOnLine or something

src/Dodge/Update/Input/DebugTest.hs

@@ -1,6 +1,8 @@
 module Dodge.Update.Input.DebugTest (
     doDebugTest,
     doDebugTest2,
+    doDebugTestF6,
+    doDebugTestF7,
 ) where
 
 import Control.Lens
@@ -26,3 +28,18 @@ doDebugTest uv = fromMaybe uv $ do
 
 doDebugTest2 :: Universe -> Universe
 doDebugTest2 = uvDebugFloat1 .~ 20
+
+doDebugTestF6 :: Universe -> Universe
+doDebugTestF6 = uvIOEffects %~ \f u -> do
+    writeFile "log/heldL" $ show $ u ^. uvWorld . input . heldWorldPos . at ButtonLeft
+    writeFile "log/heldR" $ show $ u ^. uvWorld . input . heldWorldPos . at ButtonRight
+    f u
+
+doDebugTestF7 :: Universe -> Universe
+doDebugTestF7 = uvIOEffects %~ \f u -> do
+    l <- readFile "log/heldL"
+    r <- readFile "log/heldR"
+    f $ u
+        & uvWorld . input . heldWorldPos . at ButtonLeft .~ read l
+        & uvWorld . input . heldWorldPos . at ButtonRight .~ read r
+        

src/Dodge/Update/Input/InGame.hs

@@ -350,6 +350,8 @@ updateFunctionKey uv sc InitialPress = case sc of
     ScancodeF2 -> pauseAndFloatCam uv
     ScancodeF5 -> doQuicksave uv
     ScancodeF9 -> doQuickload uv
+    ScancodeF6 -> doDebugTestF6 uv
+    ScancodeF7 -> doDebugTestF7 uv
     ScancodeEscape -> pauseGame uv
     _ -> uv
 updateFunctionKey uv ScancodeF3 _ = doDebugTest uv