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

Gu_xl

源码:

游客，本帖隐藏的内容需要发帖数高于 20 才可浏览，你当前发帖数只有 0

一些程序用到的函数

2. 
   
3. ;;;==================================================================
   
4. ;;;(gxl-Sys-TimeOut t1) 耗尽用时计算函数
   
5. ;;;==================================================================
   
6. (defun gxl-Sys-TimeOut (t1 / t2 t3 t4 t5 t6 t7 t8)
   
7. (setq t2 (getvar "Cdate"))
   
8. (setq t3 t1)
   
9. (setq t4 (fix (* 100 t3))
   
10. t5 (- (fix (* 10000 t3)) (* t4 100))
    
11. t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))
    
12. t7 (+ (* t4 3600) (* t5 60) t6)
    
13. )
    
14. (setq t3 t2)
    
15. (setq t4 (fix (* 100 t3))
    
16. t5 (- (fix (* 10000 t3)) (* t4 100))
    
17. t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))
    
18. t8 (+ (* t4 3600) (* t5 60) t6)
    
19. )
    
20. (princ "\n 用时 ")
    
21. (princ (- t8 t7))
    
22. (princ " 秒 ")
    
23. (princ)
    
24. )
    
25. ;;;================================================================================================
    
26. ;;; 进程条初始化 (gxl-Sys-Progress-Init 提示 进程总数)
    
27. ;;; 进程步进 (gxl-Sys-Progress 进程总数 -1)
    
28. ;;; 进程结束 (gxl-Sys-Progress-Done)
    
29. (setq *ProgressID* 0
    
30. *ProgressPrompt* ""
    
31. *ProgressBFB* " 0%")
    
32. 
    
33. (defun gxl-Sys-Progress-Init (str to)
    
34. (if *FlagINIT* (alert "上一次进程条没有结束！"))
    
35. (setq *ProgressID* 0
    
36. *ProgressTo* to
    
37. *ProgressPrompt* str
    
38. *ProgressBFB* 2
    
39. *FlagINIT* T)
    
40. )
    
41. (defun gxl-Sys-Progress-Done ()
    
42. (setq *ProgressID* 0
    
43. *ProgressTo* nil
    
44. *ProgressPrompt* ""
    
45. *ProgressBFB* 2
    
46. *FlagINIT* nil)
    
47. (setvar "modemacro" "")
    
48. )
    
49. 
    
50. ;;;进程条函数,to 为进程总数，i为已到达进程数
    
51. ;;;第一次使用 i应为1，以后 i = -1 为步进数，也可以为已到达进程数
    
52. 
    
53. (defun gxl-Sys-Progress (to i / CS_TEXT MYI bfb corstate LL)
    
54. ;(setq cs_text ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>")
    
55. ;(setq corstate (getvar "coords"))
    
56. ;(setvar "coords" 0)
    
57. ;(setq cs_text "||||||||||||||||||||||||||||||"
    
58. ; LL (strlen cs_text)
    
59. (if (and *FlagINIT* *ProgressTo*)
    
60. (setq to *ProgressTo*)
    
61. )
    
62. (setq cs_text "████████████████████"
    
63. LL (strlen cs_text)
    
64. )
    
65. (if (= -1 i)
    
66. (setq i (1+ *ProgressID*)
    
67. *ProgressID* i
    
68. )
    
69. (setq *ProgressID* i)
    
70. )
    
71. (if (> i to)
    
72. (setq i to)
    
73. )
    
74. (setq myi (fix (/ (* (strlen cs_text) i) to))
    
75. myi (* 2 (/ myi 2))
    
76. )
    
77. (if (= 0 myi)
    
78. (setq myi 2)
    
79. )
    
80. (if (/= *ProgressBFB* myi)
    
81. (progn
    
82. (setq
    
83. cs_text (substr cs_text 1 myi)
    
84. cs_text (strcat cs_text (gxl-Str-Space (- LL myi)))
    
85. )
    
86. 
    
87. (setq bfb (fix (* 100 i (/ 1.0 to))))
    
88. (setq bfb (itoa bfb))
    
89. (cond
    
90. ((= 1 (strlen bfb))
    
91. (setq bfb (strcat " " bfb "% "))
    
92. )
    
93. ((= 2 (strlen bfb)) (setq bfb (strcat " " bfb "% ")))
    
94. ((= 3 (strlen bfb)) (setq bfb (strcat bfb "% ")))
    
95. )
    
96. ;(grtext -1 (strcat "已完成" cs_text bfb))
    
97. (setvar "modemacro"
    
98. (strcat *ProgressPrompt*
    
99. "已完成"
    
100. cs_text
     
101. bfb
     
102. )
     
103. )
     
104. (setq *ProgressBFB* myi)
     
105. 
     
106. )
     
107. (if (= 2 myi)
     
108. (progn
     
109. (setvar "modemacro"
     
110. (strcat *ProgressPrompt*
     
111. "已完成"
     
112. "| "
     
113. "1%"
     
114. )
     
115. )
     
116. ) ;progn
     
117. ) ;if
     
118. )
     
119. ;(setvar "coords" corstate)
     
120. )
     
121. ;;;gxl-Sel-EntNextAll en 返回 en 之后的所有物体选择集，无则返回 nil
     
122. (defun gxl-Sel-EntNextAll (ent / ss ent1)
     
123. (setq ss (ssadd))
     
124. (while (setq ent1 (entnext ent))
     
125. (ssadd ent1 ss)
     
126. (setq ent ent1)
     
127. )
     
128. (if (= 0 (sslength ss))
     
129. nil
     
130. ss
     
131. )
     
132. )
     
133. ;;;选择集转为图元列表
     
134. (defun gxl-Sel-SS->List (ss / cs_i out)
     
135. (if (= (type ss) 'PICKSET)
     
136. (progn
     
137. (setq cs_i 0.0
     
138. out '()
     
139. )
     
140. (repeat (sslength ss)
     
141. (setq out (cons (ssname ss cs_i) out))
     
142. (setq cs_i (1+ cs_i))
     
143. )
     
144. (setq out (reverse out))
     
145. )
     
146. )
     
147. )
     
148. (defun gxl-Sel-List->SS (Lst / en ss)
     
149. (setq ss (ssadd)
     
150. kk 0)
     
151. (foreach en Lst
     
152. (ssadd en ss)
     
153. (setq kk (1+ kk))
     
154. )
     
155. ss
     
156. )
     
157. ;;;==================================================================
     
158. ;;;(gxl-dxf ent i )取出图元索引i对应的值
     
159. ;;;==================================================================
     
160. (defun gxl-dxf (ent i)
     
161. (if (= (type ent) 'ename)
     
162. (setq ent (entget ent))
     
163. )
     
164. (cdr (assoc i ent))
     
165. 
     
166. )
     
167. ;;;==================================================================
     
168. ;;;(gxl-CH_Ent ent i pt) 用新值pt更新图元ent索引i对应的值
     
169. ;;;==================================================================
     
170. (defun gxl-CH_Ent (ent i pt / en)
     
171. (if (assoc i (setq en (entget ent)))
     
172. (setq en (subst (cons i pt) (assoc i en) en))
     
173. (setq en (append en (list (cons i pt))))
     
174. )
     
175. (entmod en)
     
176. )
     
177. 
     

<br /> ;;;==================================================================<br /> ;;;(gxl-Sys-TimeOut t1) 耗尽用时计算函数<br /> ;;;==================================================================<br /> (defun gxl-Sys-TimeOut (t1 / t2 t3 t4 t5 t6 t7 t8)<br /> (setq t2 (getvar "Cdate"))<br /> (setq t3 t1)<br /> (setq t4 (fix (* 100 t3))<br /> t5 (- (fix (* 10000 t3)) (* t4 100))<br /> t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))<br /> t7 (+ (* t4 3600) (* t5 60) t6)<br /> )<br /> (setq t3 t2)<br /> (setq t4 (fix (* 100 t3))<br /> t5 (- (fix (* 10000 t3)) (* t4 100))<br /> t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))<br /> t8 (+ (* t4 3600) (* t5 60) t6)<br /> )<br /> (princ "\n 用时 ")<br /> (princ (- t8 t7))<br /> (princ " 秒 ")<br /> (princ)<br /> )<br /> ;;;================================================================================================<br /> ;;; 进程条初始化 (gxl-Sys-Progress-Init 提示 进程总数)<br /> ;;; 进程步进 (gxl-Sys-Progress 进程总数 -1)<br /> ;;; 进程结束 (gxl-Sys-Progress-Done)<br /> (setq *ProgressID* 0<br /> *ProgressPrompt* ""<br /> *ProgressBFB* " 0%")<br /> <br /> (defun gxl-Sys-Progress-Init (str to)<br /> (if *FlagINIT* (alert "上一次进程条没有结束！"))<br /> (setq *ProgressID* 0<br /> *ProgressTo* to<br /> *ProgressPrompt* str<br /> *ProgressBFB* 2<br /> *FlagINIT* T)<br /> )<br /> (defun gxl-Sys-Progress-Done ()<br /> (setq *ProgressID* 0<br /> *ProgressTo* nil<br /> *ProgressPrompt* ""<br /> *ProgressBFB* 2<br /> *FlagINIT* nil)<br /> (setvar "modemacro" "")<br /> )<br /> <br /> ;;;进程条函数,to 为进程总数，i为已到达进程数<br /> ;;;第一次使用 i应为1，以后 i = -1 为步进数，也可以为已到达进程数<br /> <br /> (defun gxl-Sys-Progress (to i / CS_TEXT MYI bfb corstate LL)<br /> ;(setq cs_text ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>")<br /> ;(setq corstate (getvar "coords"))<br /> ;(setvar "coords" 0)<br /> ;(setq cs_text "||||||||||||||||||||||||||||||"<br /> ; LL (strlen cs_text)<br /> (if (and *FlagINIT* *ProgressTo*)<br /> (setq to *ProgressTo*)<br /> )<br /> (setq cs_text "████████████████████"<br /> LL (strlen cs_text)<br /> )<br /> (if (= -1 i)<br /> (setq i (1+ *ProgressID*)<br /> *ProgressID* i<br /> )<br /> (setq *ProgressID* i)<br /> )<br /> (if (> i to)<br /> (setq i to)<br /> )<br /> (setq myi (fix (/ (* (strlen cs_text) i) to))<br /> myi (* 2 (/ myi 2))<br /> )<br /> (if (= 0 myi)<br /> (setq myi 2)<br /> )<br /> (if (/= *ProgressBFB* myi)<br /> (progn<br /> (setq<br /> cs_text (substr cs_text 1 myi)<br /> cs_text (strcat cs_text (gxl-Str-Space (- LL myi)))<br /> )<br /> <br /> (setq bfb (fix (* 100 i (/ 1.0 to))))<br /> (setq bfb (itoa bfb))<br /> (cond<br /> ((= 1 (strlen bfb))<br /> (setq bfb (strcat " " bfb "% "))<br /> )<br /> ((= 2 (strlen bfb)) (setq bfb (strcat " " bfb "% ")))<br /> ((= 3 (strlen bfb)) (setq bfb (strcat bfb "% ")))<br /> )<br /> ;(grtext -1 (strcat "已完成" cs_text bfb))<br /> (setvar "modemacro"<br /> (strcat *ProgressPrompt*<br /> "已完成"<br /> cs_text<br /> bfb<br /> )<br /> )<br /> (setq *ProgressBFB* myi)<br /> <br /> )<br /> (if (= 2 myi)<br /> (progn<br /> (setvar "modemacro"<br /> (strcat *ProgressPrompt*<br /> "已完成"<br /> "| "<br /> "1%"<br /> )<br /> )<br /> ) ;progn<br /> ) ;if<br /> )<br /> ;(setvar "coords" corstate)<br /> )<br /> ;;;gxl-Sel-EntNextAll en 返回 en 之后的所有物体选择集，无则返回 nil<br /> (defun gxl-Sel-EntNextAll (ent / ss ent1)<br /> (setq ss (ssadd))<br /> (while (setq ent1 (entnext ent))<br /> (ssadd ent1 ss)<br /> (setq ent ent1)<br /> )<br /> (if (= 0 (sslength ss))<br /> nil<br /> ss<br /> )<br /> )<br /> ;;;选择集转为图元列表<br /> (defun gxl-Sel-SS->List (ss / cs_i out)<br /> (if (= (type ss) 'PICKSET)<br /> (progn<br /> (setq cs_i 0.0<br /> out '()<br /> )<br /> (repeat (sslength ss)<br /> (setq out (cons (ssname ss cs_i) out))<br /> (setq cs_i (1+ cs_i))<br /> )<br /> (setq out (reverse out))<br /> )<br /> )<br /> )<br /> (defun gxl-Sel-List->SS (Lst / en ss)<br /> (setq ss (ssadd)<br /> kk 0)<br /> (foreach en Lst<br /> (ssadd en ss)<br /> (setq kk (1+ kk))<br /> )<br /> ss<br /> )<br /> ;;;==================================================================<br /> ;;;(gxl-dxf ent i )取出图元索引i对应的值<br /> ;;;==================================================================<br /> (defun gxl-dxf (ent i)<br /> (if (= (type ent) 'ename) <br /> (setq ent (entget ent))<br /> )<br /> (cdr (assoc i ent))<br /> <br /> )<br /> ;;;==================================================================<br /> ;;;(gxl-CH_Ent ent i pt) 用新值pt更新图元ent索引i对应的值<br /> ;;;==================================================================<br /> (defun gxl-CH_Ent (ent i pt / en)<br /> (if (assoc i (setq en (entget ent)))<br /> (setq en (subst (cons i pt) (assoc i en) en))<br /> (setq en (append en (list (cons i pt))))<br /> )<br /> (entmod en)<br /> )<br /> <br />

程序构建拓扑邻接表运行速度较慢，是按照选择边数的n次方来运算，如果有人感兴趣的话，我会将优化后的代码发上来，并详细说明优化思路，优化后运行速度与边数成线性关系！ 测试命令：mkpoly
附件已更新，支持椭圆、spline！2011年1月27日

flowerson

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

chshsl

;;;==================================================================
;;;(gxl-dxf ent i )取出图元索引i对应的值
;;;==================================================================
(defun gxl-dxf (ent i)
(if (= (type ent) 'ename)
(setq ent (entget ent))
)
(cdr (assoc i ent))

)
;;;==================================================================
;;;(gxl-CH_Ent ent i pt) 用新值pt更新图元ent索引i对应的值
;;;==================================================================
(defun gxl-CH_Ent (ent i pt / en)
(if (assoc i (setq en (entget ent)))
(setq en (subst (cons i pt) (assoc i en) en))
(setq en (append en (list (cons i pt))))
)
(entmod en)
)
;;删除表中第N个元素

(defun gxl-removeNth (index lst / c rtn lst1)
  (if (>= index  (length lst)) ;_ index 越界
    lst
  (if (< index (/ (length lst) 2)) ;_ index位于前半截
    (progn
  (setq c -1 lst1 lst)
  (vl-some '(lambda (x) (if (equal index (setq c (1+ c))) t (progn (setq rtn (cons x rtn) lst1 (cdr lst1)) nil))) lst)
  (append (reverse rtn) (cdr lst1))
  )
    (progn ;_ index位于后半截
      (setq index (- (length lst) index 1) lst (reverse lst))
        (setq c -1 lst1 lst)
  (vl-some '(lambda (x) (if (equal index (setq c (1+ c))) t (progn (setq rtn (cons x rtn) lst1 (cdr lst1)) nil))) lst)
  (reverse (append (reverse rtn) (cdr lst1)))
      )
    )
    )
)


(defun gxl-massoc( d li /  a  ls )
        (setq ls '())
        (while (assoc d li)
                (progn
                        (setq  a (assoc d li))
                        (setq ls (cons (list (cadr a) (caddr a)) ls))
                        (setq li (xdlsp_list_remove li  a))
                )
        )
        (reverse ls)
)

;输出50个空格
;(gxl-Str-Space 50) "                                                  "
;(gxl-Str-Space -1)
(defun gxl-Str-Space ( d  /  a )
    (setq a "")
        (if (>  d 0)
                (repeat d
                  (setq a (strcat a " " ))
                 )
        )
        a
)

;删除表中重复项
(defun gxl-ListDumpAtom( l1 /  l2)
(while(setq l2(cons(car l1)l2) l1(vl-remove(car l1)(cdr l1))))
(reverse l2)
)

;; 曲线一点的切线方向的角度
;;示例(HH:PtFirstAngle (car (entsel)) (getpoint))
(defun gxl-GetCurveTangent (obj pt)
  (setq param (vlax-curve-getParamAtPoint obj pt))
  (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param)))
)
;;常用变量
(setq
      pi2           (* pi 0.5)
      pi4           (* pi 0.25)
      2pi           (* pi 2.)
      3pi2           (* 1.5 pi)
      3pi4   (+ pi2 pi4)
      5pi4   (+ pi pi4)
      7pi4 (+ 3pi2 pi4)
      #ZJWS# 2
      *jd* 0.00001
)

这次应该是齐了，因为我这里运行已经没问题了。

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 />   )

danxingpen

虽然看不懂但觉得一定会有用途，先收藏，以后慢慢看!

highflybird

好帖啊，板凳欣赏中。。。

Gu_xl

动画演示

 

danxingpen

好像是要编辑，，，然后点上传附件，，，，

caddog

下了MKPOLY.RAR，为什么加载后提示“mkpoly 未知命令“MKPOLY”。按 F1 查看帮助。”呢？

Gu_xl

自己定义如下函数试试

2. 
   
3. (defun c:mkpoly ()
   
4.   (SETUNDOERR)
   
5.    (if (not *jd*) (setq *jd* 0.00001))
   
6.   (princ "\n基于方位角计算的拓扑多边形自动构建快速算法测试")
   
7.   (princ "\n****程序作者：Gu_xl 2010年8月****")
   
8.   (princ "\n选择直线、圆弧、圆：")
   
9.   (setq ss (ssget '((0 . "line,arc,circle"))))
   
10.   (gxl-makepoly ss)
    
11.   (reerr)
    
12.   )
    
13. 
    

<br /> (defun c:mkpoly ()<br />   (SETUNDOERR)<br />    (if (not *jd*) (setq *jd* 0.00001))<br />   (princ "\n基于方位角计算的拓扑多边形自动构建快速算法测试")<br />   (princ "\n****程序作者：Gu_xl 2010年8月****")<br />   (princ "\n选择直线、圆弧、圆：")<br />   (setq ss (ssget '((0 . "line,arc,circle"))))<br />   (gxl-makepoly ss)<br />   (reerr)<br />   )<br /> <br />

Gu_xl

优化算法后的代码：

1. ;|为了提高程序构建多边形的运行速度，需要对程序的数据结构和计算方法进行优化，下面我逐步详解我程序的思路：
   
2. 1、根据处理后的直线、圆弧选择集生成的图元列表entList，数据结构：(图元名 图元名 ...),建立图元和各图元之间的节点对应关系数据表，
   
3. 数据结构：'((图元名 起点的节点编号 端点的节点编号)...)，表中图元名的排序和表entList的顺序一致，再建立节点和坐标数据对应表，
   
4. 数据结构：'((节点编号 坐标)...),这样方便后面构建拓扑邻接表时，搜索只需要搜索节点编号进行比较，不需要在进行比较端点坐标，这样能大大提高运算速度。
   
5. |;
   
6. ;;;(gxl-ent->Nodes entList jd)根据弧段图元表建立弧段节点表，参数：图元表 精度值 返回值：图元名--节点编号表 '((图元名 首节点编号 末节点编号)...) 节点--坐标表 '((节点编号 坐标)...)
   
7. (defun gxl-ent->Nodes (entList jd / ent ent_nodes Nodes n k p1 p2 flag flag1 flag2 bh coord p11 p21 nodes1 sortI1 sortI2)
   
8.   (grtext -2 "整理弧段节点表...")
   
9.   (setq n 1 )
   
10.   ;(setq t1 (getvar "cdate"))
    
11.   (setq ent_nodes (list (list (car entList) 0 1)))
    
12.   (setq Nodes (list  (list 1 (vlax-curve-getendPoint (car entList))) (list 0 (vlax-curve-getStartPoint (car entList)))))
    
13.   (foreach ent (cdr entList)
    
14.     (setq flag1 t
    
15.    flag2 t
    
16.       )
    
17.     (setq p1 (vlax-curve-getStartPoint ent)
    
18.    p2 (vlax-curve-getendPoint ent)
    
19.    k 0
    
20.    )
    
21. 
    
22.   ;;;===========
    
23.     (while (and (setq node (nth k nodes)) (or flag1 flag2))
    
24.     ;(foreach node nodes
    
25.       (setq bh (car node)
    
26.      coord (cadr node)
    
27.      )
    
28.       (if (equal p1 coord jd) (setq bh1 bh flag1 nil))
    
29.       (if (equal p2 coord jd) (setq bh2 bh flag2 nil))
    
30.       (setq k (1+ k))
    
31.       ;) ;_ foreach
    
32.       )
    
33.     (if flag1
    
34.       (progn
    
35. (setq bh1 (setq n (1+ n)))
    
36. (setq nodes (cons (list bh1 p1) nodes)
    
37.        )
    
38. )
    
39.       )
    
40.     (if flag2
    
41.       (progn
    
42. (setq bh2 (setq n (1+ n)))
    
43. (setq nodes (cons (list bh2 p2) nodes)
    
44.        )
    
45. )
    
46.       )
    
47. ;;;============
    
48.     (setq ent_nodes (cons (list ent bh1 bh2) ent_nodes))
    
49.    
    
50.     )
    
51.   (grtext)
    
52.   ;(GXL-SYS-TIMEOUT t1)
    
53.   (list (reverse ent_nodes) (reverse Nodes))
    
54.   
    
55.   )
    
56. ;|
    
57. 2、根据生成的段图元名--节点编号表'((图元名 首节点编号 末节点编号)...)，构建一个二维坐标表，
    
58. 数据结构：'((图元起点的节点编号 图元起点的方向点 图元弧段编号 图元末端点方向点 图元末端点节点编号)  ...)
    
59. 其中：图元起点的方向点指图元起点到终点的方向上任一点，如果图元为圆弧，则该方向点为切线方向任一点，
    
60.      图元末端点的方向点指图元末端点到起点的方向上任一点，如果图元为圆弧，则该方向点为切线方向任一点，
    
61.      图元弧段编号为图元在表段图元名--节点编号表中的顺序位置，顺序号从1开始
    
62. |;
    
63. ;;;(gxl-ent->Coordinates enlst) 根据线段图元名--节点编号表'((图元名 首节点编号 末节点编号)...) 构建二维坐标表
    
64. ;;;返回值： 二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...)
    
65. ;;;(gxl-ent->Coordinates enLst)
    
66. (defun gxl-ent->Coordinates (enLst / rtn index a b jd n k )
    
67.    
    
68.   (setq index 0)
    
69.   ;(setq jd 3)
    
70.   (setq rtn
    
71.   (mapcar '(lambda (x)
    
72.       (list (cadr x) ;_ 首端点节点编号
    
73.      (COND
    
74.        ((= "LINE" (GXL-DXF (car x) 0))
    
75.         (list (car (setq a (vlax-curve-getendPoint (car x))))
    
76.        (cadr a)
    
77.         ) ;_ list
    
78.        )
    
79.        ((= "ARC" (GXL-DXF (car x) 0))
    
80.         
    
81.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) 1))) (cadr b))
    
82.        )
    
83.        ((WCMATCH (GXL-DXF (car x) 0) "*POLYLINE")
    
84.         
    
85.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) 1))) (cadr b))
    
86.         )
    
87.      ) ;_ COND 首端点方向点
    
88.      ;(gxl-dxf x 5) ;_ 图元句柄
    
89.      ;x ;_ 图元名
    
90.      (setq index (1+ index)) ;_ 弧段编号，从序号1开始
    
91.      (COND
    
92.        ((= "LINE" (GXL-DXF (car x) 0))
    
93.         (list (car (setq a (vlax-curve-getstartPoint (car x))))
    
94.        (cadr a)
    
95.         ) ;_ list
    
96.        )
    
97.        ((= "ARC" (GXL-DXF (car x) 0))
    
98.         
    
99.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) -1.0))) (cadr b))
    
100.        )
     
101.        ((WCMATCH (GXL-DXF (car x) 0) "*POLYLINE")
     
102.         
     
103.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) -1.0))) (cadr b))
     
104.         )
     
105.      ) ;_ 末端点方向点
     
106.      (caddr x) ;_ 末端点节点编号
     
107.       ) ;_ list
     
108.     ) ;_ lambda
     
109.    enlst
     
110.   ) ;_ mapcar
     
111. )
     
112.   rtn
     
113.    ;_ vl-sort
     
114. )
     
115. ;|
     
116. 3、根据二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...) ，
     
117. 建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)，
     
118. 建立弧段拓扑邻接表的方法：
     
119. 若某一弧段N 的首端点与另一弧段
     
120. 相关联, 则在弧段拓扑邻接关系表中标记为N ; 若
     
121. 末端点与另一弧段相关联, 则标记为- N
     
122. 如果拓扑表中有nil,则表明线段端点没有邻接边
     
123. |;
     
124. ;;;(gxl-Toupu-LineList Coordinates) 根据二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...)
     
125. ;;;建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)
     
126. (defun gxl-Toupu-LineList (Coordinates
     
127.        /      toupulist        nn
     
128.        n      k       pstart   pend
     
129.        pl      new      old      t2
     
130.        Coordinates0      Coordinates1
     
131.        flag     flag1    index pl to bh
     
132.       xh1 xh2 coord
     
133.       ) ;_ Coordinates
     
134.   (if (not *jd*) (setq *jd* 0.00001))
     
135.   ;;;点表倒置
     
136. (setq Coordinates1 (mapcar 'reverse Coordinates))
     
137.   (grtext -2  "拓扑邻接表...")
     
138.   (foreach coord Coordinates
     
139.     (setq xh1 (car coord)
     
140.    xh2 (last coord)
     
141.    )
     
142.     (setq toupulist
     
143.     (cons
     
144.       (list
     
145.         (setq bh (nth 2 coord))
     
146.         (vl-remove-if
     
147.    '(lambda (x) (or (equal x bh) (equal x (* -1 bh))))
     
148.    (append (mapcar 'cadr (GXL-MASSOC xh1 Coordinates)) (mapcar '(lambda (x) (* -1 (cadr x))) (GXL-MASSOC xh1 Coordinates1)))
     
149.    )
     
150.         (vl-remove-if
     
151.    '(lambda (x) (or (equal x bh) (equal x (* -1 bh))))
     
152.    (append (mapcar 'cadr (GXL-MASSOC xh2 Coordinates)) (mapcar '(lambda (x) (* -1 (cadr x))) (GXL-MASSOC xh2 Coordinates1)))
     
153.    )
     
154.         )
     
155.       toupulist)
     
156.    )
     
157.     )
     
158.   
     
159.   (grtext)
     
160.   (reverse toupulist)
     
161.   )
     
162. ;|
     
163. 4、检查生成的弧段拓扑邻接表，如果有断头的弧段，将其删除，返回处理后的弧段拓扑邻接表和已经删除的弧段表
     
164. |;
     
165. ;;;(gxl-check-Toupu-LineList toupulist) 参数：弧段拓扑邻接表
     
166. (defun gxl-check-Toupu-LineList (toupulist / delnil toupulist1 dellist)
     
167.   (setq toupulist1 toupulist)
     
168.   (defun delnil (toupl / tmp tmp1 dellist1 a b)
     
169.     (setq tmp toupulist1)
     
170.     (foreach a toupl
     
171.       (if (member nil a)
     
172. (progn
     
173. ;(setq dellist (append dellist (list (abs (car a)))))
     
174.    (setq dellist (append dellist (list (car a))))
     
175. (setq toupulist1 (vl-remove (assoc (abs(car a)) toupulist1) toupulist1))
     
176. (setq toupulist1
     
177.         (mapcar
     
178.    '(lambda (b)
     
179.       (list (car b)
     
180.      (vl-remove-if
     
181.        '(lambda (x) (= (abs (car a)) (abs x)))
     
182.        (cadr b)
     
183.      ) ;_ vl-remove-if
     
184.      (vl-remove-if
     
185.        '(lambda (x) (= (abs (car a)) (abs x)))
     
186.        (caddr b)
     
187.      ) ;_ vl-remove-if
     
188.       ) ;_ list
     
189.     ) ;_ lambda
     
190.    toupulist1
     
191.         ) ;_ mapcar
     
192. ) ;_ setq
     
193. )
     
194. )
     
195.       )
     
196.     (if (not (equal tmp  toupulist1)) (delnil toupulist1))
     
197.     )
     
198.   (delnil toupulist1)
     
199.   (list toupulist1 dellist)
     
200.   )
     
201. ;|
     
202. 5、根据建立的弧段拓扑邻接表，按照最小角法则搜索多边形，返回　弧段与多边形拓扑关联表 '((多边形序号 (弧段号 ...))...)
     
203. 一条弧段可作为一个或两个多边形的组成边而
     
204. 存在, 亦即从一条弧段出发最多可以搜索出两个正确
     
205. 的多边形. 如图2 所示, 若从弧段A 1 的一端O 出发,
     
206. 并把它作为起始弧段, 把与A 1 的O 端拓扑关联的其
     
207. 它弧段作为中止弧段, 然后比较并找出与A 1 夹角最
     
208. 小的中止弧段A 2, 并把A 2 作为新的起始弧段, 再从
     
209. 它的另一端点出发重复以上过程继续搜索, 直到回到
     
210. 出发弧段A 1 的另一端为止, 则所有搜索出的弧段就
     
211. 构成了一个多边形. 同样, 从A 1 的O 端开始, 并把它
     
212. 作为中止弧段, 把与它拓扑关联的其它弧段作为起始
     
213. 弧段, 然后比较并找出与该弧段夹角最小的弧段, 并
     
214. 把找出的弧段作为新的中止弧段, 再从新弧段的另一
     
215. 端点出发重复以上搜索过程, 直到回到A 1 的另一端
     
216. 为止, 则所有搜索出的弧段就构成了另一个多边形.
     
217. 这样, 从一条弧段出发可以跟踪出两个多边形, 此方
     
218. 法可称为多边形搜索的最小角法则.
     
219. 多边形的搜索按照最小角法则进行. 从编号为
     
220. 1 的弧段的始端出发, 查找弧段拓扑邻接表中与该
     
221. 端点关联的弧段, 按照最小角法则可以搜索出两个
     
222. 多边形. 依照上述方法, 依次把其它弧段作为开始弧
     
223. 段, 共可找出2N (N 为总弧段数) 个多边形. 搜索过
     
224. 程中, 记录构成多边形的弧段编号(一弧段首端与上
     
225. 一弧段关联用正边号, 否则用负边号) 和弧段数, 即
     
226. 形成多边形与弧段的拓扑关联表.
     
227. |;
     
228. ;;;(gxl-MakePolyList toupulist Coordinates nodes) 最小角法拓扑多边形,返回多边形数据表
     
229. ;;;参数：
     
230. ;;; toupulist 弧段邻接表 '((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)，从 1 开始
     
231. ;;; Coordinates 二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...) 按顺序从1开始
     
232. ;;; nodes 节点--坐标表 '((节点编号 坐标)...)
     
233. (defun gxl-MakePolyList (toupulist Coordinates      nodes    /        PolyTouPuList  nn
     
234.        n     xh      pstart   pend     flag p0  p1
     
235.        a0     a1      a2       B1       B2 polytoupu
     
236.        toupu0   next     t2       kk       ExitNum ExitFlag Nodestart
     
237.        NodeEnd  node
     
238.       ) ;_ toupulist
     
239.   (if (not *jd*) (setq *jd* 0.00001))
     
240.     ;;;测试时间
     
241.   (setq t2 (getvar "cdate"))
     
242.   (setq nn (length Coordinates)
     
243. n 0
     
244. to nn)
     
245.   (GXL-SYS-PROGRESS-INIT "拓扑多边形" to)
     
246.   (repeat nn
     
247.     (setq xh (1+ n)) ;_ 弧段序号
     
248.     ;(setq bak xh)
     
249.     (if (assoc xh toupulist)
     
250.       ;;;如果该边在拓扑邻接表里
     
251.       (progn
     
252.     (GXL-SYS-PROGRESS   to -1)
     
253.     (setq Nodestart (car (nth n Coordinates))
     
254.    NodeEnd  (last (nth n Coordinates))
     
255.    Pstart (cadr (assoc Nodestart nodes))
     
256.    pEnd (cadr (assoc NodeEnd nodes))
     
257.    flag  t
     
258.     ) ;_ setq
     
259.     ;;;首端点搜索多边形
     
260.     (setq p0 pstart
     
261.    p1 (cadr (nth n Coordinates))
     
262.    a0 (angle p0 p1) ;_ 首端点弧段角度
     
263.    toupu0 (cadr (assoc xh toupulist)) ;_ 首端点弧段拓扑邻接表
     
264.    polytoupu (list (* -1 xh))
     
265.    )
     
266.     (setq ExitNum 0  ;_ 循环次数
     
267.    ExitFlag nil) ;_ 陷入死循环标志
     
268.     ;;;移除重合的线
     
269.     (setq toupu0 (vl-remove-if
     
270.      '(lambda (x)
     
271.         (if (> x 0)
     
272.    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
     
273.    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
     
274.    )
     
275.         )
     
276.      toupu0
     
277.      )
     
278.    )
     
279.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
     
280.     (while flag
     
281.       ;;;toupu0与a0按最小角度排序相邻边
     
282.       (setq toupu0
     
283.       (vl-sort toupu0
     
284.         '(lambda (e1 e2)
     
285.     (if (> e1 0)
     
286.       (setq a1 (angle (cadr (assoc (car (nth (1- e1) Coordinates)) nodes))  (cadr (nth (1- e1) Coordinates))))
     
287.       (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ e1)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e1)) Coordinates))))
     
288.       )
     
289.     (if (> e2 0)
     
290.       (setq a2 (angle (cadr (assoc (car (nth (1- e2) Coordinates)) nodes))   (cadr (nth (1- e2) Coordinates))))
     
291.       (setq a2 (angle (cadr (assoc (nth 4 (nth (abs (1+ e2)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e2)) Coordinates))))
     
292.       )
     
293.     (if (>= a0 a1) (setq B1 (- a0 a1)) (setq B1 (+ 2pi (- a0 a1))))
     
294.     (if (>= a0 a2) (setq B2 (- a0 a2)) (setq B2 (+ 2pi (- a0 a2))))
     
295.     (< B1 B2)
     
296.     )
     
297.         )
     
298.      )
     
299.       ;;;判断Next边是否已经在polytoupu里了
     
300.       ;(if (member next (mapcar 'abs polytoupu)) (setq exitflag t))
     
301.       (setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号
     
302.       ;;;验证next 下一邻接边序号的方位角是否和首端点弧段角度a0重合，如重合，找下一边，未找到，结束组多边形
     
303.       (setq falg1 t
     
304.      kk 1)
     
305.       (while flag1
     
306. (if (> next 0)
     
307.    (setq a1 (angle (cadr (assoc (car (nth (1- next) Coordinates)) nodes))  (cadr (nth (1- next) Coordinates))))
     
308.    (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ next)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ next)) Coordinates))))
     
309.   )
     
310.    (if (equal a0 a1 0.000001) (setq next (nth kk toupu0))(setq flag1 nil))
     
311. (if (not next) (setq flag1 nil))
     
312. (setq kk (1+ kk))
     
313. )
     
314.       ;(if next (setq polytoupu (append polytoupu (list (setq next (car toupu0))))))
     
315.       (if next
     
316.       (if (> next 0)
     
317. (progn
     
318.    (setq p0 (cadr (assoc  (setq node (nth 4 (nth (1- next) Coordinates))) nodes))
     
319.   a0 (angle p0 (nth 3 (nth (1- next) Coordinates)))
     
320.   toupu0 (caddr (assoc next toupulist))
     
321.   )
     
322.    (if (equal node nodeEnd) (setq flag nil))
     
323.    
     
324.    )
     
325. (progn
     
326.    (setq p0 (cadr (assoc  (setq node (car (nth (abs (1+ next)) Coordinates))) nodes))
     
327.   a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))
     
328.   toupu0 (cadr (assoc (abs next) toupulist))
     
329.   )
     
330.    (if (equal node nodeEnd) (setq flag nil))
     
331.    )
     
332. )
     
333. (setq flag nil)
     
334. )
     
335.      (setq ExitNum (1+ ExitNum))
     
336.       ;;;搜索边界次数超过2000次，程序陷入死循环，退出
     
337.       (if (> ExitNum 2000) (setq flag nil ExitFlag t))
     
338.       (if (and flag (not ExitFlag))
     
339. (progn
     
340.     ;;;移除重合的线
     
341.     (setq toupu0 (vl-remove-if
     
342.      '(lambda (x)
     
343.         (if (> x 0)
     
344.    (equal a0 (angle (cadr (assoc  (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
     
345.    (equal a0 (angle (cadr (assoc  (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
     
346.    )
     
347.         )
     
348.      toupu0
     
349.      )
     
350.    )
     
351.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
     
352.    )
     
353. )
     
354.       );_ while
     
355.     (if ExitFlag
     
356.       (setq ExitFlag nil)
     
357.     (setq PolyTouPuList (append PolyTouPuList (list polytoupu)))
     
358.       )
     
359.    
     
360.     ;;;末端点搜索
     
361.     (setq p0 pend
     
362.    p1 (nth 3 (nth n Coordinates))
     
363.    a0 (angle p0 p1) ;_ 起点角度
     
364.    toupu0 (caddr (assoc xh toupulist))
     
365.    polytoupu (list xh)
     
366.    flag  t
     
367.    )
     
368.     (setq ExitNum 0  ;_ 循环次数
     
369.    ExitFlag nil) ;_ 陷入死循环标志
     
370.         ;;;移除重合的线
     
371.     (setq toupu0 (vl-remove-if
     
372.      '(lambda (x)
     
373.         (if (> x 0)
     
374.    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
     
375.    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
     
376.    )
     
377.         )
     
378.      toupu0
     
379.      )
     
380.    )
     
381.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
     
382.     (while flag
     
383.       ;;;计算最小角度相邻边
     
384.       
     
385.       (setq toupu0
     
386.       (vl-sort toupu0
     
387.         '(lambda (e1 e2)
     
388.     (if (> e1 0)
     
389.       (setq a1 (angle (cadr (assoc (car (nth (1- e1) Coordinates)) nodes))  (cadr (nth (1- e1) Coordinates))))
     
390.       (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ e1)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e1)) Coordinates))))
     
391.       )
     
392.     (if (> e2 0)
     
393.       (setq a2 (angle (cadr (assoc (car (nth (1- e2) Coordinates)) nodes))  (cadr (nth (1- e2) Coordinates))))
     
394.       (setq a2 (angle (cadr (assoc (nth 4 (nth (abs (1+ e2)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e2)) Coordinates))))
     
395.       )
     
396.     (if (>= a0 a1) (setq B1 (- a0 a1)) (setq B1 (+ 2pi (- a0 a1))))
     
397.     (if (>= a0 a2) (setq B2 (- a0 a2)) (setq B2 (+ 2pi (- a0 a2))))
     
398.     (< B1 B2)
     
399.     )
     
400.         )
     
401.      )
     
402.        ;;;判断Next边是否已经在polytoupu里了
     
403.       ;(if (member next (mapcar 'abs polytoupu)) (setq exitflag t))
     
404.       (setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号
     
405.       ;;;验证next 下一邻接边序号的方位角是否和首端点弧段角度a0重合，如重合，找下一边，未找到，结束组多边形
     
406.       (setq falg1 t
     
407.      kk 1)
     
408.       (while flag1
     
409. (if (> next 0)
     
410.    (setq a1 (angle (cadr (assoc (car (nth (1- next) Coordinates)) nodes))  (cadr (nth (1- next) Coordinates))))
     
411.    (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ next)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ next)) Coordinates))))
     
412.   )
     
413.    (if (equal a0 a1 0.000001) (setq next (nth kk toupu0))(setq flag1 nil))
     
414. (if (not next) (setq flag1 nil))
     
415. (setq kk (1+ kk))
     
416. )
     
417.       ;(if next (setq polytoupu (append polytoupu (list (setq next (car toupu0))))))
     
418.       (if next
     
419.       (if (> next 0)
     
420. (progn
     
421.    (setq p0 (cadr (assoc (setq node (nth 4 (nth (1- next) Coordinates))) nodes))
     
422.   a0 (angle p0 (nth 3 (nth (1- next) Coordinates)))
     
423.   toupu0 (caddr (assoc next toupulist))
     
424.   )
     
425.    (if (equal node nodestart) (setq flag nil))
     
426.    )
     
427. (progn
     
428.    (setq p0 (cadr (assoc (setq node (car (nth (abs (1+ next)) Coordinates))) nodes))
     
429.   a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))
     
430.   toupu0 (cadr (assoc (abs next) toupulist))
     
431.   )
     
432.    (if (equal node nodestart) (setq flag nil))
     
433.    )
     
434. )
     
435.   (setq flag nil)
     
436. )
     
437.        (setq ExitNum (1+ ExitNum))
     
438.       ;;;搜索边界次数超过2000次，程序陷入死循环，退出
     
439.       (if (> ExitNum 2000) (setq flag nil ExitFlag t))
     
440.       (if (and flag (not ExitFlag))
     
441. (progn
     
442.     ;;;移除重合的线
     
443.     (setq toupu0 (vl-remove-if
     
444.      '(lambda (x)
     
445.         (if (> x 0)
     
446.    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
     
447.    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
     
448.    )
     
449.         )
     
450.      toupu0
     
451.      )
     
452.    )
     
453.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
     
454.    )
     
455. )
     
456.    
     
457.       ) ;_ while
     
458.     (if ExitFlag
     
459.       (setq ExitFlag nil)
     
460.     (setq PolyTouPuList (append PolyTouPuList (list polytoupu)))
     
461.       )
     
462.     )
     
463.       )
     
464. 
     
465.     (setq n (1+ n))
     
466.     )
     
467.   (GXL-SYS-PROGRESS-DONE)
     
468.     ;(princ " \n多边形拓扑 ")
     
469.   (GXL-SYS-TIMEOUT t2)
     
470. ;;;删除多余多边形
     
471.   (gxl-dumpPolyTouPuList PolyTouPuList)
     
472.   )
     
473. ;|
     
474. 6、多余多边形的消除
     
475. 由于按照最小角法则搜索出的多边形, 其中部
     
476. 分是重复的(例如“岛”被搜索了两次) , 部分是错误
     
477. 的(例如外围轮廓多边形) , 因此这两种多边形需要
     
478. 去除. 其中重复多边形的去除是从多边形与弧段的
     
479. 拓扑关联表中按照边数相等, 且边号绝对值相等的
     
480. 原则来进行; 而错误多边形的去除则按照下面原则
     
481. 进行: 一个多边形与另一多边形有公共边, 同时它又
     
482. 包含另一多边形的非公共边上一点, 则该多边形是
     
483. 错误多边形.
     
484. |;
     
485. ;;;(gxl-dumpPolyTouPuList PolyTouPuList) 删除多余多边形，本函数仅消除重复的多边形，
     
486. ;;;外包多边形在实际生成多边形后再予以删除
     
487. (defun gxl-dumpPolyTouPuList (PolyTouPuList / rtn pl nn n a)
     
488.   (setq pl PolyTouPuList
     
489. nn (length pl)
     
490.   ) ;_ setq
     
491.   ;(grtext -2 "\n处理多余多边形...")
     
492.   ;(princ)
     
493.   (GXL-SYS-PROGRESS-INIT "处理多余多边形" nn)
     
494. ;;;测试时间
     
495.   ;(setq t2 (getvar "cdate"))
     
496.   (while (setq a   (car pl)
     
497.         rtn (cons a rtn)
     
498.         pl  (vl-remove-if
     
499.        '(lambda (x)
     
500.    (if (= (length a) (length x))
     
501.      (if (equal (vl-sort (mapcar 'abs x) '<)
     
502.          (vl-sort (mapcar 'abs a) '<)
     
503.          ) ;_ equal
     
504.        t
     
505.      ) ;_ if
     
506.    ) ;_ if
     
507.         ) ;_ lambda
     
508.        pl
     
509.      ) ;_ vl-remove-if
     
510.   ) ;_ setq
     
511.     (GXL-SYS-PROGRESS  nn -1)
     
512.   ) ;_ while
     
513.   (GXL-SYS-PROGRESS-DONE)
     
514.   ;(GXL-SYS-TIMEOUT t2)
     
515.   (setq rtn (reverse rtn))
     
516.   (vl-remove-if
     
517.     '(lambda (x) (/= (length x) (length (GXL-LISTDUMPATOM (mapcar 'abs x)))))
     
518.     rtn
     
519.     )
     
520. ) ;_ defun
     
521. ;|
     
522. 7、根据生成的多边形拓扑表绘制多边形
     
523. ;;;(gxl-DrawPolyLine PolyTouPuList ssl Coordinates closed)
     
524. 由弧段与多边形拓扑关联表绘制多边形,参数 多边形拓扑关联表 图元名列表 坐标值列表 是否闭合 返回值：多边形选择集
     
525. ;;;PolyTouPuList 多边形拓扑表
     
526. ;;; ssl 图元名--节点编号表 '((图元名 首节点编号 末节点编号)...)
     
527. ;;; nodes 节点--坐标表 '((节点编号 坐标)...)
     
528. |;
     
529. (defun gxl-DrawPolyLine (PolyTouPuList
     
530.      ssl     nodes  closed   /     Polytoupu pts
     
531.      _bulges   mn       ml mk   num     p1       p2
     
532.      np1     np2       en en1   rtn     coords    n
     
533.      gxl-DelOutPolyline La_LineType_Color Lay LineType Color xh1 xh2
     
534.     ) ;_ PolyTouPuList
     
535.   ;;;(gxl-DelOutPolyline ss) 删除拓扑出poly选择集中外边框,返回删除后的选择集
     
536. ;;;(gxl-DelOutPolyline pss)
     
537. (defun gxl-DelOutPolyline (ss / ssL ssL1 ent flag en1 rtn)
     
538.   (setq ssL (GXL-SEL-SS->LIST ss)
     
539. rtn (ssadd)
     
540. flag t
     
541. )
     
542.   (setq ssL (vl-sort ssL '(lambda (e1 e2) (> (GXL-GETAREA e1) (GXL-GETAREA e2)))))
     
543.   
     
544.   (while flag
     
545.     (setq ent (car ssL)
     
546. ssL (cdr ssL)
     
547. ssL1 '()
     
548. flag1 nil
     
549. )
     
550.     (while ssL
     
551.       (setq en1 (car ssL)
     
552.      ssL (cdr ssL)
     
553.       ) ;_ setq
     
554.       (if (PolyInLwpolyLine en1 ent)
     
555. (setq  flag1 t)
     
556. (setq ssL1 (cons en1 ssL1))
     
557.       ) ;_ if
     
558.     ) ;_ while
     
559.     (if flag1 (progn (ssdel ent ss)(entdel ent)(setq flag1 nil)))
     
560.     (if ssL1
     
561. (setq ssL (vl-sort ssL1 '(lambda (e1 e2) (> (GXL-GETAREA e1) (GXL-GETAREA e2)))))
     
562.       (setq flag nil)
     
563.       )
     
564.   ) ;_ while
     
565.   ss
     
566.   )
     
567.   (setq rtn (ssadd))
     
568.   (if (not *jd*) (setq *jd* 0.0001))
     
569.   (foreach Polytoupu PolyTouPuList
     
570.     (setq pts nil
     
571.    _bulges nil
     
572.    mn (length Polytoupu)
     
573.    mk 0
     
574.    )
     
575.    ;(if closed (setq mk 0) (setq mk -1))
     
576.     (foreach num Polytoupu
     
577.       (setq mk (1+ mk))
     
578.       
     
579.       (setq en (car (nth (1- (abs num)) ssl))
     
580.      xh1 (cadr (nth (1- (abs num)) ssl))
     
581.      xh2 (caddr (nth (1- (abs num)) ssl))
     
582.      ;coords (nth (1- (abs num)) Coordinates)
     
583.      entype (gxl-dxf en 0)
     
584.      )
     
585.       
     
586.       (if (> num 0)
     
587. (setq p1 (cadr (assoc xh1 nodes))
     
588.        p2 (cadr (assoc xh2 nodes))
     
589. ) ;_ setq
     
590. (setq p1 (cadr (assoc xh2 nodes))
     
591.        p2 (cadr (assoc xh1 nodes))
     
592. ) ;_ setq
     
593.       ) ;_ if
     
594.       (cond ((= entype "LINE")
     
595.       (if pts
     
596.         (setq pts (append pts (list p2))
     
597.        _bulges (append _bulges (list 0))
     
598.        )
     
599.         (setq pts (append pts (list p1 p2))
     
600.        _bulges (append _bulges (list 0))
     
601.        )
     
602.       ) ;_ if
     
603.       
     
604.       
     
605.       )
     
606.      ((= entype "ARC")
     
607.       (if pts
     
608.         (setq pts (append pts (list p2))
     
609.        _bulges (append _bulges (list (cond ((> num 0) (gxl-GetArcBulge en)) (t (* -1.0 (gxl-GetArcBulge en))))))
     
610.        )
     
611.         (setq pts (append pts (list p1 p2))
     
612.        _bulges (append _bulges (list (cond ((> num 0) (gxl-GetArcBulge en)) (t (* -1.0 (gxl-GetArcBulge en))))))
     
613.        )
     
614.       )
     
615.       )
     
616.      ((= entype "LWPOLYLINE")
     
617.       (setq data (gxl-get_poly_data en))
     
618.       
     
619.       (if (> num 0)
     
620.         (progn
     
621.    (if pts
     
622.      (progn
     
623.    (setq pts (append pts (cdar data)))
     
624.    (setq _bulges (append _bulges (reverse (cdr (reverse (cadr data))))))
     
625.    )
     
626.      (progn
     
627.        (setq pts (append pts (cons p1 (cdar data))))
     
628.        (setq _bulges (append _bulges (cadr data)))
     
629.        )
     
630.      )
     
631.         ) ;_ progn
     
632.         (progn
     
633.    (GXL-REVERSELWPOLYLINE en)
     
634.    (setq data (gxl-get_poly_data en))
     
635.    (if pts
     
636.      (progn
     
637.    (setq pts (append pts (cdar data)))
     
638.    (setq _bulges (append _bulges (reverse (cdr (reverse (cadr data))))))
     
639.    )
     
640.      (progn
     
641.        (setq pts (append pts (cons p1 (cdar data))))
     
642.        (setq _bulges (append _bulges (cadr data)))
     
643.        )
     
644.      )
     
645.    (GXL-REVERSELWPOLYLINE en)
     
646.         ) ;_ progn
     
647.       ) ;_ if
     
648.       )
     
649.      )
     
650.       
     
651.       )
     
652.     ;(if (= entype "LWPOLYLINE") (setq _bulges  (append _bulges (list (last (cadr data))))) (setq _bulges  (append _bulges (list 0))))     
     
653.    (if closed
     
654.      (vla-put-closed (GXL-AX:ADDLWPOLYLINE1 *MODEL-SPACE* (list pts _bulges )) :vlax-true)
     
655.      (GXL-AX:ADDLWPOLYLINE1 *MODEL-SPACE* (list pts _bulges))
     
656.      )
     
657.     (setq app pts
     
658.    bus _bulges)
     
659.     (ssadd (setq en (entlast)) rtn)
     
660.     ;;;修改多段线图层
     
661.     (setq La_LineType_Color (gxl-GetToupuPolyLayer_Linetype_color Polytoupu (mapcar 'car ssl)))
     
662.     (setq lay (car La_LineType_Color)
     
663.    LineType (cadr La_LineType_Color)
     
664.    Color (caddr La_LineType_Color)
     
665.    )
     
666.     (gxl-CH_Ent en 8 lay)
     
667.     (if LineType (gxl-CH_Ent en 6 LineType))
     
668.     (if color (gxl-CH_Ent en 62 color))
     
669.     (gxl-DumpPolyPoint en)
     
670.     ;(vla-put-closed (GXL-AX:ADDLWPOLYLINE *MODEL-SPACE* pts) :vlax-true)
     
671.     )
     
672.   (if closed (gxl-DelOutPolyline rtn) rtn) ;_ 返回删除外框后的选择集
     
673.   )
     
674. ;;;测试
     
675. (defun c:mkpoly ()
     
676.   (SETUNDOERR)
     
677.    (if (not *jd*) (setq *jd* 0.00001))
     
678.   (princ "\n基于方位角计算的拓扑多边形自动构建快速算法测试")
     
679.   (princ "\n****程序作者：Gu_xl 2010年8月****")
     
680.   (princ "\n选择直线、圆弧、圆：")
     
681.   (setq ss (ssget '((0 . "line,arc,circle"))))
     
682.   (gxl-makepoly ss)
     
683.   (reerr)
     
684.   )
     
685. ;;;至此，基于方位角计算的拓扑多边形自动构建快速算法 的主要算法思路的函数功能全部完成，
     
686. ;;;附件是打包的测试程序，调用命令：mkpoly
     
687. 
     

;|为了提高程序构建多边形的运行速度，需要对程序的数据结构和计算方法进行优化，下面我逐步详解我程序的思路：<br /> 1、根据处理后的直线、圆弧选择集生成的图元列表entList，数据结构：(图元名 图元名 ...),建立图元和各图元之间的节点对应关系数据表，<br /> 数据结构：'((图元名 起点的节点编号 端点的节点编号)...)，表中图元名的排序和表entList的顺序一致，再建立节点和坐标数据对应表，<br /> 数据结构：'((节点编号 坐标)...),这样方便后面构建拓扑邻接表时，搜索只需要搜索节点编号进行比较，不需要在进行比较端点坐标，这样能大大提高运算速度。<br /> |;<br /> ;;;(gxl-ent->Nodes entList jd)根据弧段图元表建立弧段节点表，参数：图元表 精度值 返回值：图元名--节点编号表 '((图元名 首节点编号 末节点编号)...) 节点--坐标表 '((节点编号 坐标)...)<br /> (defun gxl-ent->Nodes (entList jd / ent ent_nodes Nodes n k p1 p2 flag flag1 flag2 bh coord p11 p21 nodes1 sortI1 sortI2)<br />   (grtext -2 "整理弧段节点表...")<br />   (setq n 1 )<br />   ;(setq t1 (getvar "cdate"))<br />   (setq ent_nodes (list (list (car entList) 0 1)))<br />   (setq Nodes (list  (list 1 (vlax-curve-getendPoint (car entList))) (list 0 (vlax-curve-getStartPoint (car entList)))))<br />   (foreach ent (cdr entList)<br />     (setq flag1 t<br />    flag2 t<br />       )<br />     (setq p1 (vlax-curve-getStartPoint ent)<br />    p2 (vlax-curve-getendPoint ent)<br />    k 0<br />    )<br /> <br />   ;;;===========<br />     (while (and (setq node (nth k nodes)) (or flag1 flag2))<br />     ;(foreach node nodes<br />       (setq bh (car node)<br />      coord (cadr node)<br />      )<br />       (if (equal p1 coord jd) (setq bh1 bh flag1 nil))<br />       (if (equal p2 coord jd) (setq bh2 bh flag2 nil))<br />       (setq k (1+ k))<br />       ;) ;_ foreach<br />       )<br />     (if flag1<br />       (progn<br /> (setq bh1 (setq n (1+ n)))<br /> (setq nodes (cons (list bh1 p1) nodes)<br />        )<br /> )<br />       )<br />     (if flag2<br />       (progn<br /> (setq bh2 (setq n (1+ n)))<br /> (setq nodes (cons (list bh2 p2) nodes)<br />        )<br /> )<br />       )<br /> ;;;============<br />     (setq ent_nodes (cons (list ent bh1 bh2) ent_nodes))<br />     <br />     )<br />   (grtext)<br />   ;(GXL-SYS-TIMEOUT t1)<br />   (list (reverse ent_nodes) (reverse Nodes))<br />   <br />   )<br /> ;|<br /> 2、根据生成的段图元名--节点编号表'((图元名 首节点编号 末节点编号)...)，构建一个二维坐标表，<br /> 数据结构：'((图元起点的节点编号 图元起点的方向点 图元弧段编号 图元末端点方向点 图元末端点节点编号)  ...)<br /> 其中：图元起点的方向点指图元起点到终点的方向上任一点，如果图元为圆弧，则该方向点为切线方向任一点，<br />      图元末端点的方向点指图元末端点到起点的方向上任一点，如果图元为圆弧，则该方向点为切线方向任一点，<br />      图元弧段编号为图元在表段图元名--节点编号表中的顺序位置，顺序号从1开始<br /> |;<br /> ;;;(gxl-ent->Coordinates enlst) 根据线段图元名--节点编号表'((图元名 首节点编号 末节点编号)...) 构建二维坐标表<br /> ;;;返回值： 二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...)<br /> ;;;(gxl-ent->Coordinates enLst)<br /> (defun gxl-ent->Coordinates (enLst / rtn index a b jd n k )<br />    <br />   (setq index 0)<br />   ;(setq jd 3)<br />   (setq rtn<br />   (mapcar '(lambda (x)<br />       (list (cadr x) ;_ 首端点节点编号<br />      (COND<br />        ((= "LINE" (GXL-DXF (car x) 0))<br />         (list (car (setq a (vlax-curve-getendPoint (car x))))<br />        (cadr a)<br />         ) ;_ list<br />        )<br />        ((= "ARC" (GXL-DXF (car x) 0))<br />         <br />         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) 1))) (cadr b))<br />        )<br />        ((WCMATCH (GXL-DXF (car x) 0) "*POLYLINE")<br />         <br />         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) 1))) (cadr b))<br />         )<br />      ) ;_ COND 首端点方向点<br />      ;(gxl-dxf x 5) ;_ 图元句柄<br />      ;x ;_ 图元名<br />      (setq index (1+ index)) ;_ 弧段编号，从序号1开始<br />      (COND<br />        ((= "LINE" (GXL-DXF (car x) 0))<br />         (list (car (setq a (vlax-curve-getstartPoint (car x))))<br />        (cadr a)<br />         ) ;_ list<br />        )<br />        ((= "ARC" (GXL-DXF (car x) 0))<br />         <br />         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) -1.0))) (cadr b))<br />        )<br />        ((WCMATCH (GXL-DXF (car x) 0) "*POLYLINE")<br />         <br />         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) -1.0))) (cadr b))<br />         )<br />      ) ;_ 末端点方向点<br />      (caddr x) ;_ 末端点节点编号<br />       ) ;_ list<br />     ) ;_ lambda<br />    enlst<br />   ) ;_ mapcar<br /> )<br />   rtn<br />    ;_ vl-sort<br /> )<br /> ;|<br /> 3、根据二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...) ，<br /> 建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)，<br /> 建立弧段拓扑邻接表的方法：<br /> 若某一弧段N 的首端点与另一弧段<br /> 相关联, 则在弧段拓扑邻接关系表中标记为N ; 若<br /> 末端点与另一弧段相关联, 则标记为- N<br /> 如果拓扑表中有nil,则表明线段端点没有邻接边<br /> |;<br /> ;;;(gxl-Toupu-LineList Coordinates) 根据二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...)<br /> ;;;建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)<br /> (defun gxl-Toupu-LineList (Coordinates<br />        /      toupulist        nn<br />        n      k       pstart   pend<br />        pl      new      old      t2<br />        Coordinates0      Coordinates1<br />        flag     flag1    index pl to bh<br />       xh1 xh2 coord<br />       ) ;_ Coordinates<br />   (if (not *jd*) (setq *jd* 0.00001))<br />   ;;;点表倒置<br /> (setq Coordinates1 (mapcar 'reverse Coordinates))<br />   (grtext -2  "拓扑邻接表...")<br />   (foreach coord Coordinates<br />     (setq xh1 (car coord)<br />    xh2 (last coord)<br />    )<br />     (setq toupulist<br />     (cons<br />       (list<br />         (setq bh (nth 2 coord))<br />         (vl-remove-if<br />    '(lambda (x) (or (equal x bh) (equal x (* -1 bh))))<br />    (append (mapcar 'cadr (GXL-MASSOC xh1 Coordinates)) (mapcar '(lambda (x) (* -1 (cadr x))) (GXL-MASSOC xh1 Coordinates1)))<br />    )<br />         (vl-remove-if<br />    '(lambda (x) (or (equal x bh) (equal x (* -1 bh))))<br />    (append (mapcar 'cadr (GXL-MASSOC xh2 Coordinates)) (mapcar '(lambda (x) (* -1 (cadr x))) (GXL-MASSOC xh2 Coordinates1)))<br />    )<br />         )<br />       toupulist)<br />    )<br />     )<br />   <br />   (grtext)<br />   (reverse toupulist)<br />   )<br /> ;|<br /> 4、检查生成的弧段拓扑邻接表，如果有断头的弧段，将其删除，返回处理后的弧段拓扑邻接表和已经删除的弧段表<br /> |;<br /> ;;;(gxl-check-Toupu-LineList toupulist) 参数：弧段拓扑邻接表<br /> (defun gxl-check-Toupu-LineList (toupulist / delnil toupulist1 dellist)<br />   (setq toupulist1 toupulist)<br />   (defun delnil (toupl / tmp tmp1 dellist1 a b)<br />     (setq tmp toupulist1)<br />     (foreach a toupl<br />       (if (member nil a)<br /> (progn<br /> ;(setq dellist (append dellist (list (abs (car a)))))<br />    (setq dellist (append dellist (list (car a))))<br /> (setq toupulist1 (vl-remove (assoc (abs(car a)) toupulist1) toupulist1))<br /> (setq toupulist1<br />         (mapcar<br />    '(lambda (b)<br />       (list (car b)<br />      (vl-remove-if<br />        '(lambda (x) (= (abs (car a)) (abs x)))<br />        (cadr b)<br />      ) ;_ vl-remove-if<br />      (vl-remove-if<br />        '(lambda (x) (= (abs (car a)) (abs x)))<br />        (caddr b)<br />      ) ;_ vl-remove-if<br />       ) ;_ list<br />     ) ;_ lambda<br />    toupulist1<br />         ) ;_ mapcar<br /> ) ;_ setq<br /> )<br /> )<br />       )<br />     (if (not (equal tmp  toupulist1)) (delnil toupulist1))<br />     )<br />   (delnil toupulist1)<br />   (list toupulist1 dellist)<br />   )<br /> ;|<br /> 5、根据建立的弧段拓扑邻接表，按照最小角法则搜索多边形，返回　弧段与多边形拓扑关联表 '((多边形序号 (弧段号 ...))...)<br /> 一条弧段可作为一个或两个多边形的组成边而<br /> 存在, 亦即从一条弧段出发最多可以搜索出两个正确<br /> 的多边形. 如图2 所示, 若从弧段A 1 的一端O 出发,<br /> 并把它作为起始弧段, 把与A 1 的O 端拓扑关联的其<br /> 它弧段作为中止弧段, 然后比较并找出与A 1 夹角最<br /> 小的中止弧段A 2, 并把A 2 作为新的起始弧段, 再从<br /> 它的另一端点出发重复以上过程继续搜索, 直到回到<br /> 出发弧段A 1 的另一端为止, 则所有搜索出的弧段就<br /> 构成了一个多边形. 同样, 从A 1 的O 端开始, 并把它<br /> 作为中止弧段, 把与它拓扑关联的其它弧段作为起始<br /> 弧段, 然后比较并找出与该弧段夹角最小的弧段, 并<br /> 把找出的弧段作为新的中止弧段, 再从新弧段的另一<br /> 端点出发重复以上搜索过程, 直到回到A 1 的另一端<br /> 为止, 则所有搜索出的弧段就构成了另一个多边形.<br /> 这样, 从一条弧段出发可以跟踪出两个多边形, 此方<br /> 法可称为多边形搜索的最小角法则.<br /> 多边形的搜索按照最小角法则进行. 从编号为<br /> 1 的弧段的始端出发, 查找弧段拓扑邻接表中与该<br /> 端点关联的弧段, 按照最小角法则可以搜索出两个<br /> 多边形. 依照上述方法, 依次把其它弧段作为开始弧<br /> 段, 共可找出2N (N 为总弧段数) 个多边形. 搜索过<br /> 程中, 记录构成多边形的弧段编号(一弧段首端与上<br /> 一弧段关联用正边号, 否则用负边号) 和弧段数, 即<br /> 形成多边形与弧段的拓扑关联表.<br /> |;<br /> ;;;(gxl-MakePolyList toupulist Coordinates nodes) 最小角法拓扑多边形,返回多边形数据表<br /> ;;;参数：<br /> ;;; toupulist 弧段邻接表 '((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)，从 1 开始<br /> ;;; Coordinates 二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...) 按顺序从1开始<br /> ;;; nodes 节点--坐标表 '((节点编号 坐标)...)<br /> (defun gxl-MakePolyList (toupulist Coordinates      nodes    /        PolyTouPuList  nn<br />        n     xh      pstart   pend     flag p0  p1<br />        a0     a1      a2       B1       B2 polytoupu<br />        toupu0   next     t2       kk       ExitNum ExitFlag Nodestart<br />        NodeEnd  node<br />       ) ;_ toupulist<br />   (if (not *jd*) (setq *jd* 0.00001))<br />     ;;;测试时间<br />   (setq t2 (getvar "cdate"))<br />   (setq nn (length Coordinates)<br /> n 0<br /> to nn)<br />   (GXL-SYS-PROGRESS-INIT "拓扑多边形" to)<br />   (repeat nn<br />     (setq xh (1+ n)) ;_ 弧段序号<br />     ;(setq bak xh)<br />     (if (assoc xh toupulist)<br />       ;;;如果该边在拓扑邻接表里<br />       (progn<br />     (GXL-SYS-PROGRESS   to -1)<br />     (setq Nodestart (car (nth n Coordinates))<br />    NodeEnd  (last (nth n Coordinates))<br />    Pstart (cadr (assoc Nodestart nodes))<br />    pEnd (cadr (assoc NodeEnd nodes))<br />    flag  t<br />     ) ;_ setq<br />     ;;;首端点搜索多边形<br />     (setq p0 pstart<br />    p1 (cadr (nth n Coordinates))<br />    a0 (angle p0 p1) ;_ 首端点弧段角度<br />    toupu0 (cadr (assoc xh toupulist)) ;_ 首端点弧段拓扑邻接表<br />    polytoupu (list (* -1 xh))<br />    )<br />     (setq ExitNum 0  ;_ 循环次数<br />    ExitFlag nil) ;_ 陷入死循环标志<br />     ;;;移除重合的线<br />     (setq toupu0 (vl-remove-if<br />      '(lambda (x)<br />         (if (> x 0)<br />    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)<br />    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)<br />    )<br />         )<br />      toupu0<br />      )<br />    )<br />     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))<br />     (while flag<br />       ;;;toupu0与a0按最小角度排序相邻边<br />       (setq toupu0<br />       (vl-sort toupu0<br />         '(lambda (e1 e2)<br />     (if (> e1 0)<br />       (setq a1 (angle (cadr (assoc (car (nth (1- e1) Coordinates)) nodes))  (cadr (nth (1- e1) Coordinates))))<br />       (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ e1)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e1)) Coordinates))))<br />       )<br />     (if (> e2 0)<br />       (setq a2 (angle (cadr (assoc (car (nth (1- e2) Coordinates)) nodes))   (cadr (nth (1- e2) Coordinates))))<br />       (setq a2 (angle (cadr (assoc (nth 4 (nth (abs (1+ e2)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e2)) Coordinates))))<br />       )<br />     (if (>= a0 a1) (setq B1 (- a0 a1)) (setq B1 (+ 2pi (- a0 a1))))<br />     (if (>= a0 a2) (setq B2 (- a0 a2)) (setq B2 (+ 2pi (- a0 a2))))<br />     (< B1 B2)<br />     )<br />         )<br />      )<br />       ;;;判断Next边是否已经在polytoupu里了<br />       ;(if (member next (mapcar 'abs polytoupu)) (setq exitflag t))<br />       (setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号<br />       ;;;验证next 下一邻接边序号的方位角是否和首端点弧段角度a0重合，如重合，找下一边，未找到，结束组多边形<br />       (setq falg1 t<br />      kk 1)<br />       (while flag1<br /> (if (> next 0)<br />    (setq a1 (angle (cadr (assoc (car (nth (1- next) Coordinates)) nodes))  (cadr (nth (1- next) Coordinates))))<br />    (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ next)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ next)) Coordinates))))<br />   )<br />    (if (equal a0 a1 0.000001) (setq next (nth kk toupu0))(setq flag1 nil))<br /> (if (not next) (setq flag1 nil))<br /> (setq kk (1+ kk))<br /> )<br />       ;(if next (setq polytoupu (append polytoupu (list (setq next (car toupu0))))))<br />       (if next<br />       (if (> next 0)<br /> (progn<br />    (setq p0 (cadr (assoc  (setq node (nth 4 (nth (1- next) Coordinates))) nodes))<br />   a0 (angle p0 (nth 3 (nth (1- next) Coordinates)))<br />   toupu0 (caddr (assoc next toupulist))<br />   )<br />    (if (equal node nodeEnd) (setq flag nil))<br />    <br />    )<br /> (progn<br />    (setq p0 (cadr (assoc  (setq node (car (nth (abs (1+ next)) Coordinates))) nodes))<br />   a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))<br />   toupu0 (cadr (assoc (abs next) toupulist))<br />   )<br />    (if (equal node nodeEnd) (setq flag nil))<br />    )<br /> )<br /> (setq flag nil)<br /> )<br />      (setq ExitNum (1+ ExitNum))<br />       ;;;搜索边界次数超过2000次，程序陷入死循环，退出<br />       (if (> ExitNum 2000) (setq flag nil ExitFlag t)) <br />       (if (and flag (not ExitFlag))<br /> (progn<br />     ;;;移除重合的线<br />     (setq toupu0 (vl-remove-if<br />      '(lambda (x)<br />         (if (> x 0)<br />    (equal a0 (angle (cadr (assoc  (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)<br />    (equal a0 (angle (cadr (assoc  (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)<br />    )<br />         )<br />      toupu0<br />      )<br />    )<br />     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))<br />    )<br /> )<br />       );_ while<br />     (if ExitFlag<br />       (setq ExitFlag nil)<br />     (setq PolyTouPuList (append PolyTouPuList (list polytoupu)))<br />       )<br />    <br />     ;;;末端点搜索<br />     (setq p0 pend<br />    p1 (nth 3 (nth n Coordinates))<br />    a0 (angle p0 p1) ;_ 起点角度<br />    toupu0 (caddr (assoc xh toupulist))<br />    polytoupu (list xh)<br />    flag  t<br />    )<br />     (setq ExitNum 0  ;_ 循环次数<br />    ExitFlag nil) ;_ 陷入死循环标志<br />         ;;;移除重合的线<br />     (setq toupu0 (vl-remove-if<br />      '(lambda (x)<br />         (if (> x 0)<br />    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)<br />    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)<br />    )<br />         )<br />      toupu0<br />      )<br />    )<br />     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))<br />     (while flag<br />       ;;;计算最小角度相邻边<br />       <br />       (setq toupu0<br />       (vl-sort toupu0<br />         '(lambda (e1 e2)<br />     (if (> e1 0)<br />       (setq a1 (angle (cadr (assoc (car (nth (1- e1) Coordinates)) nodes))  (cadr (nth (1- e1) Coordinates))))<br />       (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ e1)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e1)) Coordinates))))<br />       )<br />     (if (> e2 0)<br />       (setq a2 (angle (cadr (assoc (car (nth (1- e2) Coordinates)) nodes))  (cadr (nth (1- e2) Coordinates))))<br />       (setq a2 (angle (cadr (assoc (nth 4 (nth (abs (1+ e2)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e2)) Coordinates))))<br />       )<br />     (if (>= a0 a1) (setq B1 (- a0 a1)) (setq B1 (+ 2pi (- a0 a1))))<br />     (if (>= a0 a2) (setq B2 (- a0 a2)) (setq B2 (+ 2pi (- a0 a2))))<br />     (< B1 B2)<br />     )<br />         )<br />      )<br />        ;;;判断Next边是否已经在polytoupu里了<br />       ;(if (member next (mapcar 'abs polytoupu)) (setq exitflag t))<br />       (setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号<br />       ;;;验证next 下一邻接边序号的方位角是否和首端点弧段角度a0重合，如重合，找下一边，未找到，结束组多边形<br />       (setq falg1 t<br />      kk 1)<br />       (while flag1<br /> (if (> next 0)<br />    (setq a1 (angle (cadr (assoc (car (nth (1- next) Coordinates)) nodes))  (cadr (nth (1- next) Coordinates))))<br />    (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ next)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ next)) Coordinates))))<br />   )<br />    (if (equal a0 a1 0.000001) (setq next (nth kk toupu0))(setq flag1 nil))<br /> (if (not next) (setq flag1 nil))<br /> (setq kk (1+ kk))<br /> )<br />       ;(if next (setq polytoupu (append polytoupu (list (setq next (car toupu0))))))<br />       (if next<br />       (if (> next 0)<br /> (progn<br />    (setq p0 (cadr (assoc (setq node (nth 4 (nth (1- next) Coordinates))) nodes))<br />   a0 (angle p0 (nth 3 (nth (1- next) Coordinates)))<br />   toupu0 (caddr (assoc next toupulist))<br />   )<br />    (if (equal node nodestart) (setq flag nil))<br />    )<br /> (progn<br />    (setq p0 (cadr (assoc (setq node (car (nth (abs (1+ next)) Coordinates))) nodes))<br />   a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))<br />   toupu0 (cadr (assoc (abs next) toupulist))<br />   )<br />    (if (equal node nodestart) (setq flag nil))<br />    )<br /> )<br />   (setq flag nil)<br /> )<br />        (setq ExitNum (1+ ExitNum))<br />       ;;;搜索边界次数超过2000次，程序陷入死循环，退出<br />       (if (> ExitNum 2000) (setq flag nil ExitFlag t))<br />       (if (and flag (not ExitFlag))<br /> (progn<br />     ;;;移除重合的线<br />     (setq toupu0 (vl-remove-if<br />      '(lambda (x)<br />         (if (> x 0)<br />    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)<br />    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)<br />    )<br />         )<br />      toupu0<br />      )<br />    )<br />     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))<br />    )<br /> )<br />    <br />       ) ;_ while<br />     (if ExitFlag<br />       (setq ExitFlag nil)<br />     (setq PolyTouPuList (append PolyTouPuList (list polytoupu)))<br />       )<br />     )<br />       )<br /> <br />     (setq n (1+ n))<br />     )<br />   (GXL-SYS-PROGRESS-DONE)<br />     ;(princ " \n多边形拓扑 ")<br />   (GXL-SYS-TIMEOUT t2) <br /> ;;;删除多余多边形<br />   (gxl-dumpPolyTouPuList PolyTouPuList)<br />   )<br /> ;|<br /> 6、多余多边形的消除<br /> 由于按照最小角法则搜索出的多边形, 其中部<br /> 分是重复的(例如“岛”被搜索了两次) , 部分是错误<br /> 的(例如外围轮廓多边形) , 因此这两种多边形需要<br /> 去除. 其中重复多边形的去除是从多边形与弧段的<br /> 拓扑关联表中按照边数相等, 且边号绝对值相等的<br /> 原则来进行; 而错误多边形的去除则按照下面原则<br /> 进行: 一个多边形与另一多边形有公共边, 同时它又<br /> 包含另一多边形的非公共边上一点, 则该多边形是<br /> 错误多边形.<br /> |;<br /> ;;;(gxl-dumpPolyTouPuList PolyTouPuList) 删除多余多边形，本函数仅消除重复的多边形，<br /> ;;;外包多边形在实际生成多边形后再予以删除<br /> (defun gxl-dumpPolyTouPuList (PolyTouPuList / rtn pl nn n a)<br />   (setq pl PolyTouPuList<br /> nn (length pl)<br />   ) ;_ setq<br />   ;(grtext -2 "\n处理多余多边形...")<br />   ;(princ)<br />   (GXL-SYS-PROGRESS-INIT "处理多余多边形" nn)<br /> ;;;测试时间<br />   ;(setq t2 (getvar "cdate"))<br />   (while (setq a   (car pl)<br />         rtn (cons a rtn)<br />         pl  (vl-remove-if<br />        '(lambda (x)<br />    (if (= (length a) (length x))<br />      (if (equal (vl-sort (mapcar 'abs x) '<)<br />          (vl-sort (mapcar 'abs a) '<)<br />          ) ;_ equal<br />        t<br />      ) ;_ if<br />    ) ;_ if<br />         ) ;_ lambda<br />        pl<br />      ) ;_ vl-remove-if<br />   ) ;_ setq<br />     (GXL-SYS-PROGRESS  nn -1)<br />   ) ;_ while<br />   (GXL-SYS-PROGRESS-DONE)<br />   ;(GXL-SYS-TIMEOUT t2)<br />   (setq rtn (reverse rtn))<br />   (vl-remove-if<br />     '(lambda (x) (/= (length x) (length (GXL-LISTDUMPATOM (mapcar 'abs x)))))<br />     rtn<br />     )<br /> ) ;_ defun<br /> ;|<br /> 7、根据生成的多边形拓扑表绘制多边形<br /> ;;;(gxl-DrawPolyLine PolyTouPuList ssl Coordinates closed)<br /> 由弧段与多边形拓扑关联表绘制多边形,参数 多边形拓扑关联表 图元名列表 坐标值列表 是否闭合 返回值：多边形选择集<br /> ;;;PolyTouPuList 多边形拓扑表<br /> ;;; ssl 图元名--节点编号表 '((图元名 首节点编号 末节点编号)...)<br /> ;;; nodes 节点--坐标表 '((节点编号 坐标)...)<br /> |;<br /> (defun gxl-DrawPolyLine (PolyTouPuList<br />      ssl     nodes  closed   /     Polytoupu pts<br />      _bulges   mn       ml mk   num     p1       p2<br />      np1     np2       en en1   rtn     coords    n<br />      gxl-DelOutPolyline La_LineType_Color Lay LineType Color xh1 xh2<br />     ) ;_ PolyTouPuList<br />   ;;;(gxl-DelOutPolyline ss) 删除拓扑出poly选择集中外边框,返回删除后的选择集<br /> ;;;(gxl-DelOutPolyline pss)<br /> (defun gxl-DelOutPolyline (ss / ssL ssL1 ent flag en1 rtn)<br />   (setq ssL (GXL-SEL-SS->LIST ss)<br /> rtn (ssadd)<br /> flag t<br /> )<br />   (setq ssL (vl-sort ssL '(lambda (e1 e2) (> (GXL-GETAREA e1) (GXL-GETAREA e2)))))<br />   <br />   (while flag<br />     (setq ent (car ssL)<br /> ssL (cdr ssL)<br /> ssL1 '()<br /> flag1 nil<br /> )<br />     (while ssL<br />       (setq en1 (car ssL)<br />      ssL (cdr ssL)<br />       ) ;_ setq<br />       (if (PolyInLwpolyLine en1 ent)<br /> (setq  flag1 t)<br /> (setq ssL1 (cons en1 ssL1))<br />       ) ;_ if<br />     ) ;_ while<br />     (if flag1 (progn (ssdel ent ss)(entdel ent)(setq flag1 nil)))<br />     (if ssL1<br /> (setq ssL (vl-sort ssL1 '(lambda (e1 e2) (> (GXL-GETAREA e1) (GXL-GETAREA e2)))))<br />       (setq flag nil)<br />       )<br />   ) ;_ while<br />   ss<br />   )<br />   (setq rtn (ssadd))<br />   (if (not *jd*) (setq *jd* 0.0001))<br />   (foreach Polytoupu PolyTouPuList<br />     (setq pts nil<br />    _bulges nil<br />    mn (length Polytoupu)<br />    mk 0<br />    )<br />    ;(if closed (setq mk 0) (setq mk -1))<br />     (foreach num Polytoupu<br />       (setq mk (1+ mk))<br />       <br />       (setq en (car (nth (1- (abs num)) ssl))<br />      xh1 (cadr (nth (1- (abs num)) ssl))<br />      xh2 (caddr (nth (1- (abs num)) ssl))<br />      ;coords (nth (1- (abs num)) Coordinates)<br />      entype (gxl-dxf en 0)<br />      )<br />       <br />       (if (> num 0)<br /> (setq p1 (cadr (assoc xh1 nodes))<br />        p2 (cadr (assoc xh2 nodes))<br /> ) ;_ setq<br /> (setq p1 (cadr (assoc xh2 nodes))<br />        p2 (cadr (assoc xh1 nodes))<br /> ) ;_ setq<br />       ) ;_ if<br />       (cond ((= entype "LINE")<br />       (if pts<br />         (setq pts (append pts (list p2))<br />        _bulges (append _bulges (list 0))<br />        )<br />         (setq pts (append pts (list p1 p2))<br />        _bulges (append _bulges (list 0))<br />        )<br />       ) ;_ if<br />       <br />       <br />       )<br />      ((= entype "ARC")<br />       (if pts<br />         (setq pts (append pts (list p2))<br />        _bulges (append _bulges (list (cond ((> num 0) (gxl-GetArcBulge en)) (t (* -1.0 (gxl-GetArcBulge en))))))<br />        )<br />         (setq pts (append pts (list p1 p2))<br />        _bulges (append _bulges (list (cond ((> num 0) (gxl-GetArcBulge en)) (t (* -1.0 (gxl-GetArcBulge en))))))<br />        )<br />       )<br />       )<br />      ((= entype "LWPOLYLINE")<br />       (setq data (gxl-get_poly_data en))<br />       <br />       (if (> num 0)<br />         (progn<br />    (if pts<br />      (progn<br />    (setq pts (append pts (cdar data)))<br />    (setq _bulges (append _bulges (reverse (cdr (reverse (cadr data))))))<br />    )<br />      (progn<br />        (setq pts (append pts (cons p1 (cdar data))))<br />        (setq _bulges (append _bulges (cadr data)))<br />        )<br />      )<br />         ) ;_ progn<br />         (progn<br />    (GXL-REVERSELWPOLYLINE en)<br />    (setq data (gxl-get_poly_data en))<br />    (if pts<br />      (progn<br />    (setq pts (append pts (cdar data)))<br />    (setq _bulges (append _bulges (reverse (cdr (reverse (cadr data))))))<br />    )<br />      (progn<br />        (setq pts (append pts (cons p1 (cdar data))))<br />        (setq _bulges (append _bulges (cadr data)))<br />        )<br />      )<br />    (GXL-REVERSELWPOLYLINE en)<br />         ) ;_ progn<br />       ) ;_ if<br />       )<br />      )<br />       <br />       )<br />     ;(if (= entype "LWPOLYLINE") (setq _bulges  (append _bulges (list (last (cadr data))))) (setq _bulges  (append _bulges (list 0))))     <br />    (if closed<br />      (vla-put-closed (GXL-AX:ADDLWPOLYLINE1 *MODEL-SPACE* (list pts _bulges )) :vlax-true)<br />      (GXL-AX:ADDLWPOLYLINE1 *MODEL-SPACE* (list pts _bulges))<br />      )<br />     (setq app pts<br />    bus _bulges)<br />     (ssadd (setq en (entlast)) rtn)<br />     ;;;修改多段线图层<br />     (setq La_LineType_Color (gxl-GetToupuPolyLayer_Linetype_color Polytoupu (mapcar 'car ssl)))<br />     (setq lay (car La_LineType_Color)<br />    LineType (cadr La_LineType_Color)<br />    Color (caddr La_LineType_Color)<br />    )<br />     (gxl-CH_Ent en 8 lay)<br />     (if LineType (gxl-CH_Ent en 6 LineType))<br />     (if color (gxl-CH_Ent en 62 color))<br />     (gxl-DumpPolyPoint en)<br />     ;(vla-put-closed (GXL-AX:ADDLWPOLYLINE *MODEL-SPACE* pts) :vlax-true)<br />     )<br />   (if closed (gxl-DelOutPolyline rtn) rtn) ;_ 返回删除外框后的选择集<br />   )<br /> ;;;测试<br /> (defun c:mkpoly ()<br />   (SETUNDOERR)<br />    (if (not *jd*) (setq *jd* 0.00001))<br />   (princ "\n基于方位角计算的拓扑多边形自动构建快速算法测试")<br />   (princ "\n****程序作者：Gu_xl 2010年8月****")<br />   (princ "\n选择直线、圆弧、圆：")<br />   (setq ss (ssget '((0 . "line,arc,circle"))))<br />   (gxl-makepoly ss)<br />   (reerr)<br />   )<br /> ;;;至此，基于方位角计算的拓扑多边形自动构建快速算法 的主要算法思路的函数功能全部完成，<br /> ;;;附件是打包的测试程序，调用命令：mkpoly<br /> <br />

露水2

再考虑 椭圆  spl线

dengtui

  学习学习