diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index ef77d34fa..e04dd17af 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -50,7 +50,7 @@ generateLevelFromRoomList gr' w = where (_, path) = pairsToGraph pairPath' pairPath = foldMap _rmPath rs - pairPath' = fusePairs pairPath + pairPath' = snapToGrid pairPath rs = map doRoomShift $ IM.elems rs' rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 5aef47e6a..d904397bf 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -9,7 +9,7 @@ module Dodge.Path ( getNodePos, walkableNodeNear, bfsNodePoints, - fusePairs, + snapToGrid, ) where import Data.Set (Set) @@ -17,7 +17,6 @@ import qualified Data.Set as Set import Control.Lens import Data.Foldable import Data.Graph.Inductive hiding ((&)) -import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe @@ -29,7 +28,6 @@ import Geometry import Data.Bifunctor getNodePos :: Int -> World -> Maybe Point2 ---getNodePos i w = _pathGraph (_cWorld w) `lab` i getNodePos i w = (w ^. cWorld . pathGraph) `lab` i makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] @@ -147,10 +145,8 @@ obstructPathsCrossing obstacletype sp' ep w = updateedge gr (PathEdgeNodes 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 +snapToGrid :: Set (Point2,Point2) -> Set (Point2, Point2) +snapToGrid = Set.map (over each (fmap (fromIntegral . f))) where - f = fuseFunc (\x y -> dist x y < 2) . nub $ concatMap (\(x, y) -> [x, y]) $ toList ps + f :: Float -> Int + f = round