Fix bugs in zones near segments

src/Dodge/Zoning/Base.hs

@@ -11,6 +11,8 @@ module Dodge.Zoning.Base
     , zoneOfCirc
     , zonesAroundPoint
     , xIntercepts
+    , xIntercepts'
+    , yIntercepts'
     , yIntercepts
     , updateInt2Map
     ) where
@@ -48,7 +50,8 @@ zoneOfPoint = fmap . divTo
 
 zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
 {-# INLINE zoneOfSeg #-}
-zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
+--zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
+zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep)
 
 zoneOfSegSet :: Float -> Point2 -> Point2 -> S.Set Int2
 {-# INLINE zoneOfSegSet #-}
@@ -79,12 +82,30 @@ xIntercepts s (V2 sx sy) (V2 ex ey)
         | xdx < 0 = sx - modTo s sx
         | otherwise = s + sx - modTo s sx
 
+xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE xIntercepts' #-}
+xIntercepts' s (V2 sx sy) (V2 ex ey) 
+    | divTo s sx == divTo s ex = []
+    | otherwise = g <$> [a, a + s .. b]
+  where
+    (a,b) | sx < ex = (ceilingTo s sx,floorTo s ex)
+          | otherwise = (ceilingTo s ex,floorTo s sx)
+    g x = V2 (h + x) (f x)
+    h = 0.5 * s * signum (ex - sx)
+    f x = sy + (x - sx) * (ey - sy) / (ex - sx)
+
 yIntercepts :: Float -> Point2 -> Point2 -> [Point2]
 {-# INLINE yIntercepts #-}
 yIntercepts s sp ep = map f $ xIntercepts s (f sp) (f ep)
   where
     f (V2 x y) = V2 y x
 
+yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE yIntercepts' #-}
+yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep)
+  where
+    f (V2 x y) = V2 y x
+
 -- consider using: at x . non mempty . at y . non mempty <>~ a
 zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
 {-# INLINE zoneMonoid #-}