社区 › AutoLISP/Visual LISP 编程技术 › gu 版《基于方位角计算的拓扑多边形自动构建快速算法》的源码

飞鱼StrawHaat 发表于 2020-5-14 22:29:44

gu 版《基于方位角计算的拓扑多边形自动构建快速算法》的源码

本帖最后由 Gu_xl 于 2021-3-3 15:39 编辑

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

其地址：
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=82692&extra=page%3D2%26filter%3Dtypeid%26typeid%3D109%26orderby%3Ddateline


待写的程序需要参考 gu 版“构建多边形”的思路， 源码谁能共享一下。

由于本人的发帖数未能达到要求，帖子中的隐藏内容看不到。

lrd1861 发表于 2020-5-14 22:29:45

;;;===============================================================================================
;;;基于方位角计算的拓扑多边形自动构建快速算法
;;;===============================================================================================
;;;线段图元进行预处理，构建线段图元表,自动交点打断后生成图元表，参见论坛里其他帖子，预处理后的直线、圆弧互相首位连接
;;;(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)
)

cawy113116 发表于 2021-2-28 19:02:16

请教一下，这个(setundoerr)是什么函数呢 ？

38804965@qq.com 发表于 2021-9-22 23:49:25

感谢分享，前辈以前做的研究太厉害了

nayipiantian999 发表于 2021-12-30 15:00:57

提示错误: 输入的字符串太长，啥原因？

查看完整版本: gu 版《基于方位角计算的拓扑多边形自动构建快速算法》的源码