Fix tile drawing bug

src/Dodge/Graph.hs

@@ -4,6 +4,7 @@ module Dodge.Graph
     , incidenceToFunction
     , pairsToIncidence
     , graphToEdges
+    , graphToIncidence
     ) where
 -- this deserves tests
 import Data.List.Extra
@@ -34,3 +35,8 @@ graphToEdges :: forall a b . F.Gr a b -> [(a,a)]
 graphToEdges g = map (bimap f f) $ F.edges g
   where
     f n = fromJust . lookup n $ F.labNodes g
+
+graphToIncidence :: forall a b . F.Gr a b -> [(a,Int)]
+graphToIncidence g = map f $ F.labNodes g
+  where
+    f (n,p) = (p,length $ F.neighbors g n)

src/Dodge/Layout.hs

@@ -128,7 +128,7 @@ gameRoomsFromRooms = map f
         , _grDir   = snd . last $ _rmLinks rm
         , _grName  = _rmName rm
         }
-    closePoints x y = dist x y < 1
+    closePoints x y = roundPoint2 x == roundPoint2 y
 
 floorsFromRooms :: [Room] -> [(Point3,Point3)]
 floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)

src/Dodge/Render/Picture.hs

@@ -70,15 +70,17 @@ customMouseCursor w =
 
 testPic :: World -> Picture
 testPic _ = []
---  where
---    thepic = setDepth 20 . color green . polygon $ rectNSEW 5 (-5) (-5) (5)
---testPic _ = blank
---testPic w = 
+
 drawPathing :: World -> Picture
 drawPathing w
     | _debug_pathing (_config w) 
-        = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
+        = -- setLayer 5 $ 
+        (color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr)
+        <> concatMap dispInc (graphToIncidence gr)
     | otherwise = []
+  where
+    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
+    gr = _pathGraph w
 viewBoundaries :: World -> Picture
 viewBoundaries w
     | _debug_view_boundaries (_config w) 

src/Dodge/Room/AddTile.hs

@@ -5,6 +5,8 @@ import Tile
 import Geometry
 
 import Control.Lens
+import Data.List
+import Data.Function
 
 addTile :: Float -> Room -> Room
 addTile z r
@@ -12,4 +14,4 @@ addTile z r
     | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
   where
     rp = _rmPolys r
-    poly = orderPolygon . convexHull $ concat rp
+    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp

src/Dodge/Room/Procedural.hs

@@ -75,14 +75,20 @@ combineRooms :: Room -> Room -> Room
 combineRooms r r' = defaultRoom
     { _rmPolys = _rmPolys r ++ _rmPolys r'
     , _rmLinks = _rmLinks r ++ _rmLinks r'
-    , _rmPath  = (_rmPath  r )
-              ++ (_rmPath  r')
+    , _rmPath  = map clampPath $ _rmPath  r 
+              ++ _rmPath  r'
     , _rmPS    = map (shiftPlacement $ _rmShift r)  (_rmPS r) 
               ++ map (shiftPlacement $ _rmShift r') (_rmPS r')
     , _rmBound = _rmBound r ++ _rmBound r'
     , _rmFloor = _rmFloor r ++ _rmFloor r'
     , _rmShift  = (V2 0 0 , 0)
     }
+-- not that this assumes that any link paths are integral
+clampPath :: (Point2,Point2) -> (Point2, Point2)
+clampPath = bimap f f
+  where
+    f (V2 x y) = V2 (g x) (g y)
+    g = (fromIntegral :: Int -> Float) . floor
 {- Randomly generate a top fourth of a room possibly with a wall.
 Add a light and a 'PutNothing' placement.  -}
 quarterRoomFlat :: RandomGen g => Float -> State g Room