【拓扑检查】多边形间缝隙

Lispboy

检查封闭多边形（地块）间有缝隙的，用标记标出来
什么是带缝隙的多边形：多边形相贴（两多边形有顶点共边，但没贴合，至少有一个顶点在另外的多边形的外部）



需要的函数XD::Curve:Relation见：http://bbs.xdcad.net/thread-719349-1-1.html

游客，如果您要查看本帖隐藏内容请回复

xudi1234

收藏一下！

gz518518

感谢分享，谢谢老铁

zhystar

谢谢，看一下

cfc123456

谢谢，看一下

evayleung

谢谢分享。。。。。。。。。。。。。。。

wzg356

顶顶顶顶顶，学学学

wzg356

这几天在处理cass地籍数据写的，另一种拓扑关系

1. <blockquote>;取得曲线顶点

复制代码

newer

wzg356 发表于 2018-12-24 18:20
这几天在处理cass地籍数据写的，另一种拓扑关系

代码呢？

liuyj

这个有用，有时候两个多边形看上去两条边是贴在一起了，其实有很小的间隙

wzg356

wzg356 发表于 2018-12-24 18:20
这几天在处理cass地籍数据写的，另一种拓扑关系

编辑误操作了，现补上代码，有些函数属本论坛收集的

2. ;取得曲线顶点
   
3. (defun vxs (e / i v lst)
   
4.     (setq i -1)
   
5.     (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
   
6.        (setq lst (cons v lst))
   
7.     )
   
8.     (reverse lst)
   
9. )
   
10. ;--------------------------
    
11. 
    
12. 
    
13. ;判断多边形pts1（叫点集较好）是否在多边形pts2（首尾点相同的不自交点集）外,返回nil则全在内
    
14. ;纯几何学判断
    
15. ;(pst1<npts2 (vxs(car (entsel)))(vxs(car (entsel))))
    
16. (defun pst1<npts2 (pts1 pts2 /  pntonline ptisorout x pt)
    
17. ;功能：判断点在直线上的位置
    
18. ;参数：p1,p2：直线上的两点，例如直线上的起点和端点,p3：所要判断的点
    
19. ;返回值：点的位置，等于0时(equal k 0.0 0.00000001)点在线上，
    
20. ;大于0时点在线的左侧，小于0时点在线的右侧
    
21. ;示例：(setq k(pntonline (getpoint) (getpoint) (getpoint)))  
    
22. (defun pntonline(p3 p1 p2 / p c B C P)
    
23.   (setq p p3)
    
24.   (apply '+ (mapcar '(lambda (b)
    
25.     (setq c(- (* (car p) (cadr b)) (* (cadr p) (car b))) p b )c )
    
26.     (list p1 p2 p3)))
    
27. )
    
28. ;判断点是否在多边形外,返回nil则不在界外
    
29. ;(ptisorout (getpoint) (vxs(car (entsel))))
    
30. (defun ptisorout (pt pts / jgls x lines)
    
31.         (while (cadr pts)
    
32.       (setq lines(cons(list (car pts)(cadr pts))lines))
    
33.       (setq pts(cdr pts))
    
34.     );多边形分解为单边
    
35.         (setq jgls(mapcar  
    
36.                 '(lambda (x)(pntonline pt (car x) (cadr x)))lines)
    
37.         )
    
38.         (vl-member-if '(lambda (x)(> x 0.00001))jgls)
    
39. )
    
40. ;--主函数就这句话------------
    
41.         (vl-remove-if '(lambda (x)(equal x nil))
    
42.                 (mapcar '(lambda (pt)(ptisorout pt pts2))pts1)
    
43.         )
    
44. )
    
45. ;-----------------------------
    
46. ;应用
    
47. ;取得多边形内线实体, 不含多边形本身，实体不超过边界就算
    
48. ;多边形范围必须在屏幕内
    
49. ; 使用(ssget "wP" <pt-list> [filter-list])时，实体挂边就选不上，故写此函数
    
50. ;(if(setq ss(ssgetpolyline (car(entsel))))(sslength ss))
    
51. (defun ssgetpolyline (en /  ss ss1  pts en1 nn)
    
52. (setq pts(vxs en))
    
53. (setq ss(ssget "CP" pts '((0 . "*polyline"))));这句可再进一步过滤，比如选地块内房屋
    
54. (setq ss1 (ssadd) nn -1)
    
55. (while (setq en1(ssname  ss (setq nn(1+ nn))))
    
56.         (if(not(equal en1 en))
    
57.                 (if(not(pst1<npts2 (vxs en1) pts))
    
58.                         (setq ss1(ssadd en1 ss1));或进行其他函数操作
    
59.                 )
    
60.         )
    
61. )(if(> (sslength ss1)1)ss1)
    
62. )

;取得曲线顶点<br /> (defun vxs (e / i v lst)<br />     (setq i -1)<br />     (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />        (setq lst (cons v lst))<br />     )<br />     (reverse lst)<br /> )<br /> ;--------------------------<br /> <br /> <br /> ;判断多边形pts1（叫点集较好）是否在多边形pts2（首尾点相同的不自交点集）外,返回nil则全在内<br /> ;纯几何学判断<br /> ;(pst1<npts2 (vxs(car (entsel)))(vxs(car (entsel))))<br /> (defun pst1<npts2 (pts1 pts2 /  pntonline ptisorout x pt)<br /> ;功能：判断点在直线上的位置<br /> ;参数：p1,p2：直线上的两点，例如直线上的起点和端点,p3：所要判断的点<br /> ;返回值：点的位置，等于0时(equal k 0.0 0.00000001)点在线上，<br /> ;大于0时点在线的左侧，小于0时点在线的右侧<br /> ;示例：(setq k(pntonline (getpoint) (getpoint) (getpoint)))  <br /> (defun pntonline(p3 p1 p2 / p c B C P) <br />   (setq p p3)<br />   (apply '+ (mapcar '(lambda (b) <br />     (setq c(- (* (car p) (cadr b)) (* (cadr p) (car b))) p b )c ) <br />     (list p1 p2 p3))) <br /> )<br /> ;判断点是否在多边形外,返回nil则不在界外<br /> ;(ptisorout (getpoint) (vxs(car (entsel))))<br /> (defun ptisorout (pt pts / jgls x lines)<br />         (while (cadr pts)<br />       (setq lines(cons(list (car pts)(cadr pts))lines))<br />       (setq pts(cdr pts))<br />     );多边形分解为单边<br />         (setq jgls(mapcar  <br />                 '(lambda (x)(pntonline pt (car x) (cadr x)))lines)<br />         )<br />         (vl-member-if '(lambda (x)(> x 0.00001))jgls)<br /> )<br /> ;--主函数就这句话------------<br />         (vl-remove-if '(lambda (x)(equal x nil))<br />                 (mapcar '(lambda (pt)(ptisorout pt pts2))pts1)<br />         )<br /> )<br /> ;-----------------------------<br /> ;应用<br /> ;取得多边形内线实体, 不含多边形本身，实体不超过边界就算<br /> ;多边形范围必须在屏幕内<br /> ; 使用(ssget "wP" <pt-list> [filter-list])时，实体挂边就选不上，故写此函数<br /> ;(if(setq ss(ssgetpolyline (car(entsel))))(sslength ss))<br /> (defun ssgetpolyline (en /  ss ss1  pts en1 nn)<br /> (setq pts(vxs en))<br /> (setq ss(ssget "CP" pts '((0 . "*polyline"))));这句可再进一步过滤，比如选地块内房屋<br /> (setq ss1 (ssadd) nn -1)<br /> (while (setq en1(ssname  ss (setq nn(1+ nn))))<br />         (if(not(equal en1 en))<br />                 (if(not(pst1<npts2 (vxs en1) pts))<br />                         (setq ss1(ssadd en1 ss1));或进行其他函数操作<br />                 )<br />         )<br /> )(if(> (sslength ss1)1)ss1)<br /> )

wzg356

newer 发表于 2018-12-24 18:48
代码呢？

误操作了，已补上。

Lisphk

wzg356 发表于 2018-12-24 22:26
编辑误操作了，现补上代码，有些函数属本论坛收集的

谢谢分享，都有什么拓扑关系处理？

wzg356

Lisphk 发表于 2018-12-24 22:55
谢谢分享，都有什么拓扑关系处理？

这期间地籍工作，需要对宗地内房屋添加宗地的一些属性，或者把房屋的一些信息写入宗地扩展属性，目的是根据宗地选房屋。只是拓扑判断，扩展一下可判断房屋或地物是否超出宗地边界（这种情况要处理的）。

gstwsjy06

真真的好东西，谢谢搂主分享