明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 109780|回复: 351

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

    [复制链接]
发表于 2010-8-7 23:35:00 | 显示全部楼层 |阅读模式
本帖最后由 Gu_xl 于 2013-6-11 10:44 编辑

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

一些程序用到的函数

  1. ;;;==================================================================
  2. ;;;(gxl-Sys-TimeOut t1) 耗尽用时计算函数
  3. ;;;==================================================================
  4. (defun gxl-Sys-TimeOut (t1 / t2 t3 t4 t5 t6 t7 t8)
  5. (setq t2 (getvar "Cdate"))
  6. (setq t3 t1)
  7. (setq t4 (fix (* 100 t3))
  8. t5 (- (fix (* 10000 t3)) (* t4 100))
  9. t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))
  10. t7 (+ (* t4 3600) (* t5 60) t6)
  11. )
  12. (setq t3 t2)
  13. (setq t4 (fix (* 100 t3))
  14. t5 (- (fix (* 10000 t3)) (* t4 100))
  15. t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))
  16. t8 (+ (* t4 3600) (* t5 60) t6)
  17. )
  18. (princ "\n 用时 ")
  19. (princ (- t8 t7))
  20. (princ " 秒 ")
  21. (princ)
  22. )
  23. ;;;================================================================================================
  24. ;;; 进程条初始化 (gxl-Sys-Progress-Init 提示 进程总数)
  25. ;;; 进程步进 (gxl-Sys-Progress 进程总数 -1)
  26. ;;; 进程结束 (gxl-Sys-Progress-Done)
  27. (setq *ProgressID* 0
  28. *ProgressPrompt* ""
  29. *ProgressBFB* " 0%")

  30. (defun gxl-Sys-Progress-Init (str to)
  31. (if *FlagINIT* (alert "上一次进程条没有结束!"))
  32. (setq *ProgressID* 0
  33. *ProgressTo* to
  34. *ProgressPrompt* str
  35. *ProgressBFB* 2
  36. *FlagINIT* T)
  37. )
  38. (defun gxl-Sys-Progress-Done ()
  39. (setq *ProgressID* 0
  40. *ProgressTo* nil
  41. *ProgressPrompt* ""
  42. *ProgressBFB* 2
  43. *FlagINIT* nil)
  44. (setvar "modemacro" "")
  45. )

  46. ;;;进程条函数,to 为进程总数,i为已到达进程数
  47. ;;;第一次使用 i应为1,以后 i = -1 为步进数,也可以为已到达进程数

  48. (defun gxl-Sys-Progress (to i / CS_TEXT MYI bfb corstate LL)
  49. ;(setq cs_text ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>")
  50. ;(setq corstate (getvar "coords"))
  51. ;(setvar "coords" 0)
  52. ;(setq cs_text "||||||||||||||||||||||||||||||"
  53. ; LL (strlen cs_text)
  54. (if (and *FlagINIT* *ProgressTo*)
  55. (setq to *ProgressTo*)
  56. )
  57. (setq cs_text "████████████████████"
  58. LL (strlen cs_text)
  59. )
  60. (if (= -1 i)
  61. (setq i (1+ *ProgressID*)
  62. *ProgressID* i
  63. )
  64. (setq *ProgressID* i)
  65. )
  66. (if (> i to)
  67. (setq i to)
  68. )
  69. (setq myi (fix (/ (* (strlen cs_text) i) to))
  70. myi (* 2 (/ myi 2))
  71. )
  72. (if (= 0 myi)
  73. (setq myi 2)
  74. )
  75. (if (/= *ProgressBFB* myi)
  76. (progn
  77. (setq
  78. cs_text (substr cs_text 1 myi)
  79. cs_text (strcat cs_text (gxl-Str-Space (- LL myi)))
  80. )

  81. (setq bfb (fix (* 100 i (/ 1.0 to))))
  82. (setq bfb (itoa bfb))
  83. (cond
  84. ((= 1 (strlen bfb))
  85. (setq bfb (strcat " " bfb "% "))
  86. )
  87. ((= 2 (strlen bfb)) (setq bfb (strcat " " bfb "% ")))
  88. ((= 3 (strlen bfb)) (setq bfb (strcat bfb "% ")))
  89. )
  90. ;(grtext -1 (strcat "已完成" cs_text bfb))
  91. (setvar "modemacro"
  92. (strcat *ProgressPrompt*
  93. "已完成"
  94. cs_text
  95. bfb
  96. )
  97. )
  98. (setq *ProgressBFB* myi)

  99. )
  100. (if (= 2 myi)
  101. (progn
  102. (setvar "modemacro"
  103. (strcat *ProgressPrompt*
  104. "已完成"
  105. "| "
  106. "1%"
  107. )
  108. )
  109. ) ;progn
  110. ) ;if
  111. )
  112. ;(setvar "coords" corstate)
  113. )
  114. ;;;gxl-Sel-EntNextAll en 返回 en 之后的所有物体选择集,无则返回 nil
  115. (defun gxl-Sel-EntNextAll (ent / ss ent1)
  116. (setq ss (ssadd))
  117. (while (setq ent1 (entnext ent))
  118. (ssadd ent1 ss)
  119. (setq ent ent1)
  120. )
  121. (if (= 0 (sslength ss))
  122. nil
  123. ss
  124. )
  125. )
  126. ;;;选择集转为图元列表
  127. (defun gxl-Sel-SS->List (ss / cs_i out)
  128. (if (= (type ss) 'PICKSET)
  129. (progn
  130. (setq cs_i 0.0
  131. out '()
  132. )
  133. (repeat (sslength ss)
  134. (setq out (cons (ssname ss cs_i) out))
  135. (setq cs_i (1+ cs_i))
  136. )
  137. (setq out (reverse out))
  138. )
  139. )
  140. )
  141. (defun gxl-Sel-List->SS (Lst / en ss)
  142. (setq ss (ssadd)
  143. kk 0)
  144. (foreach en Lst
  145. (ssadd en ss)
  146. (setq kk (1+ kk))
  147. )
  148. ss
  149. )
  150. ;;;==================================================================
  151. ;;;(gxl-dxf ent i )取出图元索引i对应的值
  152. ;;;==================================================================
  153. (defun gxl-dxf (ent i)
  154. (if (= (type ent) 'ename)
  155. (setq ent (entget ent))
  156. )
  157. (cdr (assoc i ent))

  158. )
  159. ;;;==================================================================
  160. ;;;(gxl-CH_Ent ent i pt) 用新值pt更新图元ent索引i对应的值
  161. ;;;==================================================================
  162. (defun gxl-CH_Ent (ent i pt / en)
  163. (if (assoc i (setq en (entget ent)))
  164. (setq en (subst (cons i pt) (assoc i en) en))
  165. (setq en (append en (list (cons i pt))))
  166. )
  167. (entmod en)
  168. )

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

这个太牛了,必须点赞!  发表于 2017-8-2 23:58

评分

参与人数 2明经币 +2 收起 理由
jiaxin_1111 + 1
H-浩浩-H + 1 很给力!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

发表于 2011-12-13 19:26:11 | 显示全部楼层
本帖最后由 flowerson 于 2011-12-13 19:29 编辑

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

点评

说的很有道理,有的我看了多天也没找到感觉,但又不好问的太多。就算了吧,就多上上明经吧。公布了的,想是G版主的雷锋精神再次光大了啊,再次向让我等看到源码并能用能理解的G版主表示感谢,衷心的感谢  发表于 2012-11-6 13:22
回复 支持 1 反对 0

使用道具 举报

发表于 2018-1-10 11:01:27 | 显示全部楼层
本帖最后由 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
)

这次应该是齐了,因为我这里运行已经没问题了。
发表于 2017-8-9 11:01:30 | 显示全部楼层

辅助函数复原

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

经过2天的研究G大侠的代码及网盘函数库,复原了,所缺的几个函数,见大家都希望补全,现贴上。希望G大侠不要见怪。用法:1楼中的 辅助函数+8楼代码+本代码。
  1. ;命令: (gxl-massoc 10 (entget (car (entsel "选择多段线:")))) 选择多段线:((35846.5 18949.5)
  2. ;(36264.4 18956.0) (36617.2 18954.3))
  3. ;

  4. (defun gxl-massoc ( d li /  a  ls )
  5.         (setq ls '())
  6.         (while (assoc d li)
  7.                 (progn
  8.                         (setq  a (assoc d li))
  9.                         (setq ls (cons (list (cadr a) (caddr a)) ls))
  10.                         (setq li (xdlsp_list_remove li  a))
  11.                 )
  12.         )
  13.         (reverse ls)
  14. )

  15. (defun xdlsp_list_remove (el val)
  16.   (if (member val el)
  17.     (append
  18.       (reverse (cdr (member val (reverse el))))
  19.       (cdr (member val el))
  20.     )
  21.     el
  22.   )
  23. )

  24. ;输出50个空格
  25. ;(gxl-Str-Space 50) "                                                  "
  26. ;(gxl-Str-Space -1)
  27. (defun gxl-Str-Space ( d  /  a )
  28.     (setq a "")
  29.         (if (>  d 0)
  30.                 (repeat d
  31.                   (setq a (strcat a " " ))
  32.                  )
  33.         )
  34.         a
  35. )

  36. ;删除表中重复项
  37. (defun gxl-ListDumpAtom( l1 /  l2)
  38. (while(setq l2(cons(car l1)l2) l1(vl-remove(car l1)(cdr l1))))
  39. (reverse l2)
  40. )
  41. ;;主测试函数

  42. ;;;测试
  43. (defun c:mkpoly2 ()
  44.   ;;(setundoerr)
  45.   (princ "\n自动拓扑多边形测试!编制:Gu_xl 2010年8月")
  46.   (princ "\n选择线段:")
  47.   ;;;选择的线段必须已经做完打断预处理,请自行添加处理代码
  48.   ;(if (not jd) (setq jd 0.00001))
  49.   (setq jd 0.00001)
  50.   (setq ss (ssget '((0 . "line,arc"))))
  51.   (setq t1 (getvar "cdate"))
  52.   (setq ssl (GXL-SEL-SS->LIST ss))
  53.   (setq nod1 (gxl-ent->Nodes ssl jd))
  54.   (setq coordlist (gxl-ent->Coordinates  (car nod1)))
  55.   (setq touplist (gxl-Toupu-LineList coordlist))
  56.   (setq polylist (gxl-MakePolyList touplist coordlist  (cadr nod1)))
  57.   (setq polylist (gxl-dumpPolyTouPuList polylist))
  58.   (setq n 1)
  59.   (foreach poly polylist
  60.     (setq enlist (mapcar '(lambda (x) (nth (1- (abs x)) ssl)) poly)
  61.   enss (GXL-SEL-LIST->SS enlist)
  62.   )
  63.     (setq en (entlast))
  64.     (command "copy" enss "" '(0 0 0) '(0 0 0))
  65.     (setq enss (GXL-SEL-ENTNEXTALL en))
  66.     (command "pedit" (ssname enss 0) "y" "j" enss "" "")
  67.     (setq en (entlast))
  68.     (gxl-CH_Ent en 62 1)
  69.     (gxl-CH_Ent en 8 "多边形层")
  70.     )
  71.   (princ "\n总计 ")
  72.   (GXL-SYS-TIMEOUT t1)
  73.   (princ "\n共生成 ")
  74.   (princ (length polylist))
  75.   (princ " 个多边形!")
  76.   ;(reerr)
  77.   )
发表于 2010-8-8 08:18:00 | 显示全部楼层

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

发表于 2010-8-8 12:29:00 | 显示全部楼层

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

 楼主| 发表于 2010-8-9 11:33:00 | 显示全部楼层
本帖最后由 Gu_xl 于 2011-1-26 20:20 编辑

动画演示

 

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2010-8-10 10:38:00 | 显示全部楼层

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

发表于 2010-12-17 11:11:04 | 显示全部楼层
下了MKPOLY.RAR,为什么加载后提示“mkpoly 未知命令“MKPOLY”。按 F1 查看帮助。”呢?
 楼主| 发表于 2010-12-17 11:16:19 | 显示全部楼层
自己定义如下函数试试

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

 楼主| 发表于 2011-1-26 19:48:30 | 显示全部楼层
本帖最后由 Gu_xl 于 2011-10-12 15:27 编辑

优化算法后的代码:
  1. ;|为了提高程序构建多边形的运行速度,需要对程序的数据结构和计算方法进行优化,下面我逐步详解我程序的思路:
  2. 1、根据处理后的直线、圆弧选择集生成的图元列表entList,数据结构:(图元名 图元名 ...),建立图元和各图元之间的节点对应关系数据表,
  3. 数据结构:'((图元名 起点的节点编号 端点的节点编号)...),表中图元名的排序和表entList的顺序一致,再建立节点和坐标数据对应表,
  4. 数据结构:'((节点编号 坐标)...),这样方便后面构建拓扑邻接表时,搜索只需要搜索节点编号进行比较,不需要在进行比较端点坐标,这样能大大提高运算速度。
  5. |;
  6. ;;;(gxl-ent->Nodes entList jd)根据弧段图元表建立弧段节点表,参数:图元表 精度值 返回值:图元名--节点编号表 '((图元名 首节点编号 末节点编号)...) 节点--坐标表 '((节点编号 坐标)...)
  7. (defun gxl-ent->Nodes (entList jd / ent ent_nodes Nodes n k p1 p2 flag flag1 flag2 bh coord p11 p21 nodes1 sortI1 sortI2)
  8.   (grtext -2 "整理弧段节点表...")
  9.   (setq n 1 )
  10.   ;(setq t1 (getvar "cdate"))
  11.   (setq ent_nodes (list (list (car entList) 0 1)))
  12.   (setq Nodes (list  (list 1 (vlax-curve-getendPoint (car entList))) (list 0 (vlax-curve-getStartPoint (car entList)))))
  13.   (foreach ent (cdr entList)
  14.     (setq flag1 t
  15.    flag2 t
  16.       )
  17.     (setq p1 (vlax-curve-getStartPoint ent)
  18.    p2 (vlax-curve-getendPoint ent)
  19.    k 0
  20.    )

  21.   ;;;===========
  22.     (while (and (setq node (nth k nodes)) (or flag1 flag2))
  23.     ;(foreach node nodes
  24.       (setq bh (car node)
  25.      coord (cadr node)
  26.      )
  27.       (if (equal p1 coord jd) (setq bh1 bh flag1 nil))
  28.       (if (equal p2 coord jd) (setq bh2 bh flag2 nil))
  29.       (setq k (1+ k))
  30.       ;) ;_ foreach
  31.       )
  32.     (if flag1
  33.       (progn
  34. (setq bh1 (setq n (1+ n)))
  35. (setq nodes (cons (list bh1 p1) nodes)
  36.        )
  37. )
  38.       )
  39.     (if flag2
  40.       (progn
  41. (setq bh2 (setq n (1+ n)))
  42. (setq nodes (cons (list bh2 p2) nodes)
  43.        )
  44. )
  45.       )
  46. ;;;============
  47.     (setq ent_nodes (cons (list ent bh1 bh2) ent_nodes))
  48.    
  49.     )
  50.   (grtext)
  51.   ;(GXL-SYS-TIMEOUT t1)
  52.   (list (reverse ent_nodes) (reverse Nodes))
  53.   
  54.   )
  55. ;|
  56. 2、根据生成的段图元名--节点编号表'((图元名 首节点编号 末节点编号)...),构建一个二维坐标表,
  57. 数据结构:'((图元起点的节点编号 图元起点的方向点 图元弧段编号 图元末端点方向点 图元末端点节点编号)  ...)
  58. 其中:图元起点的方向点指图元起点到终点的方向上任一点,如果图元为圆弧,则该方向点为切线方向任一点,
  59.      图元末端点的方向点指图元末端点到起点的方向上任一点,如果图元为圆弧,则该方向点为切线方向任一点,
  60.      图元弧段编号为图元在表段图元名--节点编号表中的顺序位置,顺序号从1开始
  61. |;
  62. ;;;(gxl-ent->Coordinates enlst) 根据线段图元名--节点编号表'((图元名 首节点编号 末节点编号)...) 构建二维坐标表
  63. ;;;返回值: 二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...)
  64. ;;;(gxl-ent->Coordinates enLst)
  65. (defun gxl-ent->Coordinates (enLst / rtn index a b jd n k )
  66.    
  67.   (setq index 0)
  68.   ;(setq jd 3)
  69.   (setq rtn
  70.   (mapcar '(lambda (x)
  71.       (list (cadr x) ;_ 首端点节点编号
  72.      (COND
  73.        ((= "LINE" (GXL-DXF (car x) 0))
  74.         (list (car (setq a (vlax-curve-getendPoint (car x))))
  75.        (cadr a)
  76.         ) ;_ list
  77.        )
  78.        ((= "ARC" (GXL-DXF (car x) 0))
  79.         
  80.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) 1))) (cadr b))
  81.        )
  82.        ((WCMATCH (GXL-DXF (car x) 0) "*POLYLINE")
  83.         
  84.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) 1))) (cadr b))
  85.         )
  86.      ) ;_ COND 首端点方向点
  87.      ;(gxl-dxf x 5) ;_ 图元句柄
  88.      ;x ;_ 图元名
  89.      (setq index (1+ index)) ;_ 弧段编号,从序号1开始
  90.      (COND
  91.        ((= "LINE" (GXL-DXF (car x) 0))
  92.         (list (car (setq a (vlax-curve-getstartPoint (car x))))
  93.        (cadr a)
  94.         ) ;_ list
  95.        )
  96.        ((= "ARC" (GXL-DXF (car x) 0))
  97.         
  98.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) -1.0))) (cadr b))
  99.        )
  100.        ((WCMATCH (GXL-DXF (car x) 0) "*POLYLINE")
  101.         
  102.         (list (car (setq b (polar (setq a (vlax-curve-getStartPoint (car x))) (GXL-GETCURVETANGENT (car x) a) -1.0))) (cadr b))
  103.         )
  104.      ) ;_ 末端点方向点
  105.      (caddr x) ;_ 末端点节点编号
  106.       ) ;_ list
  107.     ) ;_ lambda
  108.    enlst
  109.   ) ;_ mapcar
  110. )
  111.   rtn
  112.    ;_ vl-sort
  113. )
  114. ;|
  115. 3、根据二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...) ,
  116. 建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...),
  117. 建立弧段拓扑邻接表的方法:
  118. 若某一弧段N 的首端点与另一弧段
  119. 相关联, 则在弧段拓扑邻接关系表中标记为N ; 若
  120. 末端点与另一弧段相关联, 则标记为- N
  121. 如果拓扑表中有nil,则表明线段端点没有邻接边
  122. |;
  123. ;;;(gxl-Toupu-LineList Coordinates) 根据二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...)
  124. ;;;建立弧段拓扑邻接表,'((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...)
  125. (defun gxl-Toupu-LineList (Coordinates
  126.        /      toupulist        nn
  127.        n      k       pstart   pend
  128.        pl      new      old      t2
  129.        Coordinates0      Coordinates1
  130.        flag     flag1    index pl to bh
  131.       xh1 xh2 coord
  132.       ) ;_ Coordinates
  133.   (if (not *jd*) (setq *jd* 0.00001))
  134.   ;;;点表倒置
  135. (setq Coordinates1 (mapcar 'reverse Coordinates))
  136.   (grtext -2  "拓扑邻接表...")
  137.   (foreach coord Coordinates
  138.     (setq xh1 (car coord)
  139.    xh2 (last coord)
  140.    )
  141.     (setq toupulist
  142.     (cons
  143.       (list
  144.         (setq bh (nth 2 coord))
  145.         (vl-remove-if
  146.    '(lambda (x) (or (equal x bh) (equal x (* -1 bh))))
  147.    (append (mapcar 'cadr (GXL-MASSOC xh1 Coordinates)) (mapcar '(lambda (x) (* -1 (cadr x))) (GXL-MASSOC xh1 Coordinates1)))
  148.    )
  149.         (vl-remove-if
  150.    '(lambda (x) (or (equal x bh) (equal x (* -1 bh))))
  151.    (append (mapcar 'cadr (GXL-MASSOC xh2 Coordinates)) (mapcar '(lambda (x) (* -1 (cadr x))) (GXL-MASSOC xh2 Coordinates1)))
  152.    )
  153.         )
  154.       toupulist)
  155.    )
  156.     )
  157.   
  158.   (grtext)
  159.   (reverse toupulist)
  160.   )
  161. ;|
  162. 4、检查生成的弧段拓扑邻接表,如果有断头的弧段,将其删除,返回处理后的弧段拓扑邻接表和已经删除的弧段表
  163. |;
  164. ;;;(gxl-check-Toupu-LineList toupulist) 参数:弧段拓扑邻接表
  165. (defun gxl-check-Toupu-LineList (toupulist / delnil toupulist1 dellist)
  166.   (setq toupulist1 toupulist)
  167.   (defun delnil (toupl / tmp tmp1 dellist1 a b)
  168.     (setq tmp toupulist1)
  169.     (foreach a toupl
  170.       (if (member nil a)
  171. (progn
  172. ;(setq dellist (append dellist (list (abs (car a)))))
  173.    (setq dellist (append dellist (list (car a))))
  174. (setq toupulist1 (vl-remove (assoc (abs(car a)) toupulist1) toupulist1))
  175. (setq toupulist1
  176.         (mapcar
  177.    '(lambda (b)
  178.       (list (car b)
  179.      (vl-remove-if
  180.        '(lambda (x) (= (abs (car a)) (abs x)))
  181.        (cadr b)
  182.      ) ;_ vl-remove-if
  183.      (vl-remove-if
  184.        '(lambda (x) (= (abs (car a)) (abs x)))
  185.        (caddr b)
  186.      ) ;_ vl-remove-if
  187.       ) ;_ list
  188.     ) ;_ lambda
  189.    toupulist1
  190.         ) ;_ mapcar
  191. ) ;_ setq
  192. )
  193. )
  194.       )
  195.     (if (not (equal tmp  toupulist1)) (delnil toupulist1))
  196.     )
  197.   (delnil toupulist1)
  198.   (list toupulist1 dellist)
  199.   )
  200. ;|
  201. 5、根据建立的弧段拓扑邻接表,按照最小角法则搜索多边形,返回 弧段与多边形拓扑关联表 '((多边形序号 (弧段号 ...))...)
  202. 一条弧段可作为一个或两个多边形的组成边而
  203. 存在, 亦即从一条弧段出发最多可以搜索出两个正确
  204. 的多边形. 如图2 所示, 若从弧段A 1 的一端O 出发,
  205. 并把它作为起始弧段, 把与A 1 的O 端拓扑关联的其
  206. 它弧段作为中止弧段, 然后比较并找出与A 1 夹角最
  207. 小的中止弧段A 2, 并把A 2 作为新的起始弧段, 再从
  208. 它的另一端点出发重复以上过程继续搜索, 直到回到
  209. 出发弧段A 1 的另一端为止, 则所有搜索出的弧段就
  210. 构成了一个多边形. 同样, 从A 1 的O 端开始, 并把它
  211. 作为中止弧段, 把与它拓扑关联的其它弧段作为起始
  212. 弧段, 然后比较并找出与该弧段夹角最小的弧段, 并
  213. 把找出的弧段作为新的中止弧段, 再从新弧段的另一
  214. 端点出发重复以上搜索过程, 直到回到A 1 的另一端
  215. 为止, 则所有搜索出的弧段就构成了另一个多边形.
  216. 这样, 从一条弧段出发可以跟踪出两个多边形, 此方
  217. 法可称为多边形搜索的最小角法则.
  218. 多边形的搜索按照最小角法则进行. 从编号为
  219. 1 的弧段的始端出发, 查找弧段拓扑邻接表中与该
  220. 端点关联的弧段, 按照最小角法则可以搜索出两个
  221. 多边形. 依照上述方法, 依次把其它弧段作为开始弧
  222. 段, 共可找出2N (N 为总弧段数) 个多边形. 搜索过
  223. 程中, 记录构成多边形的弧段编号(一弧段首端与上
  224. 一弧段关联用正边号, 否则用负边号) 和弧段数, 即
  225. 形成多边形与弧段的拓扑关联表.
  226. |;
  227. ;;;(gxl-MakePolyList toupulist Coordinates nodes) 最小角法拓扑多边形,返回多边形数据表
  228. ;;;参数:
  229. ;;; toupulist 弧段邻接表 '((弧段序号 (首端点关联表 ...) (末端点关联表 ...))...),从 1 开始
  230. ;;; Coordinates 二维坐标表 '((首端点节点编号 首端点方向点 弧段编号 末端点方向点 末端点节点编号)  ...) 按顺序从1开始
  231. ;;; nodes 节点--坐标表 '((节点编号 坐标)...)
  232. (defun gxl-MakePolyList (toupulist Coordinates      nodes    /        PolyTouPuList  nn
  233.        n     xh      pstart   pend     flag p0  p1
  234.        a0     a1      a2       B1       B2 polytoupu
  235.        toupu0   next     t2       kk       ExitNum ExitFlag Nodestart
  236.        NodeEnd  node
  237.       ) ;_ toupulist
  238.   (if (not *jd*) (setq *jd* 0.00001))
  239.     ;;;测试时间
  240.   (setq t2 (getvar "cdate"))
  241.   (setq nn (length Coordinates)
  242. n 0
  243. to nn)
  244.   (GXL-SYS-PROGRESS-INIT "拓扑多边形" to)
  245.   (repeat nn
  246.     (setq xh (1+ n)) ;_ 弧段序号
  247.     ;(setq bak xh)
  248.     (if (assoc xh toupulist)
  249.       ;;;如果该边在拓扑邻接表里
  250.       (progn
  251.     (GXL-SYS-PROGRESS   to -1)
  252.     (setq Nodestart (car (nth n Coordinates))
  253.    NodeEnd  (last (nth n Coordinates))
  254.    Pstart (cadr (assoc Nodestart nodes))
  255.    pEnd (cadr (assoc NodeEnd nodes))
  256.    flag  t
  257.     ) ;_ setq
  258.     ;;;首端点搜索多边形
  259.     (setq p0 pstart
  260.    p1 (cadr (nth n Coordinates))
  261.    a0 (angle p0 p1) ;_ 首端点弧段角度
  262.    toupu0 (cadr (assoc xh toupulist)) ;_ 首端点弧段拓扑邻接表
  263.    polytoupu (list (* -1 xh))
  264.    )
  265.     (setq ExitNum 0  ;_ 循环次数
  266.    ExitFlag nil) ;_ 陷入死循环标志
  267.     ;;;移除重合的线
  268.     (setq toupu0 (vl-remove-if
  269.      '(lambda (x)
  270.         (if (> x 0)
  271.    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
  272.    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
  273.    )
  274.         )
  275.      toupu0
  276.      )
  277.    )
  278.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
  279.     (while flag
  280.       ;;;toupu0与a0按最小角度排序相邻边
  281.       (setq toupu0
  282.       (vl-sort toupu0
  283.         '(lambda (e1 e2)
  284.     (if (> e1 0)
  285.       (setq a1 (angle (cadr (assoc (car (nth (1- e1) Coordinates)) nodes))  (cadr (nth (1- e1) Coordinates))))
  286.       (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ e1)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e1)) Coordinates))))
  287.       )
  288.     (if (> e2 0)
  289.       (setq a2 (angle (cadr (assoc (car (nth (1- e2) Coordinates)) nodes))   (cadr (nth (1- e2) Coordinates))))
  290.       (setq a2 (angle (cadr (assoc (nth 4 (nth (abs (1+ e2)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e2)) Coordinates))))
  291.       )
  292.     (if (>= a0 a1) (setq B1 (- a0 a1)) (setq B1 (+ 2pi (- a0 a1))))
  293.     (if (>= a0 a2) (setq B2 (- a0 a2)) (setq B2 (+ 2pi (- a0 a2))))
  294.     (< B1 B2)
  295.     )
  296.         )
  297.      )
  298.       ;;;判断Next边是否已经在polytoupu里了
  299.       ;(if (member next (mapcar 'abs polytoupu)) (setq exitflag t))
  300.       (setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号
  301.       ;;;验证next 下一邻接边序号的方位角是否和首端点弧段角度a0重合,如重合,找下一边,未找到,结束组多边形
  302.       (setq falg1 t
  303.      kk 1)
  304.       (while flag1
  305. (if (> next 0)
  306.    (setq a1 (angle (cadr (assoc (car (nth (1- next) Coordinates)) nodes))  (cadr (nth (1- next) Coordinates))))
  307.    (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ next)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ next)) Coordinates))))
  308.   )
  309.    (if (equal a0 a1 0.000001) (setq next (nth kk toupu0))(setq flag1 nil))
  310. (if (not next) (setq flag1 nil))
  311. (setq kk (1+ kk))
  312. )
  313.       ;(if next (setq polytoupu (append polytoupu (list (setq next (car toupu0))))))
  314.       (if next
  315.       (if (> next 0)
  316. (progn
  317.    (setq p0 (cadr (assoc  (setq node (nth 4 (nth (1- next) Coordinates))) nodes))
  318.   a0 (angle p0 (nth 3 (nth (1- next) Coordinates)))
  319.   toupu0 (caddr (assoc next toupulist))
  320.   )
  321.    (if (equal node nodeEnd) (setq flag nil))
  322.    
  323.    )
  324. (progn
  325.    (setq p0 (cadr (assoc  (setq node (car (nth (abs (1+ next)) Coordinates))) nodes))
  326.   a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))
  327.   toupu0 (cadr (assoc (abs next) toupulist))
  328.   )
  329.    (if (equal node nodeEnd) (setq flag nil))
  330.    )
  331. )
  332. (setq flag nil)
  333. )
  334.      (setq ExitNum (1+ ExitNum))
  335.       ;;;搜索边界次数超过2000次,程序陷入死循环,退出
  336.       (if (> ExitNum 2000) (setq flag nil ExitFlag t))
  337.       (if (and flag (not ExitFlag))
  338. (progn
  339.     ;;;移除重合的线
  340.     (setq toupu0 (vl-remove-if
  341.      '(lambda (x)
  342.         (if (> x 0)
  343.    (equal a0 (angle (cadr (assoc  (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
  344.    (equal a0 (angle (cadr (assoc  (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
  345.    )
  346.         )
  347.      toupu0
  348.      )
  349.    )
  350.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
  351.    )
  352. )
  353.       );_ while
  354.     (if ExitFlag
  355.       (setq ExitFlag nil)
  356.     (setq PolyTouPuList (append PolyTouPuList (list polytoupu)))
  357.       )
  358.    
  359.     ;;;末端点搜索
  360.     (setq p0 pend
  361.    p1 (nth 3 (nth n Coordinates))
  362.    a0 (angle p0 p1) ;_ 起点角度
  363.    toupu0 (caddr (assoc xh toupulist))
  364.    polytoupu (list xh)
  365.    flag  t
  366.    )
  367.     (setq ExitNum 0  ;_ 循环次数
  368.    ExitFlag nil) ;_ 陷入死循环标志
  369.         ;;;移除重合的线
  370.     (setq toupu0 (vl-remove-if
  371.      '(lambda (x)
  372.         (if (> x 0)
  373.    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
  374.    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
  375.    )
  376.         )
  377.      toupu0
  378.      )
  379.    )
  380.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
  381.     (while flag
  382.       ;;;计算最小角度相邻边
  383.       
  384.       (setq toupu0
  385.       (vl-sort toupu0
  386.         '(lambda (e1 e2)
  387.     (if (> e1 0)
  388.       (setq a1 (angle (cadr (assoc (car (nth (1- e1) Coordinates)) nodes))  (cadr (nth (1- e1) Coordinates))))
  389.       (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ e1)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e1)) Coordinates))))
  390.       )
  391.     (if (> e2 0)
  392.       (setq a2 (angle (cadr (assoc (car (nth (1- e2) Coordinates)) nodes))  (cadr (nth (1- e2) Coordinates))))
  393.       (setq a2 (angle (cadr (assoc (nth 4 (nth (abs (1+ e2)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ e2)) Coordinates))))
  394.       )
  395.     (if (>= a0 a1) (setq B1 (- a0 a1)) (setq B1 (+ 2pi (- a0 a1))))
  396.     (if (>= a0 a2) (setq B2 (- a0 a2)) (setq B2 (+ 2pi (- a0 a2))))
  397.     (< B1 B2)
  398.     )
  399.         )
  400.      )
  401.        ;;;判断Next边是否已经在polytoupu里了
  402.       ;(if (member next (mapcar 'abs polytoupu)) (setq exitflag t))
  403.       (setq polytoupu (append polytoupu (list (setq next (car toupu0))))) ;_ next 下一邻接边序号
  404.       ;;;验证next 下一邻接边序号的方位角是否和首端点弧段角度a0重合,如重合,找下一边,未找到,结束组多边形
  405.       (setq falg1 t
  406.      kk 1)
  407.       (while flag1
  408. (if (> next 0)
  409.    (setq a1 (angle (cadr (assoc (car (nth (1- next) Coordinates)) nodes))  (cadr (nth (1- next) Coordinates))))
  410.    (setq a1 (angle (cadr (assoc (nth 4 (nth (abs (1+ next)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ next)) Coordinates))))
  411.   )
  412.    (if (equal a0 a1 0.000001) (setq next (nth kk toupu0))(setq flag1 nil))
  413. (if (not next) (setq flag1 nil))
  414. (setq kk (1+ kk))
  415. )
  416.       ;(if next (setq polytoupu (append polytoupu (list (setq next (car toupu0))))))
  417.       (if next
  418.       (if (> next 0)
  419. (progn
  420.    (setq p0 (cadr (assoc (setq node (nth 4 (nth (1- next) Coordinates))) nodes))
  421.   a0 (angle p0 (nth 3 (nth (1- next) Coordinates)))
  422.   toupu0 (caddr (assoc next toupulist))
  423.   )
  424.    (if (equal node nodestart) (setq flag nil))
  425.    )
  426. (progn
  427.    (setq p0 (cadr (assoc (setq node (car (nth (abs (1+ next)) Coordinates))) nodes))
  428.   a0 (angle p0 (cadr (nth (abs (1+ next)) Coordinates)))
  429.   toupu0 (cadr (assoc (abs next) toupulist))
  430.   )
  431.    (if (equal node nodestart) (setq flag nil))
  432.    )
  433. )
  434.   (setq flag nil)
  435. )
  436.        (setq ExitNum (1+ ExitNum))
  437.       ;;;搜索边界次数超过2000次,程序陷入死循环,退出
  438.       (if (> ExitNum 2000) (setq flag nil ExitFlag t))
  439.       (if (and flag (not ExitFlag))
  440. (progn
  441.     ;;;移除重合的线
  442.     (setq toupu0 (vl-remove-if
  443.      '(lambda (x)
  444.         (if (> x 0)
  445.    (equal a0 (angle (cadr (assoc (car (nth (1- x) Coordinates)) nodes))  (cadr (nth (1- x) Coordinates))) *jd*)
  446.    (equal a0 (angle (cadr (assoc (nth 4 (nth (abs (1+ x)) Coordinates)) nodes))  (nth 3 (nth (abs (1+ x)) Coordinates))) *jd*)
  447.    )
  448.         )
  449.      toupu0
  450.      )
  451.    )
  452.     (if (not (> (length toupu0) 0)) (setq flag nil ExitFlag t))
  453.    )
  454. )
  455.    
  456.       ) ;_ while
  457.     (if ExitFlag
  458.       (setq ExitFlag nil)
  459.     (setq PolyTouPuList (append PolyTouPuList (list polytoupu)))
  460.       )
  461.     )
  462.       )

  463.     (setq n (1+ n))
  464.     )
  465.   (GXL-SYS-PROGRESS-DONE)
  466.     ;(princ " \n多边形拓扑 ")
  467.   (GXL-SYS-TIMEOUT t2)
  468. ;;;删除多余多边形
  469.   (gxl-dumpPolyTouPuList PolyTouPuList)
  470.   )
  471. ;|
  472. 6、多余多边形的消除
  473. 由于按照最小角法则搜索出的多边形, 其中部
  474. 分是重复的(例如“岛”被搜索了两次) , 部分是错误
  475. 的(例如外围轮廓多边形) , 因此这两种多边形需要
  476. 去除. 其中重复多边形的去除是从多边形与弧段的
  477. 拓扑关联表中按照边数相等, 且边号绝对值相等的
  478. 原则来进行; 而错误多边形的去除则按照下面原则
  479. 进行: 一个多边形与另一多边形有公共边, 同时它又
  480. 包含另一多边形的非公共边上一点, 则该多边形是
  481. 错误多边形.
  482. |;
  483. ;;;(gxl-dumpPolyTouPuList PolyTouPuList) 删除多余多边形,本函数仅消除重复的多边形,
  484. ;;;外包多边形在实际生成多边形后再予以删除
  485. (defun gxl-dumpPolyTouPuList (PolyTouPuList / rtn pl nn n a)
  486.   (setq pl PolyTouPuList
  487. nn (length pl)
  488.   ) ;_ setq
  489.   ;(grtext -2 "\n处理多余多边形...")
  490.   ;(princ)
  491.   (GXL-SYS-PROGRESS-INIT "处理多余多边形" nn)
  492. ;;;测试时间
  493.   ;(setq t2 (getvar "cdate"))
  494.   (while (setq a   (car pl)
  495.         rtn (cons a rtn)
  496.         pl  (vl-remove-if
  497.        '(lambda (x)
  498.    (if (= (length a) (length x))
  499.      (if (equal (vl-sort (mapcar 'abs x) '<)
  500.          (vl-sort (mapcar 'abs a) '<)
  501.          ) ;_ equal
  502.        t
  503.      ) ;_ if
  504.    ) ;_ if
  505.         ) ;_ lambda
  506.        pl
  507.      ) ;_ vl-remove-if
  508.   ) ;_ setq
  509.     (GXL-SYS-PROGRESS  nn -1)
  510.   ) ;_ while
  511.   (GXL-SYS-PROGRESS-DONE)
  512.   ;(GXL-SYS-TIMEOUT t2)
  513.   (setq rtn (reverse rtn))
  514.   (vl-remove-if
  515.     '(lambda (x) (/= (length x) (length (GXL-LISTDUMPATOM (mapcar 'abs x)))))
  516.     rtn
  517.     )
  518. ) ;_ defun
  519. ;|
  520. 7、根据生成的多边形拓扑表绘制多边形
  521. ;;;(gxl-DrawPolyLine PolyTouPuList ssl Coordinates closed)
  522. 由弧段与多边形拓扑关联表绘制多边形,参数 多边形拓扑关联表 图元名列表 坐标值列表 是否闭合 返回值:多边形选择集
  523. ;;;PolyTouPuList 多边形拓扑表
  524. ;;; ssl 图元名--节点编号表 '((图元名 首节点编号 末节点编号)...)
  525. ;;; nodes 节点--坐标表 '((节点编号 坐标)...)
  526. |;
  527. (defun gxl-DrawPolyLine (PolyTouPuList
  528.      ssl     nodes  closed   /     Polytoupu pts
  529.      _bulges   mn       ml mk   num     p1       p2
  530.      np1     np2       en en1   rtn     coords    n
  531.      gxl-DelOutPolyline La_LineType_Color Lay LineType Color xh1 xh2
  532.     ) ;_ PolyTouPuList
  533.   ;;;(gxl-DelOutPolyline ss) 删除拓扑出poly选择集中外边框,返回删除后的选择集
  534. ;;;(gxl-DelOutPolyline pss)
  535. (defun gxl-DelOutPolyline (ss / ssL ssL1 ent flag en1 rtn)
  536.   (setq ssL (GXL-SEL-SS->LIST ss)
  537. rtn (ssadd)
  538. flag t
  539. )
  540.   (setq ssL (vl-sort ssL '(lambda (e1 e2) (> (GXL-GETAREA e1) (GXL-GETAREA e2)))))
  541.   
  542.   (while flag
  543.     (setq ent (car ssL)
  544. ssL (cdr ssL)
  545. ssL1 '()
  546. flag1 nil
  547. )
  548.     (while ssL
  549.       (setq en1 (car ssL)
  550.      ssL (cdr ssL)
  551.       ) ;_ setq
  552.       (if (PolyInLwpolyLine en1 ent)
  553. (setq  flag1 t)
  554. (setq ssL1 (cons en1 ssL1))
  555.       ) ;_ if
  556.     ) ;_ while
  557.     (if flag1 (progn (ssdel ent ss)(entdel ent)(setq flag1 nil)))
  558.     (if ssL1
  559. (setq ssL (vl-sort ssL1 '(lambda (e1 e2) (> (GXL-GETAREA e1) (GXL-GETAREA e2)))))
  560.       (setq flag nil)
  561.       )
  562.   ) ;_ while
  563.   ss
  564.   )
  565.   (setq rtn (ssadd))
  566.   (if (not *jd*) (setq *jd* 0.0001))
  567.   (foreach Polytoupu PolyTouPuList
  568.     (setq pts nil
  569.    _bulges nil
  570.    mn (length Polytoupu)
  571.    mk 0
  572.    )
  573.    ;(if closed (setq mk 0) (setq mk -1))
  574.     (foreach num Polytoupu
  575.       (setq mk (1+ mk))
  576.       
  577.       (setq en (car (nth (1- (abs num)) ssl))
  578.      xh1 (cadr (nth (1- (abs num)) ssl))
  579.      xh2 (caddr (nth (1- (abs num)) ssl))
  580.      ;coords (nth (1- (abs num)) Coordinates)
  581.      entype (gxl-dxf en 0)
  582.      )
  583.       
  584.       (if (> num 0)
  585. (setq p1 (cadr (assoc xh1 nodes))
  586.        p2 (cadr (assoc xh2 nodes))
  587. ) ;_ setq
  588. (setq p1 (cadr (assoc xh2 nodes))
  589.        p2 (cadr (assoc xh1 nodes))
  590. ) ;_ setq
  591.       ) ;_ if
  592.       (cond ((= entype "LINE")
  593.       (if pts
  594.         (setq pts (append pts (list p2))
  595.        _bulges (append _bulges (list 0))
  596.        )
  597.         (setq pts (append pts (list p1 p2))
  598.        _bulges (append _bulges (list 0))
  599.        )
  600.       ) ;_ if
  601.       
  602.       
  603.       )
  604.      ((= entype "ARC")
  605.       (if pts
  606.         (setq pts (append pts (list p2))
  607.        _bulges (append _bulges (list (cond ((> num 0) (gxl-GetArcBulge en)) (t (* -1.0 (gxl-GetArcBulge en))))))
  608.        )
  609.         (setq pts (append pts (list p1 p2))
  610.        _bulges (append _bulges (list (cond ((> num 0) (gxl-GetArcBulge en)) (t (* -1.0 (gxl-GetArcBulge en))))))
  611.        )
  612.       )
  613.       )
  614.      ((= entype "LWPOLYLINE")
  615.       (setq data (gxl-get_poly_data en))
  616.       
  617.       (if (> num 0)
  618.         (progn
  619.    (if pts
  620.      (progn
  621.    (setq pts (append pts (cdar data)))
  622.    (setq _bulges (append _bulges (reverse (cdr (reverse (cadr data))))))
  623.    )
  624.      (progn
  625.        (setq pts (append pts (cons p1 (cdar data))))
  626.        (setq _bulges (append _bulges (cadr data)))
  627.        )
  628.      )
  629.         ) ;_ progn
  630.         (progn
  631.    (GXL-REVERSELWPOLYLINE en)
  632.    (setq data (gxl-get_poly_data en))
  633.    (if pts
  634.      (progn
  635.    (setq pts (append pts (cdar data)))
  636.    (setq _bulges (append _bulges (reverse (cdr (reverse (cadr data))))))
  637.    )
  638.      (progn
  639.        (setq pts (append pts (cons p1 (cdar data))))
  640.        (setq _bulges (append _bulges (cadr data)))
  641.        )
  642.      )
  643.    (GXL-REVERSELWPOLYLINE en)
  644.         ) ;_ progn
  645.       ) ;_ if
  646.       )
  647.      )
  648.       
  649.       )
  650.     ;(if (= entype "LWPOLYLINE") (setq _bulges  (append _bulges (list (last (cadr data))))) (setq _bulges  (append _bulges (list 0))))     
  651.    (if closed
  652.      (vla-put-closed (GXL-AX:ADDLWPOLYLINE1 *MODEL-SPACE* (list pts _bulges )) :vlax-true)
  653.      (GXL-AX:ADDLWPOLYLINE1 *MODEL-SPACE* (list pts _bulges))
  654.      )
  655.     (setq app pts
  656.    bus _bulges)
  657.     (ssadd (setq en (entlast)) rtn)
  658.     ;;;修改多段线图层
  659.     (setq La_LineType_Color (gxl-GetToupuPolyLayer_Linetype_color Polytoupu (mapcar 'car ssl)))
  660.     (setq lay (car La_LineType_Color)
  661.    LineType (cadr La_LineType_Color)
  662.    Color (caddr La_LineType_Color)
  663.    )
  664.     (gxl-CH_Ent en 8 lay)
  665.     (if LineType (gxl-CH_Ent en 6 LineType))
  666.     (if color (gxl-CH_Ent en 62 color))
  667.     (gxl-DumpPolyPoint en)
  668.     ;(vla-put-closed (GXL-AX:ADDLWPOLYLINE *MODEL-SPACE* pts) :vlax-true)
  669.     )
  670.   (if closed (gxl-DelOutPolyline rtn) rtn) ;_ 返回删除外框后的选择集
  671.   )
  672. ;;;测试
  673. (defun c:mkpoly ()
  674.   (SETUNDOERR)
  675.    (if (not *jd*) (setq *jd* 0.00001))
  676.   (princ "\n基于方位角计算的拓扑多边形自动构建快速算法测试")
  677.   (princ "\n****程序作者:Gu_xl 2010年8月****")
  678.   (princ "\n选择直线、圆弧、圆:")
  679.   (setq ss (ssget '((0 . "line,arc,circle"))))
  680.   (gxl-makepoly ss)
  681.   (reerr)
  682.   )
  683. ;;;至此,基于方位角计算的拓扑多边形自动构建快速算法 的主要算法思路的函数功能全部完成,
  684. ;;;附件是打包的测试程序,调用命令:mkpoly



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

看了下思路,就看了十几行,头疼中。  发表于 2012-5-10 20:29
学习了,谢谢  发表于 2012-3-21 20:06

评分

参与人数 3明经币 +1 金钱 +60 收起 理由
zzyong00 + 10 很给力!
yjr111 + 1
露水2 + 50

查看全部评分

发表于 2011-1-26 20:29:17 | 显示全部楼层
再考虑 椭圆  spl线
发表于 2011-1-26 21:28:46 | 显示全部楼层
  学习学习
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-15 06:50 , Processed in 0.249532 second(s), 41 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表