Digital line zoning

src/Dodge/Render/ShapePicture.hs

@@ -17,6 +17,7 @@ import Dodge.Update.Camera
 import Dodge.Item.Draw
 --import Dodge.Zone
 import Geometry
+import Geometry.Zone
 import ShapePicture
 import Shape
 import Picture
@@ -80,11 +81,45 @@ extraPics cfig w = pictures (_decorations w)
     <> drawCrInfo cfig w
     <> cfigdraw Show_bound_box drawBoundingBox
     <> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
+    <> cfigdraw Show_dda_test (const drawDDATest)
   where
     cfigdraw boption draw
         | debugOn boption cfig = draw cfig w
         | otherwise = mempty
 
+drawDDATest :: World -> Picture
+drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
+    <> runIdentity (S.foldMap_ (drawZone' 50) ps')
+    <> runIdentity (S.foldMap_ drawCross qs)
+    <> color blue (runIdentity (S.foldMap_ drawCross qs'))
+    <> setLayer DebugLayer (color yellow (line [cvf,mwp]))
+  where
+    cvf = _cameraViewFrom w
+    mwp = mouseWorldPos w
+    ps = ddaStreamX 50 cvf mwp
+    ps' = ddaStreamY 50 (_cameraViewFrom w) (mouseWorldPos w)
+    qs = xIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
+    qs' = yIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
+
+drawCross :: Point2 -> Picture
+drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5
+
+crossPic :: Float -> Picture
+crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
+
+drawZone :: Float -> V2 Int -> Picture
+drawZone s (V2 x y) = setLayer DebugLayer . color orange $ line (p:ps ++ [p])
+  where
+    (p:ps) = zipWith (+.+) innerSquare $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)]
+
+drawZone' :: Float -> V2 Int -> Picture
+drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p])
+  where
+    (p:ps) = zipWith (+.+) (map (2*.*) innerSquare) $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)]
+
+innerSquare :: [Point2]
+innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
+
 drawWallSearchRays :: World -> Picture
 drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w
   where