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

尘缘一生 · 发表于 2024-6-5 06:11:44

本帖最后由尘缘一生于 2024-6-5 09:29 编辑

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

应用实例：

可以在三领测试效果

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

尘缘一生 · 发表于 2024-6-5 20:41:48

本帖最后由尘缘一生于 2024-6-5 20:45 编辑

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

继续写下子

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

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

xj6019 · 发表于 2024-6-5 08:38:21

本帖最后由 xj6019 于 2024-6-5 08:45 编辑

尘缘一生发表于 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 · 发表于 2024-6-5 07:43:57

"graham-scan"是什么函数？

尘缘一生 · 发表于 2024-6-5 07:45:40

本帖最后由尘缘一生于 2024-6-5 09:10 编辑

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

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

尘缘一生 · 发表于 2024-6-5 08:56:51

本帖最后由尘缘一生于 2024-6-5 09:01 编辑

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

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

tranque · 发表于 2024-6-5 09:42:09

感谢尘缘前辈的分享

chslwj521 · 发表于 2024-6-6 14:13:22

感谢分享

hubeiwdlue · 发表于 2024-6-18 21:09:28

这是个实用的函数。

咏郡 · 发表于 2024-6-19 10:37:42

很需要这个函数，感谢

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

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

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评

本帖子中包含更多资源

本帖子中包含更多资源