Fix error in circle wall collision detection

The wall zoning did not take into account the radius of the circle

appDodge/Main.hs

@@ -96,6 +96,8 @@ firstWorldLoad theConfig = do
                 , _uvFrameTicks = 0
                 , _uvRAMSave = Nothing
                 , _uvDebug = mempty
+                , _uvDebugFloat1 = 10
+                , _uvDebugFloat2 = 0
                 , _uvDebugMessageOffset = 0
                 }
     return $ u & uvScreenLayers .~ [splashMenu u]

data/dodge.config.json

@@ -2,7 +2,8 @@
   "_debug_booleans": [
     "Show_ms_frame",
     "Enable_debug",
-    "Collision_test"
+    "Circ_collision_test",
+    "Show_walls_near_segment"
   ],
   "_debug_view_clip_bounds": "NoRoomClipBoundaries",
   "_gameplay_rotate_to_wall": true,

src/Dodge/Base/Collide.hs

@@ -35,6 +35,7 @@ module Dodge.Base.Collide (
     anythingHitCirc,
 ) where
 
+--import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import qualified Data.IntSet as IS
 import Data.List (sortOn)
@@ -152,13 +153,12 @@ collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
   where
     findPoint (p, mwl) wl =
         maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
-            . shiftbyrad
+            . shiftbyrad . _wlLine $ wl
-            . _wlLine
+--    shiftbyrad (a, b) =
-            $ wl
+--            ( a +.+ rad *.* normalizeV (a -.- b)
-    shiftbyrad (a, b) =
+--            , b +.+ rad *.* normalizeV (b -.- a)
-        bimap
+--            )
-            f
+    shiftbyrad (a, b) = bimap f f
-            f
             ( a +.+ rad *.* normalizeV (a -.- b)
             , b +.+ rad *.* normalizeV (b -.- a)
             )
@@ -243,13 +243,16 @@ canSeeIndirect i j w = hasLOSIndirect ipos jpos w
 anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
 anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
   where
-    hitCr = IS.foldr f False $ crixsNearSeg sp ep w
+    x = rad *.* normalizeV (ep - sp)
+    xsp = sp - x
+    xep = ep + x
+    hitCr = IS.foldr f False $ crixsNearSeg xsp xep w
     f cid bl =
         maybe
             False
             (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
             (w ^? cWorld . lWorld . creatures . ix cid)
             || bl
-    hitWl = collideCircWalls sp ep rad $ wlsNearSeg sp ep w
+    hitWl = collideCircWalls sp ep rad $ wlsNearSeg xsp xep w
 
 -- this should probably be wallsOnLine or something

src/Dodge/Data/Config.hs

@@ -82,9 +82,11 @@ data DebugBool
     | Show_wall_search_rays
     | Show_dda_test
     | Collision_test
+    | Circ_collision_test
     | Show_far_wall_detect
     | Show_walls_near_point_cursor
     | Show_walls_near_point_you
+    | Show_walls_near_segment
     | Show_zone_near_point_cursor
     | Inspect_wall
     | Show_nodes_near_select

src/Dodge/Data/Universe.hs

@@ -41,6 +41,8 @@ data Universe = Universe
     , _uvFrameTicks :: Word32
     , _uvRAMSave :: Maybe World
     , _uvDebug :: M.Map DebugBool DebugItem
+    , _uvDebugFloat1 :: Float
+    , _uvDebugFloat2 :: Float
     , _uvDebugMessageOffset :: Int
     }
 

src/Dodge/Debug.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module Dodge.Debug where
 
 import Data.Aeson.Types
@@ -23,10 +24,25 @@ debugEvents u = case dbools ^. at Enable_debug of
     dbools = u ^. uvConfig . debug_booleans
 
 debugEvent :: DebugBool -> Universe -> Universe
-debugEvent db u = case db of
+debugEvent db u = u & uvDebug . at db .~ debugEvent' u db
-    Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
+--  case db of
-    Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
+--    Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
-    _ -> u
+--    Circ_collision_test -> u & uvDebug . at Circ_collision_test ?~ circCollisionDebugItem u
+--    Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
+--    _ -> u
+
+debugEvent' :: Universe -> DebugBool -> Maybe DebugItem
+debugEvent' u = \case
+    Collision_test -> Just $ collisionDebugItem u
+    Circ_collision_test -> Just $ circCollisionDebugItem u
+    Select_creature -> Just $ selectCreatureDebugItem u
+    Show_walls_near_point_cursor -> Just 
+        (DebugItem (const $ drawWallsNearCursor w) (const mempty) NoDebugInfo)
+    Show_walls_near_segment -> Just 
+        (DebugItem (const $ drawWallsNearSegment w) (const mempty) NoDebugInfo)
+    _ -> Nothing
+  where
+    w = u ^. uvWorld
 
 collisionDebugItem :: Universe -> DebugItem
 collisionDebugItem u =
@@ -44,6 +60,14 @@ selectCreatureDebugItem u =
         , _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
         }
 
+circCollisionDebugItem :: Universe -> DebugItem
+circCollisionDebugItem _ =
+    DebugItem
+        { _debugPic = drawCircCollisionTest . (^. uvWorld)
+        , _debugMessage = const []
+        , _debugInfo = NoDebugInfo
+        }
+
 scrollDebugInfoInt :: Int -> Universe -> DebugInfo -> DebugInfo
 scrollDebugInfoInt i u
     | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =

src/Dodge/Debug/Picture.hs

@@ -108,6 +108,27 @@ drawCollisionTest w = concat $ do
         setLayer DebugLayer (color orange $ line [a, b])
             <> foldMap (drawCrossCol red . fst) (thingHit a b w)
 
+drawCircCollisionTest :: World -> Picture
+drawCircCollisionTest w = concat $ do
+    a <- w ^. input . heldWorldPos . at ButtonLeft
+    b <- w ^. input . heldWorldPos . at ButtonRight
+    let col | (anythingHitCirc 2 a b w) = red
+            | otherwise = green
+    return $
+        setLayer DebugLayer (color col $ line [a, b])
+        <> drawCoord a w <> drawCoord b w
+
+drawWallsNearSegment :: World -> Picture
+drawWallsNearSegment w = concat $ do
+    a <- w ^. input . heldWorldPos . at ButtonLeft
+    b <- w ^. input . heldWorldPos . at ButtonRight
+    return . foldMap f $ wlsNearSeg a b w
+  where
+    f wl = setLayer DebugLayer (color rose $ thickLine 3 [a, b])
+        <> drawCoord a w <> drawCoord b w
+      where
+        (a, b) = _wlLine wl
+
 --            <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
 --            <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
 --            <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
@@ -147,7 +168,8 @@ debugDraw' cfig w bl = case bl of
     Show_wall_search_rays -> drawWallSearchRays w
     Show_dda_test -> drawDDATest w
     Show_far_wall_detect -> drawFarWallDetect w
-    Show_walls_near_point_cursor -> drawWallsNearCursor w
+    Show_walls_near_point_cursor -> mempty
+    Show_walls_near_segment -> mempty
     Show_walls_near_point_you -> drawWallsNearYou w
     Show_zone_near_point_cursor -> drawZoneNearPointCursor w
     Inspect_wall -> drawInspectWalls w
@@ -160,6 +182,7 @@ debugDraw' cfig w bl = case bl of
     Show_nodes_near_select -> undefined --drawNodesNearSelect w
     Show_path_between -> drawPathBetween w
     Collision_test -> mempty
+    Circ_collision_test -> mempty
     Select_creature -> mempty
 
 drawCreatureDisplayTexts :: World -> Picture
@@ -188,9 +211,10 @@ drawWallsNearYou w = concat $ do
 
 drawWallsNearCursor :: World -> Picture
 drawWallsNearCursor w =
-    setLayer DebugLayer $ foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_wCam w)) w
+    foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_wCam w)) w
   where
-    f wl = color rose $ thickLine 3 [a, b]
+    f wl = setLayer DebugLayer (color rose $ thickLine 3 [a, b])
+        <> drawCoord a w <> drawCoord b w
       where
         (a, b) = _wlLine wl
 
@@ -326,6 +350,14 @@ drawMousePosition w =
   where
     mwp = mouseWorldPos (w ^. input) (w ^. wCam)
 
+drawCoord :: Point2 -> World -> Picture
+drawCoord p w = 
+    setLayer FixedCoordLayer
+        . uncurryV translate (worldPosToScreen (w ^. wCam) p)
+        . scale 0.1 0.1
+        . text
+        $ shortPoint2 p
+
 drawWlIDs :: World -> Picture
 drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
   where

src/Dodge/TestString.hs

@@ -26,7 +26,9 @@ import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M
 
 testStringInit :: Universe -> [String]
-testStringInit u = foldMap prettyShort $ u ^. uvWorld . cWorld . lWorld . projectiles
+testStringInit u = [show $ u ^. uvDebugFloat1
+    , show $ u ^. uvWorld . input . heldWorldPos . at SDL.ButtonRight]
+--testStringInit u = foldMap prettyShort $ u ^. uvWorld . cWorld . lWorld . projectiles
 --    (map (show . _ebPos) $ u ^. uvWorld . cWorld . lWorld . energyBalls)
 --    <>
 --    (foldMap prettyShort $ u ^. uvWorld . cWorld . lWorld . bullets)

src/Dodge/Update/Input/InGame.hs

@@ -4,6 +4,7 @@ module Dodge.Update.Input.InGame (
     updateMouseInGame,
 ) where
 
+import Dodge.Update.Input.DebugTest
 import Dodge.Item.InvSize
 import Data.Monoid
 import NewInt
@@ -351,6 +352,8 @@ updateFunctionKey uv sc InitialPress = case sc of
     ScancodeF9 -> doQuickload uv
     ScancodeEscape -> pauseGame uv
     _ -> uv
+updateFunctionKey uv ScancodeF3 _ = doDebugTest uv
+updateFunctionKey uv ScancodeF4 _ = doDebugTest2 uv
 updateFunctionKey uv _ _ = uv
 
 updatePressedButtonsCarte :: World -> World
@@ -585,3 +588,4 @@ maybeExitCombine w
     | ButtonRight `M.member` (w ^. input . mouseButtons) = w
     | otherwise =
         w & hud . hudElement . subInventory .~ NoSubInventory
+