Fix bugs in zoning

src/Dodge/Render/Label.hs

@@ -0,0 +1,31 @@
+module Dodge.Render.Label
+    where
+import Dodge.Base.Coordinate
+import Dodge.ShortShow
+import Dodge.Base.WinScale
+import Picture
+import Dodge.Data.Universe
+import Geometry
+
+drawLabCrossCol :: Configuration -> World -> Color -> Point2 -> Picture
+drawLabCrossCol cfig w col p = drawCrossCol col p
+    <> drawPointLabel cfig w p
+
+drawPointLabel :: Configuration -> World -> Point2 -> Picture 
+drawPointLabel cfig w p =
+    setLayer FixedCoordLayer . winScale cfig
+        . uncurryV translate p'
+        . scale 0.1 0.1
+        . text
+        $ shortPoint2 p
+  where
+    p' = worldPosToScreen w p
+
+drawCrossCol :: Color -> Point2 -> Picture
+drawCrossCol col p = setLayer DebugLayer . color col . uncurryV translate p $ crossPic 5
+
+drawCross :: Point2 -> Picture
+drawCross = drawCrossCol red
+
+crossPic :: Float -> Picture
+crossPic x = line [V2 x x, V2 (- x) (- x)] <> line [V2 (- x) x, V2 x (- x)]

src/Dodge/Render/ShapePicture.hs

@@ -2,7 +2,8 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
-import Dodge.Zoning.Base
+import Dodge.Render.Label
+import Dodge.WorldEvent.ThingsHit
 import Control.Lens
 import Data.Foldable
 import qualified Data.Graph.Inductive as FGL
@@ -10,47 +11,28 @@ import qualified Data.Map.Strict as M
 import Data.Maybe
 import qualified Data.Set as Set
 import Dodge.Base
-import Dodge.Beam.Draw
-import Dodge.Block.Draw
-import Dodge.Bullet.Draw
-import Dodge.Button.Draw
-import Dodge.Cloud.Draw
 import Dodge.Creature.Picture
 import Dodge.Creature.Picture.Awareness
 import Dodge.Data.Config
 import Dodge.Data.World
 import Dodge.Debug.Picture
-import Dodge.EnergyBall.Draw
-import Dodge.Flame.Draw
+import Dodge.Draw
 import Dodge.Flare
 import Dodge.GameRoom
 import Dodge.Graph
-import Dodge.Item.Draw.SPic
-import Dodge.Laser.Draw
-import Dodge.LightSource.Draw
-import Dodge.LinearShockwave.Draw
-import Dodge.Machine.Draw
 import Dodge.Path
 import Dodge.Picture.SizeInvariant
-import Dodge.Projectile.Draw
-import Dodge.Prop.Draw
 import Dodge.RadarBlip
-import Dodge.RadarSweep.Draw
 import Dodge.Render.InfoBox
 import Dodge.Render.List
-import Dodge.Shockwave.Draw
 import Dodge.ShortShow
 import Dodge.SoundLogic.LoadSound
-import Dodge.Spark.Draw
-import Dodge.Targeting.Draw
-import Dodge.Tesla.Arc.Draw
-import Dodge.TractorBeam.Draw
 import Dodge.Update.Camera
 import Dodge.Zone
 import Dodge.Zoning
+import Dodge.Zoning.Base
 import Geometry
 import Geometry.ConvexPoly
---import Geometry.Zone
 import qualified IntMapHelp as IM
 import Padding
 import Picture
@@ -172,36 +154,47 @@ debugDraw cfig w
             <> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
     | otherwise = mempty
   where
-    (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
+    pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
+    ts = map show (Set.toList $ _debug_booleans cfig)
 
-debugDraw' :: Configuration -> World -> DebugBool -> ([String], Picture)
+debugDraw' :: Configuration -> World -> DebugBool -> Picture
 {-# INLINE debugDraw' #-}
 debugDraw' cfig w bl = case bl of
-    Show_debug -> lstring "Show debug"
-    Noclip -> lstring "Noclip"
-    Remove_LOS -> lstring "No line of sight"
-    Cull_more_lights -> lstring "Cull more lights"
-    Close_shape_culling -> lstring "Close shape culling"
-    Bound_box_screen -> lstring "bound box screen, this should be moved"
-    Show_ms_frame -> rdraw mempty
-    View_boundaries -> rdraw $ viewBoundaries w
-    Show_bound_box -> rdraw $ drawBoundingBox w
-    Show_wall_search_rays -> rdraw $ drawWallSearchRays w
-    Show_dda_test -> rdraw $ drawDDATest w
-    Show_far_wall_detect -> rdraw $ drawFarWallDetect w
-    Show_select -> rdraw $ drawWorldSelect w
-    Inspect_wall -> rdraw $ drawInspectWalls w
-    Cr_awareness -> rdraw $ drawCreatureDisplayTexts w
-    Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
-    Cr_status -> rdraw $ drawCrInfo cfig w
-    Mouse_position -> rdraw $ drawMousePosition cfig w
-    Walls_info -> rdraw $ drawWlIDs cfig w
-    Pathing -> rdraw $ drawPathing cfig w
-    Show_nodes_near_select -> rdraw $ drawNodesNearSelect w
-    Show_path_between -> rdraw $ drawPathBetween w
+    Show_debug -> mempty
+    Noclip -> mempty
+    Remove_LOS -> mempty
+    Cull_more_lights -> mempty
+    Close_shape_culling -> mempty
+    Bound_box_screen -> mempty
+    Show_ms_frame -> mempty
+    View_boundaries -> viewBoundaries w
+    Show_bound_box -> drawBoundingBox w
+    Show_wall_search_rays -> drawWallSearchRays w
+    Show_dda_test -> drawDDATest w
+    Show_far_wall_detect -> drawFarWallDetect w
+    Show_select -> drawWorldSelect w
+    Inspect_wall -> drawInspectWalls w
+    Cr_awareness -> drawCreatureDisplayTexts w
+    Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds w
+    Cr_status -> drawCrInfo cfig w
+    Mouse_position -> drawMousePosition cfig w
+    Walls_info -> drawWlIDs cfig w
+    Pathing -> drawPathing cfig w
+    Show_nodes_near_select -> drawNodesNearSelect w
+    Show_path_between -> drawPathBetween w
+    Collision_test -> drawCollisionTest cfig w
+
+drawCollisionTest :: Configuration -> World -> Picture
+drawCollisionTest cfig w =
+    setLayer DebugLayer (color orange $ line [a,b])
+    <> foldMap (drawCross . fst) (crHit a b w) 
+    <> foldMap (drawCross . _crPos) (crsNearSeg a b w) 
+--    <> foldMap (drawZoneCol green crZoneSize) (zoneOfSeg' crZoneSize a b)
+    <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint' crZoneSize) (xIntercepts' crZoneSize a b)
+    <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint' crZoneSize) (yIntercepts' crZoneSize a b)
+    <> foldMap (drawLabCrossCol cfig w blue) (xIntercepts' crZoneSize a b)
   where
-    lstring str = ([str], mempty)
-    rdraw pic = (mempty, pic)
+    (a, b) = _lrLine w
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w))
@@ -229,9 +222,11 @@ drawNodesNearSelect w =
 
 drawInspectWalls :: World -> Picture
 drawInspectWalls w =
-    foldMap (drawInspectWall w) $
+    setLayer DebugLayer (color orange $ line [a,b]) <>
+    foldMap (drawInspectWall w) (
         filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
             IM.elems $ _walls (_cWorld w)
+    )
   where
     (a, b) = _lLine w
 
@@ -287,25 +282,21 @@ drawFarWallDetect w =
 drawDDATest :: World -> Picture
 drawDDATest w =
     foldMap (drawZoneCol orange 50) ps
---    runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
---        <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps')
---        <> runIdentity (S.foldMap_ drawCross qs)
---        <> color blue (runIdentity (S.foldMap_ drawCross qs'))
+        --    runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
+        --        <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps')
+        --        <> runIdentity (S.foldMap_ drawCross qs)
+        --        <> color blue (runIdentity (S.foldMap_ drawCross qs'))
         <> setLayer DebugLayer (color yellow (line [cvf, mwp]))
   where
     cvf = _cameraViewFrom (_cWorld w)
     mwp = mouseWorldPos w
     --ps = ddaStreamX 50 cvf mwp
     ps = zoneOfSeg' 50 cvf mwp
-    --ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
-    --qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
-    --qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
 
-drawCross :: Point2 -> Picture
-drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5
+--ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
+--qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
+--qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
 
-crossPic :: Float -> Picture
-crossPic x = line [V2 x x, V2 (- x) (- x)] <> line [V2 (- x) x, V2 x (- x)]
 
 drawZoneCol :: Color -> Float -> V2 Int -> Picture
 drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])