【Gu_xl】基于方位角计算的拓扑多边形自动构建快速算法
本帖最后由 Gu_xl 于 2013-6-11 10:44 编辑源码:
;;;===============================================================================================
;;;基于方位角计算的拓扑多边形自动构建快速算法
;;;===============================================================================================
;;;线段图元进行预处理，构建线段图元表,自动交点打断后生成图元表，参见论坛里其他帖子，预处理后的直线、圆弧互相首位连接
;;;(gxl-Break_ss ss)
;;;根据线段图元表构建二维坐标表'((首端点 末端点)...)
(defun gxl-ent->Coordinates (enLst)
(mapcar '(lambda (x)
(list (list (car (setq a (vlax-curve-getStartPoint x))) (cadr a))
(list (car (setq a (vlax-curve-getendPoint x))) (cadr a))
) ;_ list
) ;_ lambda
enlst
) ;_ mapcar
) ;_ defun
;;;根据二维坐标表建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)，从 1 开始
;|若某一弧段N 的首端点与另一弧段
相关联, 则在弧段拓扑邻接关系表中标记为N ; 若
末端点与另一弧段相关联, 则标记为- N
|;
;;;如果拓扑表中有nil,则表明线段有断头、悬挂的情况
(defun gxl-Toupu-LineList (Coordinates / toupulist nn n k pstart pend pl new old t2)
;;;测试时间
(setq t2 (getvar "cdate"))
(setq nn (length Coordinates)
n 1)
;;;建立一个拓扑空表 '((1 '() '()) (2 '() '()) ...),以序号索引
(repeat nn
(setq toupulist (append toupulist (list (list n nil nil))))
(setq n (1+ n))
)
(setq n 0
to (* nn nn))
(GXL-SYS-PROGRESS-INIT "拓扑邻接表" to)
(repeat nn
(setq pstart (car (setq pl (nth n Coordinates)))
pend (cadr pl)
)
(setq k 0)
(repeat nn
(GXL-SYS-PROGRESS to -1)
(if (/= n k)
(progn
(setq pstart1 (car (setq pl (nth k Coordinates)))
pend1 (cadr pl)
)
(if (equal pstart pstart1 0.000001)
(progn
(setq old (assoc (1+ k) toupulist))
(setq new (list (1+ k) (append (cadr old) (list (1+ n))) (caddr old)))
(setq toupulist (subst new old toupulist))
)
(if (equal pstart pend1 0.000001)
(progn
(setq old (assoc (1+ k) toupulist))
(setq new (list (1+ k) (cadr old) (append (caddr old) (list (1+ n)))))
(setq toupulist (subst new old toupulist))
)
)
)
(if (equal pend pstart1 0.000001)
(progn
(setq old (assoc (1+ k) toupulist))
(setq new (list (1+ k) (append (cadr old) (list (* -1 (1+ n)))) (caddr old)))
(setq toupulist (subst new old toupulist))
)
(if (equal pend pend1 0.000001)
(progn
(setq old (assoc (1+ k) toupulist))
(setq new (list (1+ k) (cadr old) (append (caddr old) (list (* -1 (1+ n))))))
(setq toupulist (subst new old toupulist))
)
)
)
)
)
(setq k (1+ k))
)
(setq n (1+ n))
)
(GXL-SYS-PROGRESS-DONE)
(princ " \n弧段拓扑邻接表")
(GXL-SYS-TIMEOUT t2)
toupulist
)
;;;根据建立的弧段拓扑邻接表，按照最小角法则搜索多边形，返回 弧段与多边形拓扑关联表 '((多边形序号 (弧段号 ...))...)
;|一条弧段可作为一个或两个多边形的组成边而
存在, 亦即从一条弧段出发最多可以搜索出两个正确
的多边形. 如图2 所示, 若从弧段A 1 的一端O 出发,
并把它作为起始弧段, 把与A 1 的O 端拓扑关联的其
它弧段作为中止弧段, 然后比较并找出与A 1 夹角最
小的中止弧段A 2, 并把A 2 作为新的起始弧段, 再从
它的另一端点出发重复以上过程继续搜索, 直到回到
出发弧段A 1 的另一端为止, 则所有搜索出的弧段就
构成了一个多边形. 同样, 从A 1 的O 端开始, 并把它
作为中止弧段, 把与它拓扑关联的其它弧段作为起始
弧段, 然后比较并找出与该弧段夹角最小的弧段, 并
把找出的弧段作为新的中止弧段, 再从新弧段的另一
端点出发重复以上搜索过程, 直到回到A 1 的另一端
为止, 则所有搜索出的弧段就构成了另一个多边形.
这样, 从一条弧段出发可以跟踪出两个多边形, 此方
法可称为多边形搜索的最小角法则.
多边形的搜索按照最小角法则进行. 从编号为
1 的弧段的始端出发, 查找弧段拓扑邻接表中与该
端点关联的弧段, 按照最小角法则可以搜索出两个
多边形. 依照上述方法, 依次把其它弧段作为开始弧
段, 共可找出2N (N 为总弧段数) 个多边形. 搜索过
程中, 记录构成多边形的弧段编号(一弧段首端与上
一弧段关联用正边号, 否则用负边号) 和弧段数, 即
形成多边形与弧段的拓扑关联表.
|;
(defun gxl-MakePolyList (toupulist Coordinates / PolyTouPuList nn n
pstart pend flag p0 p1 a0 a1
a2 B1 B2 polytoupu toupu0 next t2
)
;;;测试时间
(setq t2 (getvar "cdate"))
(setq nn (length toupulist)
n 0
to nn)
(GXL-SYS-PROGRESS-INIT "拓扑多边形" to)
(repeat nn
(GXL-SYS-PROGRESS to -1)
(setq pstart (car (nth n Coordinates))
pend (cadr (nth n Coordinates))
flag t
) ;_ setq
;;;首端点搜索多边形
(setq p0 pstart
p1 pend
a0 (angle p0 p1) ;_ 首端点弧段角度
toupu0 (cadr (nth n toupulist)) ;_ 首端点弧段拓扑邻接表
polytoupu (list (1+ n))
)
(while flag
;;;计算最小角度相邻边
(setq toupu0
(vl-sort toupu0
'(lambda (e1 e2)
(if (> e1 0)
(setq a1 (angle (car (nth (1- e1) Coordinates))(cadr (nth (1- e1) Coordinates))))
(setq a1 (angle (cadr (nth (abs (1+ e1)) Coordinates))(car (nth (abs (1+ e1)) Coordinates))))
)
(if (> e2 0)
(setq a2 (angle (car (nth (1- e2) Coordinates))(cadr (nth (1- e2) Coordinates))))
(setq a2 (angle (cadr (nth (abs (1+ e2)) Coordinates))(car (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)
)
)
)
(setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号
(if (> next 0)
(progn
(setq p0 (cadr (nth (1- next) Coordinates))
a0 (angle p0 (car (nth (1- next) Coordinates)))
toupu0 (caddr (nth (1- next) toupulist))
)
(if (equal p0 pend 0.00001) (setq flag nil))
)
(progn
(setq p0 (car (nth (abs (1+ next)) Coordinates))
a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))
toupu0 (cadr (nth (abs (1+ next)) toupulist))
)
(if (equal p0 pend 0.00001) (setq flag nil))
)
)
)
(setq PolyTouPuList (append PolyTouPuList (list polytoupu)))
;;;末端点搜索
(setq p0 pend
p1 pstart
a0 (angle p0 p1) ;_ 起点角度
toupu0 (caddr (nth n toupulist))
polytoupu (list (* -1 (1+ n)))
flag t
)
(while flag
;;;计算最小角度相邻边
(setq toupu0
(vl-sort toupu0
'(lambda (e1 e2)
(if (> e1 0)
(setq a1 (angle (car (nth (1- e1) Coordinates))(cadr (nth (1- e1) Coordinates))))
(setq a1 (angle (cadr (nth (abs (1+ e1)) Coordinates))(car (nth (abs (1+ e1)) Coordinates))))
)
(if (> e2 0)
(setq a2 (angle (car (nth (1- e2) Coordinates))(cadr (nth (1- e2) Coordinates))))
(setq a2 (angle (cadr (nth (abs (1+ e2)) Coordinates))(car (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)
)
)
)
(setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号
(if (> next 0)
(progn
(setq p0 (cadr (nth (1- next) Coordinates))
a0 (angle p0 (car (nth (1- next) Coordinates)))
toupu0 (caddr (nth (1- next) toupulist))
)
(if (equal p0 pstart 0.00001) (setq flag nil))
)
(progn
(setq p0 (car (nth (abs (1+ next)) Coordinates))
a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))
toupu0 (cadr (nth (abs (1+ next)) toupulist))
)
(if (equal p0 pstart 0.00001) (setq flag nil))
)
)
)
(setq PolyTouPuList (append PolyTouPuList (list polytoupu)))
(setq n (1+ n))
)
(GXL-SYS-PROGRESS-DONE)
(princ " \n多边形拓扑 ")
(GXL-SYS-TIMEOUT t2)
PolyTouPuList
)
;;;多余多边形的消除
;|由于按照最小角法则搜索出的多边形, 其中部
分是重复的(例如“岛”被搜索了两次) , 部分是错误
的(例如外围轮廓多边形) , 因此这两种多边形需要
去除. 其中重复多边形的去除是从多边形与弧段的
拓扑关联表中按照边数相等, 且边号绝对值相等的
原则来进行; 而错误多边形的去除则按照下面原则
进行: 一个多边形与另一多边形有公共边, 同时它又
包含另一多边形的非公共边上一点, 则该多边形是
错误多边形.
|;
(defun gxl-dumpPolyTouPuList (PolyTouPuList / rtn pl nn n a)
(setq pl PolyTouPuList
nn (length pl)
)
(princ "\n处理多余多边形...")
;;;测试时间
(setq t2 (getvar "cdate"))
(while (setq a (car pl)
rtn(cons a rtn)
pl (vl-remove-if '(lambda (x) (equal (vl-sort (mapcar 'abs x) '<) (vl-sort (mapcar 'abs a) '<))) pl)
)
)
(GXL-SYS-TIMEOUT t2)
(reverse rtn)
)
;;;测试
(defun c:tt ()
(setundoerr)
(princ "\n自动拓扑多边形测试！编制：Gu_xl 2010年8月")
(princ "\n选择线段：")
;;;选择的线段必须已经做完打断预处理，请自行添加处理代码
(setq ss (ssget '((0 . "line,arc"))))
(setq t1 (getvar "cdate"))
(setq ssl (GXL-SEL-SS->LIST ss))
(setq coordlist (gxl-ent->Coordinates ssl))
(setq touplist (gxl-Toupu-LineList coordlist))
(setq polylist (gxl-MakePolyList touplist coordlist))
(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-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:29 编辑
期待版主公布更多的源码！不太懂的版友们是要自己不断拿源码调试修改才能变成自己的。或者说这个就是模仿过程。我也知道大概的原理楼主已经公布了。对于不够精的版友来说，差一点不会就不会。差之毫厘失之千里。当然也尊重楼主的知识产权，如果不方便也非常能理解！ 本帖最后由 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 /als )
(setq ls '())
(while (assoc d li)
(progn
(setqa (assoc d li))
(setq ls (cons (list (cadr a) (caddr a)) ls))
(setq li (xdlsp_list_remove lia))
)
)
(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: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 /als )
(setq ls '())
(while (assoc d li)
(progn
(setqa (assoc d li))
(setq ls (cons (list (cadr a) (caddr a)) ls))
(setq li (xdlsp_list_remove lia))
)
)
(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)
) <p>虽然看不懂但觉得一定会有用途，先收藏，以后慢慢看!</p> <p>好帖啊，板凳欣赏中。。。</p> 本帖最后由 Gu_xl 于 2011-1-26 20:20 编辑 <br /><br /><P>动画演示</P>
<P> </P> <p>好像是要编辑，，，然后点上传附件，，，，</p> 下了MKPOLY.RAR，为什么加载后提示“mkpoly 未知命令“MKPOLY”。按 F1 查看帮助。”呢？ 自己定义如下函数试试
(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-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 tmptoupulist1)) (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 / PolyTouPuListnn
n xh pstart pend flag p0p1
a0 a1 a2 B1 B2 polytoupu
toupu0 next t2 kk ExitNum ExitFlag Nodestart
NodeEndnode
) ;_ 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))
flagt
) ;_ 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)
flagt
)
(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-PROGRESSnn -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 nodesclosed / 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)
(setqflag1 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
再考虑 椭圆spl线 学习学习