Refactor wall fusing

This commit is contained in:
2021-08-13 12:56:09 +02:00
parent 501a1cea86
commit 3192ae628f
+11 -9
View File
@@ -198,23 +198,25 @@ pointIfNotClose ps p = case findClosePoint ps p of
Nothing -> Just p Nothing -> Just p
_ -> Nothing _ -> Nothing
-- | Fuses a point with one in a list if any are close enough. -- | Fuses a point with one in a list if any are close enough.
fusePoint :: [Point2] -> Point2 -> Point2 fusePoint :: [Point2] -> Point2 -> ([Point2],Point2)
fusePoint ps p = fromMaybe p $ findClosePoint ps p fusePoint ps p = case findClosePoint ps p of
Just q -> (ps,q)
Nothing -> (p:ps,p)
-- | Given a list of points and wall, moves the wall to be on the points if it is -- | Given a list of points and wall, moves the wall to be on the points if it is
-- close to any of the points. -- close to any of the points.
-- If either wall point is not moved, this point gets added to the list. -- If either wall point is not moved, this point gets added to the list.
fuseWall :: ([Point2], WallP) -> ([Point2], WallP) fuseWall :: [Point2] -> WallP -> ([Point2], WallP)
fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') ) fuseWall ps (x,y) = ( rs , (x',y') )
where where
x' = fusePoint ps x (qs,y') = fusePoint ps y
y' = fusePoint (x':ps) y (rs,x') = fusePoint qs x
-- | Given list of points and collection of walls, fuses the wall ends if -- | Given list of points and collection of walls, fuses the wall ends if
-- they are close to the list of points or each other. -- they are close to the list of points or each other.
fuseWallsWith :: [Point2] -> [WallP] -> [WallP] fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws fuseWallsWith zs ws = snd $ foldr fuseWalls (zs, []) ws
where where
fuseWalls' w (ps, ws') = fuseWalls w (ps, ws') =
let (qs, w') = fuseWall (ps, w) let (qs, w') = fuseWall ps w
in (qs, w' : ws') in (qs, w' : ws')
-- | Test if fst p == snd p. -- | Test if fst p == snd p.
wallIsZeroLength :: Eq a => (a,a) -> Bool wallIsZeroLength :: Eq a => (a,a) -> Bool