【Gu_xl】基于方位角计算的拓扑多边形自动构建快速算法

tanjurun

万能的楼主啊，为何要设门槛呢

tanjurun

还差好远啊，怎么办呢

gamexia

如果图中含封闭图形，必须炸开，才能选择

chshsl

G版主，太经典了，下载学习，我有个类似的问题需要解决。

chshsl

经过2天的研究G大侠的代码及网盘函数库，复原了，所缺的几个函数，见大家都希望补全，现贴上。希望G大侠不要见怪。用法：1楼中的 辅助函数+8楼代码+本代码。

2. ;命令: (gxl-massoc 10 (entget (car (entsel "选择多段线：")))) 选择多段线：((35846.5 18949.5)
   
3. ;(36264.4 18956.0) (36617.2 18954.3))
   
4. ;
   
5. 
   
6. (defun gxl-massoc ( d li /  a  ls )
   
7.         (setq ls '())
   
8.         (while (assoc d li)
   
9.                 (progn
   
10.                         (setq  a (assoc d li))
    
11.                         (setq ls (cons (list (cadr a) (caddr a)) ls))
    
12.                         (setq li (xdlsp_list_remove li  a))
    
13.                 )
    
14.         )
    
15.         (reverse ls)
    
16. )
    
17. 
    
18. (defun xdlsp_list_remove (el val)
    
19.   (if (member val el)
    
20.     (append
    
21.       (reverse (cdr (member val (reverse el))))
    
22.       (cdr (member val el))
    
23.     )
    
24.     el
    
25.   )
    
26. )
    
27. 
    
28. ;输出50个空格
    
29. ;(gxl-Str-Space 50) "                                                  "
    
30. ;(gxl-Str-Space -1)
    
31. (defun gxl-Str-Space ( d  /  a )
    
32.     (setq a "")
    
33.         (if (>  d 0)
    
34.                 (repeat d
    
35.                   (setq a (strcat a " " ))
    
36.                  )
    
37.         )
    
38.         a
    
39. )
    
40. 
    
41. ;删除表中重复项
    
42. (defun gxl-ListDumpAtom( l1 /  l2)
    
43. (while(setq l2(cons(car l1)l2) l1(vl-remove(car l1)(cdr l1))))
    
44. (reverse l2)
    
45. )
    
46. ;;主测试函数
    
47. 
    
48. ;;;测试
    
49. (defun c:mkpoly2 ()
    
50.   ;;(setundoerr)
    
51.   (princ "\n自动拓扑多边形测试！编制：Gu_xl 2010年8月")
    
52.   (princ "\n选择线段：")
    
53.   ;;;选择的线段必须已经做完打断预处理，请自行添加处理代码
    
54.   ;(if (not jd) (setq jd 0.00001))
    
55.   (setq jd 0.00001)
    
56.   (setq ss (ssget '((0 . "line,arc"))))
    
57.   (setq t1 (getvar "cdate"))
    
58.   (setq ssl (GXL-SEL-SS->LIST ss))
    
59.   (setq nod1 (gxl-ent->Nodes ssl jd))
    
60.   (setq coordlist (gxl-ent->Coordinates  (car nod1)))
    
61.   (setq touplist (gxl-Toupu-LineList coordlist))
    
62.   (setq polylist (gxl-MakePolyList touplist coordlist  (cadr nod1)))
    
63.   (setq polylist (gxl-dumpPolyTouPuList polylist))
    
64.   (setq n 1)
    
65.   (foreach poly polylist
    
66.     (setq enlist (mapcar '(lambda (x) (nth (1- (abs x)) ssl)) poly)
    
67.   enss (GXL-SEL-LIST->SS enlist)
    
68.   )
    
69.     (setq en (entlast))
    
70.     (command "copy" enss "" '(0 0 0) '(0 0 0))
    
71.     (setq enss (GXL-SEL-ENTNEXTALL en))
    
72.     (command "pedit" (ssname enss 0) "y" "j" enss "" "")
    
73.     (setq en (entlast))
    
74.     (gxl-CH_Ent en 62 1)
    
75.     (gxl-CH_Ent en 8 "多边形层")
    
76.     )
    
77.   (princ "\n总计 ")
    
78.   (GXL-SYS-TIMEOUT t1)
    
79.   (princ "\n共生成 ")
    
80.   (princ (length polylist))
    
81.   (princ " 个多边形！")
    
82.   ;(reerr)
    
83.   )

;命令: (gxl-massoc 10 (entget (car (entsel "选择多段线：")))) 选择多段线：((35846.5 18949.5) <br /> ;(36264.4 18956.0) (36617.2 18954.3))<br /> ;<br /> <br /> (defun gxl-massoc ( d li /  a  ls )<br />         (setq ls '())<br />         (while (assoc d li)<br />                 (progn <br />                         (setq  a (assoc d li))<br />                         (setq ls (cons (list (cadr a) (caddr a)) ls))<br />                         (setq li (xdlsp_list_remove li  a))<br />                 )<br />         )<br />         (reverse ls)<br /> )<br /> <br /> (defun xdlsp_list_remove (el val)<br />   (if (member val el)<br />     (append<br />       (reverse (cdr (member val (reverse el))))<br />       (cdr (member val el))<br />     )<br />     el<br />   )<br /> )<br /> <br /> ;输出50个空格<br /> ;(gxl-Str-Space 50) "                                                  "<br /> ;(gxl-Str-Space -1)<br /> (defun gxl-Str-Space ( d  /  a )<br />     (setq a "")<br />         (if (>  d 0)<br />                 (repeat d<br />                   (setq a (strcat a " " ))<br />                  )<br />         )<br />         a<br /> )<br /> <br /> ;删除表中重复项<br /> (defun gxl-ListDumpAtom( l1 /  l2)<br /> (while(setq l2(cons(car l1)l2) l1(vl-remove(car l1)(cdr l1))))<br /> (reverse l2)<br /> )<br /> ;;主测试函数<br /> <br /> ;;;测试<br /> (defun c:mkpoly2 ()<br />   ;;(setundoerr)<br />   (princ "\n自动拓扑多边形测试！编制：Gu_xl 2010年8月")<br />   (princ "\n选择线段：")<br />   ;;;选择的线段必须已经做完打断预处理，请自行添加处理代码<br />   ;(if (not jd) (setq jd 0.00001))<br />   (setq jd 0.00001)<br />   (setq ss (ssget '((0 . "line,arc"))))<br />   (setq t1 (getvar "cdate"))<br />   (setq ssl (GXL-SEL-SS->LIST ss))<br />   (setq nod1 (gxl-ent->Nodes ssl jd))<br />   (setq coordlist (gxl-ent->Coordinates  (car nod1)))<br />   (setq touplist (gxl-Toupu-LineList coordlist))<br />   (setq polylist (gxl-MakePolyList touplist coordlist  (cadr nod1)))<br />   (setq polylist (gxl-dumpPolyTouPuList polylist))<br />   (setq n 1)<br />   (foreach poly polylist<br />     (setq enlist (mapcar '(lambda (x) (nth (1- (abs x)) ssl)) poly)<br />   enss (GXL-SEL-LIST->SS enlist)<br />   )<br />     (setq en (entlast))<br />     (command "copy" enss "" '(0 0 0) '(0 0 0))<br />     (setq enss (GXL-SEL-ENTNEXTALL en))<br />     (command "pedit" (ssname enss 0) "y" "j" enss "" "")<br />     (setq en (entlast))<br />     (gxl-CH_Ent en 62 1)<br />     (gxl-CH_Ent en 8 "多边形层")<br />     )<br />   (princ "\n总计 ")<br />   (GXL-SYS-TIMEOUT t1)<br />   (princ "\n共生成 ")<br />   (princ (length polylist))<br />   (princ " 个多边形！")<br />   ;(reerr)<br />   )

chshsl

大侠们，G版主的这个代码，在CAD2008 32位 win7 64位下可以运行，CAD2004 XP下不能运行。求帮助。

479274135

学习学习

li809

过来学习学习。

caizeping

这个真牛

zfcdage

期待版主公布更多的源码！不太懂的版友们是要自己不断拿源码调试修改才能变成自己的。或者说这个就是模仿过程。我也知道大概的原理楼主已经公布了。对于不够精的版友来说，差一点不会就不会。差之毫厘失之千里。当然也尊重楼主的知识产权，如果不方便也非常能理解！