线集按最近距离成对分组（函数）
本帖最后由 尘缘一生 于 2024-6-5 09:29 编辑没有找到这个功能，自己写了个。
应用实例：
可以在三领测试效果
链接：https://pan.baidu.com/s/1Jg0m0RLgUdvCrnfe_rQZkw
提取码：eyyo
本帖最后由 尘缘一生 于 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
)
)
本帖最后由 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
)
)
"graham-scan"是什么函数？ 本帖最后由 尘缘一生 于 2024-6-5 09:10 编辑
bai2000 发表于 2024-6-5 07:43
"graham-scan"是什么函数？
本坛的，高飞鸟大师的扫描求凸包。 本帖最后由 尘缘一生 于 2024-6-5 09:01 编辑
xj6019 发表于 2024-6-5 08:38
测试有遗漏
测试代码如下
嗯，我测试用高飞的，主要是检查倾斜角度的支持，
感谢尘缘前辈的分享:handshake 感谢分享:lol 这是个实用的函数。 很需要这个函数，感谢
页:
[1]
2