线集按最近距离成对分组（函数）

尘缘一生

没有找到这个功能，自己写了个。



应用实例：



可以在三领测试效果


链接：https://pan.baidu.com/s/1Jg0m0RLgUdvCrnfe_rQZkw
提取码：eyyo

尘缘一生

深入研究一下，这个问题还是很复杂的，为了支持更多类型

继续写下子

2. ;是否是偶数--(一级)---
   
3. ;返回 T 偶数 nil 奇数
   
4. (defun isEven (number)
   
5.   (zerop (rem number 2))
   
6. )
   
7. ;;平行线集以最短间距成对分组---(一级)---
   
8. ;ss平行线选择集 line,lwpolyline,polyline,circle,arc,ellipse,spline
   
9. ;返回((nam1 nam2) (nam3 nam4)....)
   
10. ;《三领设计 V3.0》MODIFY 尘缘一生  QQ：15290049
    
11. (defun sl-ssll-ab (ss / nam nam1 ssll n pxlis pa dis elis num lllis)
    
12.   (setq num (sslength ss))
    
13.   (if (= (isEven num) nil)
    
14.     (progn
    
15.       (ssdel (setq nam (ssname ss (1- num))) ss)
    
16.       (setq elis (list (list nam nam)))
    
17.     )
    
18.   )
    
19.   (setq ssll (ssadd))
    
20.   (repeat (setq n (sslength ss))
    
21.     (ssadd (ssname ss (setq n (1- n))) ssll)
    
22.   )
    
23.   (while (> (sslength ss) 0)
    
24.     (setq nam (ssname ss 0) lllis nil n -1)
    
25.     (ssdel nam ssll)
    
26.     (while (setq nam1 (ssname ssll (setq n (1+ n))))
    
27.       (setq
    
28.         pa (caddr (cur_3point nam))
    
29.         dis (* (getvar "DIMLFAC") (car (th-per pa (en2obj nam1))))
    
30.       )
    
31.       (if (> dis 0.0)
    
32.         (setq lllis (cons (list dis nam1) lllis))
    
33.       )
    
34.     )
    
35.     (setq lllis (vl-sort lllis '(lambda (a b) (< (car a) (car b)))))
    
36.     (setq nam1 (cadar lllis))
    
37.     (setq elis (cons (list nam nam1) elis))
    
38.     (ssdel nam ss)
    
39.     (ssdel nam1 ss)
    
40.     (ssdel nam1 ssll)
    
41.   )
    
42.   elis
    
43. )
    
44. ;线集按角度分组集---(一级)---
    
45. ;ss线集 line,lwpolyline,polyline
    
46. ;返回 (选择集1  选择集2 ...)
    
47. ;《三领设计 V3.0》MODIFY 尘缘一生  QQ：15290049
    
48. (defun sl-ssll-ssgroup (ss / n nam nam1 ss1 ss2 sslis ang ang1)
    
49.   (setq ss1 (ssadd))
    
50.   (repeat (setq n (sslength ss))
    
51.     (ssadd (ssname ss (setq n (1- n))) ss1)
    
52.   )
    
53.   (while (> (sslength ss) 0)
    
54.     (setq nam (ssname ss 0) ang (e-ang nam nil) ss2 (ssadd) n -1) ;e-ang 三领集成：取角度
    
55.     (ssdel nam ss1)
    
56.     (ssadd nam ss2)
    
57.     (while (setq nam1 (ssname ss1 (setq n (1+ n))))
    
58.       (setq ang1 (e-ang nam1 nil))
    
59.       (if (equal ang ang1 1e-4)
    
60.         (progn
    
61.           (ssadd nam1 ss2)
    
62.           (ssdel nam1 ss)
    
63.         )
    
64.       )
    
65.     )
    
66.     (setq sslis (cons ss2 sslis))
    
67.     (ssdel nam ss)
    
68.   )
    
69.   sslis
    
70. )
    
71. ;线集以最短间距成对分组---(一级)---
    
72. ;ss曲线选择集 line,lwpolyline,polyline,circle,arc,ellipse,spline
    
73. ;返回((nam1 nam2) (nam3 nam4)....)
    
74. ;《三领设计 V3.0》MODIFY 尘缘一生  QQ：15290049
    
75. (defun sl-ssCur-ab (ss / n ss1 ss2 elis nam e)
    
76.   (setq n -1 ss1 (ssadd) ss2 (ssadd) elis '())
    
77.   (while (setq nam (ssname ss (setq n (1+ n))))
    
78.     (if (member (dxf1 nam 0) '("ARC" "CIRCLE" "SPLINE" "ELLIPSE"))
    
79.       (ssadd nam ss1)
    
80.       (ssadd nam ss2)
    
81.     )
    
82.   )
    
83.   (if (> (sslength ss1) 0) (setq elis (append (sl-ssll-ab ss1) elis)))
    
84.   (if (> (sslength ss2) 0)
    
85.     (progn
    
86.       (setq n -1 ss1 (ssadd) ss (ssadd))
    
87.       (while (setq nam (ssname ss2 (setq n (1+ n))))
    
88.         (if (= (sl:pts-onLine (getpt (ssadd nam))) nil);不共线之线 getpt 实体取点函数  sl:pts-onLine 点集是否共线函数 t nil
    
89.           (ssadd nam ss1)
    
90.           (ssadd nam ss)
    
91.         )
    
92.       )
    
93.       (if (> (sslength ss1) 0)
    
94.         (progn
    
95.           (setq e (entlast))
    
96.           (slexpline ss1) ;炸开闭合的，拐角的线 slexpine 三领集成，炸线并宽度等特性不变
    
97.           (setq ss (sl:pickset-join ss (last_ent e))) ;并集
    
98.         )
    
99.       )
    
100.       (mapcar '(lambda (e) (setq elis (append (sl-ssll-ab e) elis))) (sl-ssll-ssgroup ss))
     
101.     )
     
102.   )
     
103.   elis
     
104. )
     
105. ;;测试----------------最终结果函数 sl-ssCur-ab
     
106. (defun c:tt (/ elis)
     
107.   (setq elis (sl-ssCur-ab (ssget '((0 . "LINE,LWPOLYLINE,POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE")))))
     
108.   (mapcar
     
109.     '(lambda (e / l)
     
110.        (setq l (append (getpt (ssadd (car e))) (getpt (ssadd (cadr e)))))
     
111.        (setq l (graham-scan l))
     
112.        (if (or (< (length l) 3) (and (>= (length l) 3) (<= (det (car l) (cadr l) (caddr l)) 0.0)))
     
113.          (setq l (reverse l))
     
114.        )
     
115.        (setq l (car (minarearectangle l)))
     
116.        (if l
     
117.          (slch:lwpolyline l t nil nil 1 nil)
     
118.        )
     
119.      )
     
120.     elis
     
121.   )
     
122. )
     

;是否是偶数--(一级)---<br /> ;返回 T 偶数 nil 奇数<br /> (defun isEven (number)<br />   (zerop (rem number 2))<br /> )<br /> ;;平行线集以最短间距成对分组---(一级)---<br /> ;ss平行线选择集 line,lwpolyline,polyline,circle,arc,ellipse,spline<br /> ;返回((nam1 nam2) (nam3 nam4)....)<br /> ;《三领设计 V3.0》MODIFY 尘缘一生  QQ：15290049<br /> (defun sl-ssll-ab (ss / nam nam1 ssll n pxlis pa dis elis num lllis)<br />   (setq num (sslength ss))<br />   (if (= (isEven num) nil)<br />     (progn<br />       (ssdel (setq nam (ssname ss (1- num))) ss)<br />       (setq elis (list (list nam nam)))<br />     )<br />   )<br />   (setq ssll (ssadd))<br />   (repeat (setq n (sslength ss))<br />     (ssadd (ssname ss (setq n (1- n))) ssll)<br />   )<br />   (while (> (sslength ss) 0)<br />     (setq nam (ssname ss 0) lllis nil n -1)<br />     (ssdel nam ssll)<br />     (while (setq nam1 (ssname ssll (setq n (1+ n))))<br />       (setq <br />         pa (caddr (cur_3point nam))<br />         dis (* (getvar "DIMLFAC") (car (th-per pa (en2obj nam1))))<br />       )<br />       (if (> dis 0.0)<br />         (setq lllis (cons (list dis nam1) lllis))<br />       )<br />     )<br />     (setq lllis (vl-sort lllis '(lambda (a b) (< (car a) (car b)))))<br />     (setq nam1 (cadar lllis))<br />     (setq elis (cons (list nam nam1) elis))<br />     (ssdel nam ss)<br />     (ssdel nam1 ss)<br />     (ssdel nam1 ssll)<br />   )<br />   elis<br /> )<br /> ;线集按角度分组集---(一级)---<br /> ;ss线集 line,lwpolyline,polyline<br /> ;返回 (选择集1  选择集2 ...)<br /> ;《三领设计 V3.0》MODIFY 尘缘一生  QQ：15290049<br /> (defun sl-ssll-ssgroup (ss / n nam nam1 ss1 ss2 sslis ang ang1)<br />   (setq ss1 (ssadd))<br />   (repeat (setq n (sslength ss))<br />     (ssadd (ssname ss (setq n (1- n))) ss1)<br />   )<br />   (while (> (sslength ss) 0)<br />     (setq nam (ssname ss 0) ang (e-ang nam nil) ss2 (ssadd) n -1) ;e-ang 三领集成：取角度 <br />     (ssdel nam ss1)<br />     (ssadd nam ss2)<br />     (while (setq nam1 (ssname ss1 (setq n (1+ n))))<br />       (setq ang1 (e-ang nam1 nil))<br />       (if (equal ang ang1 1e-4)<br />         (progn<br />           (ssadd nam1 ss2)<br />           (ssdel nam1 ss)<br />         )<br />       )<br />     )<br />     (setq sslis (cons ss2 sslis))<br />     (ssdel nam ss)<br />   )<br />   sslis<br /> )<br /> ;线集以最短间距成对分组---(一级)---<br /> ;ss曲线选择集 line,lwpolyline,polyline,circle,arc,ellipse,spline<br /> ;返回((nam1 nam2) (nam3 nam4)....)<br /> ;《三领设计 V3.0》MODIFY 尘缘一生  QQ：15290049<br /> (defun sl-ssCur-ab (ss / n ss1 ss2 elis nam e)<br />   (setq n -1 ss1 (ssadd) ss2 (ssadd) elis '())<br />   (while (setq nam (ssname ss (setq n (1+ n))))<br />     (if (member (dxf1 nam 0) '("ARC" "CIRCLE" "SPLINE" "ELLIPSE"))<br />       (ssadd nam ss1)<br />       (ssadd nam ss2)<br />     )<br />   )<br />   (if (> (sslength ss1) 0) (setq elis (append (sl-ssll-ab ss1) elis)))<br />   (if (> (sslength ss2) 0) <br />     (progn<br />       (setq n -1 ss1 (ssadd) ss (ssadd))<br />       (while (setq nam (ssname ss2 (setq n (1+ n))))<br />         (if (= (sl:pts-onLine (getpt (ssadd nam))) nil);不共线之线 getpt 实体取点函数  sl:pts-onLine 点集是否共线函数 t nil<br />           (ssadd nam ss1)<br />           (ssadd nam ss)<br />         )<br />       )<br />       (if (> (sslength ss1) 0)<br />         (progn<br />           (setq e (entlast))<br />           (slexpline ss1) ;炸开闭合的，拐角的线 slexpine 三领集成，炸线并宽度等特性不变<br />           (setq ss (sl:pickset-join ss (last_ent e))) ;并集<br />         )<br />       )<br />       (mapcar '(lambda (e) (setq elis (append (sl-ssll-ab e) elis))) (sl-ssll-ssgroup ss))<br />     )<br />   )<br />   elis<br /> )<br /> ;;测试----------------最终结果函数 sl-ssCur-ab<br /> (defun c:tt (/ elis)<br />   (setq elis (sl-ssCur-ab (ssget '((0 . "LINE,LWPOLYLINE,POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE")))))<br />   (mapcar <br />     '(lambda (e / l) <br />        (setq l (append (getpt (ssadd (car e))) (getpt (ssadd (cadr e)))))<br />        (setq l (graham-scan l))<br />        (if (or (< (length l) 3) (and (>= (length l) 3) (<= (det (car l) (cadr l) (caddr l)) 0.0)))<br />          (setq l (reverse l))<br />        )<br />        (setq l (car (minarearectangle l)))<br />        (if l<br />          (slch:lwpolyline l t nil nil 1 nil)<br />        )<br />      )<br />     elis<br />   )<br /> )<br />

xj6019

尘缘一生 发表于 2024-6-5 07:45
本坛的，高飞大师的扫描求凸包。

测试有遗漏
测试代码如下

(defun c:NM (/ )
        (setq elis (sl-ssll-ab (ssget '((0 . "LINE,LWPOLYLINE,POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE")))))
        (mapcar
                '(lambda (es / l)
                         (if(<(distance(Midpoint(car es))(Midpoint(cadr es)))300) ;过滤两线中点距离小于300的，否则感觉跟乱
                                 (progn
                                         (setq pt(mid(Midpoint(car es))(Midpoint(cadr es)))) ;求两线中点的中点
                                         (xj-yuan pt 200) ;找出来的位置画圆检查
                                 )
                         )                         
                 )
                elis
        )
)

bai2000

"graham-scan"是什么函数？

尘缘一生

bai2000 发表于 2024-6-5 07:43
"graham-scan"是什么函数？

本坛的，高飞鸟大师的扫描求凸包。

尘缘一生

xj6019 发表于 2024-6-5 08:38
测试有遗漏
测试代码如下

嗯，我测试用高飞的，主要是检查倾斜角度的支持，

tranque

感谢尘缘前辈的分享

chslwj521

感谢分享

hubeiwdlue

这是个实用的函数。

咏郡

很需要这个函数，感谢