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

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

本帖最后由 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

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

一些程序用到的函数[code="lisp]
;;;==================================================================
;;;(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)
)[/code]

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

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

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

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

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

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

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

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

最佳答案