Fuse close points in pathing layout

src/Dodge/Layout.hs

@@ -51,8 +51,9 @@ generateLevelFromRoomList gr' w = initWallZoning
         & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
             (labEdges path))
   where
-    (_,path) = pairsToGraph pairPath
+    (_,path) = pairsToGraph pairPath'
     pairPath = foldMap _rmPath rs
+    pairPath' = fusePairs pairPath
     rs = map doRoomShift $ IM.elems rs'
     rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
 

src/Dodge/Path.hs

@@ -9,6 +9,7 @@ module Dodge.Path
     , getNodePos
     , walkableNodeNear
     , bfsNodePoints
+    , fusePairs
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -16,12 +17,14 @@ import Dodge.Zone
 import Geometry.Data
 import Geometry
 
+import Data.Foldable
 import Control.Lens
 import Data.Maybe
 import Data.List
 --import qualified Data.IntMap.Strict as IM
 import Data.Graph.Inductive hiding ((&))
 import qualified Data.Set as Set
+import Data.Set (Set)
 import qualified Data.Map.Strict as M
 import Data.Map.Strict (Map)
 import StreamingHelp
@@ -142,3 +145,11 @@ obstructPathsCrossing obstacletype sp' ep w =
     updateedges gr = runIdentity $ S.fold_ updateedge gr id es
     updateedge gr (x,y,pe) 
         = insEdge (x,y,pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x,y) gr
+
+fuseFunc :: (a -> a -> Bool) -> [a] -> a -> a
+fuseFunc t xs x = fromJust . find (t x) $ nubBy t xs
+
+fusePairs :: Set (Point2,Point2) -> Set (Point2,Point2)
+fusePairs ps = Set.map (bimap f f) ps
+  where
+    f = fuseFunc (\x y -> dist x y < 2) . nub $ concatMap (\(x,y) -> [x,y]) $ toList ps