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

Gu_xl · 发表于 2010-8-7 23:35

本帖最后由 Gu_xl 于 2013-6-11 10:44 编辑

源码:

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

一些程序用到的函数

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

;;;================================================================== 
;;;(gxl-Sys-TimeOut t1) 耗尽用时计算函数 
;;;================================================================== 
(defun gxl-Sys-TimeOut (t1 / t2 t3 t4 t5 t6 t7 t8) 
(setq t2 (getvar "Cdate")) 
(setq t3 t1) 
(setq t4 (fix (* 100 t3)) 
t5 (- (fix (* 10000 t3)) (* t4 100)) 
t6 (- (* 1000000 t3) (* t5 100) (* t4 10000)) 
t7 (+ (* t4 3600) (* t5 60) t6) 
) 
(setq t3 t2) 
(setq t4 (fix (* 100 t3)) 
t5 (- (fix (* 10000 t3)) (* t4 100)) 
t6 (- (* 1000000 t3) (* t5 100) (* t4 10000)) 
t8 (+ (* t4 3600) (* t5 60) t6) 
) 
(princ "\n 用时 ") 
(princ (- t8 t7)) 
(princ " 秒 ") 
(princ) 
) 
;;;================================================================================================ 
;;; 进程条初始化 (gxl-Sys-Progress-Init 提示 进程总数) 
;;; 进程步进 (gxl-Sys-Progress 进程总数 -1) 
;;; 进程结束 (gxl-Sys-Progress-Done) 
(setq *ProgressID* 0 
*ProgressPrompt* "" 
*ProgressBFB* " 0%") 
 
(defun gxl-Sys-Progress-Init (str to) 
(if *FlagINIT* (alert "上一次进程条没有结束！")) 
(setq *ProgressID* 0 
*ProgressTo* to 
*ProgressPrompt* str 
*ProgressBFB* 2 
*FlagINIT* T) 
) 
(defun gxl-Sys-Progress-Done () 
(setq *ProgressID* 0 
*ProgressTo* nil 
*ProgressPrompt* "" 
*ProgressBFB* 2 
*FlagINIT* nil) 
(setvar "modemacro" "") 
) 
 
;;;进程条函数,to 为进程总数，i为已到达进程数 
;;;第一次使用 i应为1，以后 i = -1 为步进数，也可以为已到达进程数 
 
(defun gxl-Sys-Progress (to i / CS_TEXT MYI bfb corstate LL) 
;(setq cs_text ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>") 
;(setq corstate (getvar "coords")) 
;(setvar "coords" 0) 
;(setq cs_text "||||||||||||||||||||||||||||||" 
; LL (strlen cs_text) 
(if (and *FlagINIT* *ProgressTo*) 
(setq to *ProgressTo*) 
) 
(setq cs_text "████████████████████" 
LL (strlen cs_text) 
) 
(if (= -1 i) 
(setq i (1+ *ProgressID*) 
*ProgressID* i 
) 
(setq *ProgressID* i) 
) 
(if (> i to) 
(setq i to) 
) 
(setq myi (fix (/ (* (strlen cs_text) i) to)) 
myi (* 2 (/ myi 2)) 
) 
(if (= 0 myi) 
(setq myi 2) 
) 
(if (/= *ProgressBFB* myi) 
(progn 
(setq 
cs_text (substr cs_text 1 myi) 
cs_text (strcat cs_text (gxl-Str-Space (- LL myi))) 
) 
 
(setq bfb (fix (* 100 i (/ 1.0 to)))) 
(setq bfb (itoa bfb)) 
(cond 
((= 1 (strlen bfb)) 
(setq bfb (strcat " " bfb "% ")) 
) 
((= 2 (strlen bfb)) (setq bfb (strcat " " bfb "% "))) 
((= 3 (strlen bfb)) (setq bfb (strcat bfb "% "))) 
) 
;(grtext -1 (strcat "已完成" cs_text bfb)) 
(setvar "modemacro" 
(strcat *ProgressPrompt* 
"已完成" 
cs_text 
bfb 
) 
) 
(setq *ProgressBFB* myi) 
 
) 
(if (= 2 myi) 
(progn 
(setvar "modemacro" 
(strcat *ProgressPrompt* 
"已完成" 
"| " 
"1%" 
) 
) 
) ;progn 
) ;if 
) 
;(setvar "coords" corstate) 
) 
;;;gxl-Sel-EntNextAll en 返回 en 之后的所有物体选择集，无则返回 nil 
(defun gxl-Sel-EntNextAll (ent / ss ent1) 
(setq ss (ssadd)) 
(while (setq ent1 (entnext ent)) 
(ssadd ent1 ss) 
(setq ent ent1) 
) 
(if (= 0 (sslength ss)) 
nil 
ss 
) 
) 
;;;选择集转为图元列表 
(defun gxl-Sel-SS->List (ss / cs_i out) 
(if (= (type ss) 'PICKSET) 
(progn 
(setq cs_i 0.0 
out '() 
) 
(repeat (sslength ss) 
(setq out (cons (ssname ss cs_i) out)) 
(setq cs_i (1+ cs_i)) 
) 
(setq out (reverse out)) 
) 
) 
) 
(defun gxl-Sel-List->SS (Lst / en ss) 
(setq ss (ssadd) 
kk 0) 
(foreach en Lst 
(ssadd en ss) 
(setq kk (1+ kk)) 
) 
ss 
) 
;;;================================================================== 
;;;(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次方来运算，如果有人感兴趣的话，我会将优化后的代码发上来，并详细说明优化思路，优化后运行速度与边数成线性关系！测试命令：mkpoly
附件已更新，支持椭圆、spline！2011年1月27日

flowerson · 发表于 2011-12-13 19:26

本帖最后由 flowerson 于 2011-12-13 19:29 编辑

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

chshsl · 发表于 2018-1-10 11:01

本帖最后由 chshsl 于 2018-1-10 11:02 编辑

;;;==================================================================
;;;(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 · 发表于 2017-8-9 11:01

本帖最后由 chshsl 于 2017-8-9 11:17 编辑

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

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

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

danxingpen · 发表于 2010-8-8 08:18

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

highflybird · 发表于 2010-8-8 12:29

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

Gu_xl · 发表于 2010-8-9 11:33

本帖最后由 Gu_xl 于 2011-1-26 20:20 编辑

动画演示

danxingpen · 发表于 2010-8-10 10:38

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

caddog · 发表于 2010-12-17 11:11

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

Gu_xl · 发表于 2010-12-17 11:16

自己定义如下函数试试

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

Gu_xl · 发表于 2011-1-26 19:48

本帖最后由 Gu_xl 于 2011-10-12 15:27 编辑

优化算法后的代码：

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

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

露水2 · 发表于 2011-1-26 20:29

再考虑椭圆 spl线

dengtui · 发表于 2011-1-26 21:28

学习学习

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

点评

辅助函数复原

本帖子中包含更多资源

本帖子中包含更多资源

点评

评分