【K:RtnBox4SSGroup】矩形分堆/方框分堆
本帖最后由 kucha007 于 2024-3-3 18:37 编辑20240303-程序又梳理了一遍，参照此贴：
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=189529&fromuid=7329538
坛友分享的，梳理了一遍。开发者是大海，很好用：
;对图元进行扎堆分组(矩形分堆),并返回每一个组的包围盒
;时间复杂度为n(1)，测试了17万个图元480组仅10秒
;作者：Tryhi-大海 (优化 by Kucha)
;SS是选择集，Dist是方框之间的间隙容差。
(defun K:RtnBox4SSGroup (SS Dist
/ K:GetEntBox K:GetSSBoxLst K:2RecIntersect Lst NewLst TmpLst Flag Rdo BasRec FstRec IntRec a b)
(progn ;基础函数
;获取实体最小外接矩形的WCS坐标(忽略Z值)
(defun K:GetEntBox (en / MaxPt MinPt)
(vla-GetBoundingBox (vlax-ename->vla-object en) 'MinPt 'MaxPt) ;取得包容图元的最大点和最小点
(setq MinPt (vlax-safearray->list MinPt)) ;把变体数据转化为表
(setq MaxPt (vlax-safearray->list MaxPt)) ;把变体数据转化为表
(list (car MinPt) (cadr MinPt) (car MaxPt) (cadr MaxPt))
)
;获取选择集每个实体的最小边界框坐标列表
(defun K:GetSSBoxLst (SS / i en Lst)
(if SS
(repeat (setq i (sslength SS))
(setq en (ssname SS (setq i (1- i))))
(setq Lst (cons (K:GetEntBox en) Lst))
)
)
Lst
)
;如果矩形相交，则返回两矩形的最大边界框
(defun K:2RecIntersect (A B)
(if
(not
(or;不可能重叠的四种情况
(> (car A) (caddr B)) ;A的左侧比B的右侧大：X
(> (cadr A) (Last B)) ;A的下部比B的上部大：Y
(< (caddr A) (car B)) ;A的右侧比B的左侧小：X
(< (Last A) (cadr B)) ;A的上部比B的下部小：Y
)
)
(list
(min (car A) (car B))
(min (cadr A) (cadr B))
(max (caddr A) (caddr B))
(max (Last A) (Last B))
)
)
)
)
(if (and SS(setq Dist (/ Dist 2)))
(progn
(setq Lst
(vl-sort
(K:GetSSBoxLst SS)
'(lambda (A B) ;左下右上
(if (equal (car A) (car B) 1e-3)
(if (equal (cadr A) (cadr B) 1e-3)
(if (equal (caddr A) (caddr B) 1e-3)
(< (cadddr A) (cadddr B)) ;上小在前
(< (caddr A) (caddr B)) ;右小在前
)
(< (cadr A) (cadr B)) ;下小在前
)
(< (car A) (car B)) ;左小在前
)
)
)
);边界框矩形排序
(setq Lst
(mapcar
'(lambda (x)
(list
(- (car x) Dist)
(- (cadr x) Dist)
(+ (caddr x) Dist)
(+ (cadddr x) Dist)
)
)
Lst
)
);矩形扩大
(progn ;合并矩形
(setq Flag T Rdo Nil)
(while Flag
(setq BasRec (car Lst)
NewLst Nil
)
(while (setq FstRec (car Lst)) ;主要耗时点
(setq Lst (cdr Lst)) ;更新列表
(if (setq IntRec (K:2RecIntersect BasRec (setq FstRec (car Lst))))
(setq BasRec IntRec);存在相交矩形
(if
(setq TmpLst (vl-some
'(lambda (a / b)
(if (setq b (K:2RecIntersect BasRec a))
(list b a)
)
)
NewLst
)
);NewLst中有和BasRec相交的矩形？
(progn
(if (not (eq (car TmpLst) (Last TmpLst)))
(setq NewLst (subst (car TmpLst) (Last TmpLst) NewLst))
)
(setq BasRec FstRec)
)
(setq NewLst (cons BasRec NewLst)
BasRec FstRec
)
)
)
)
(if (eq (length NewLst) (length Rdo))
(setq Flag Nil)
(setq Rdo NewLst
Lst NewLst
)
)
)
)
(setq Lst
(mapcar
'(lambda (x)
(list
(+ (car x) Dist)
(+ (cadr x) Dist)
(- (caddr x) Dist)
(- (cadddr x) Dist)
)
)
NewLst
)
);矩形缩小
)
);矩形分堆得到互不相交的矩形LST
(mapcar
'(lambda (x)
(list
(list (car x) (cadr x))
(list (caddr x) (cadddr x))
)
)
Lst
);调整LST表的数据结构
)
本帖最后由 kucha007 于 2023-5-21 11:14 编辑
举个例子：
想要扎堆缩放对象可以这样操作:
ps：为了避免前面缩放的对象和后面的对象打架，这里是先收集对象成表，然后再按表缩放。缩放基点是左下角
(if (not SCVar)(setq SCVar 1.2));设置缩放为1.2
(if (not SCDist) (setq SCDist 2)) ;默认容差为2
(while (setq SS (ssget))
(setq ObjLst '())
(setq ObjLst
(mapcar
'(lambda (Box)
(cons
(car Box);左下角作为缩放基点
(K:SS->VLA (ssget "C" (car Box) (Last Box)))
)
)
(K:RtnBox4SSGroup SS SCDist)
)
);收集缩放基点和VLA对象成表
(mapcar
'(lambda (Lst / Pt)
(setq Pt (vlax-3D-point (car Lst)))
(foreach obj (cdr Lst)
(vla-scaleentity obj Pt SCVar)
)
)
ObjLst
);缩放对象
(princ "\n——★★★ 所选对象的已缩放完毕！ ★★★——")
)
kucha007 发表于 2023-3-25 16:31
举个例子：
想要扎堆缩放对象可以这样操作（这里的缩放基点是左下角）：
补充函数：Lee Mac的选择集转Vla对象成表
;收集选择集中的Vla对象成表 by Lee Mac
(defun K:SS->VLA (SS / i Lst)
(if SS
(repeat (setq i (sslength SS))
(setq Lst
(cons
(vlax-ename->vla-object (ssname SS (setq i (1- i))))
Lst
)
)
)
)
)
kucha007 发表于 2023-10-13 22:20
用用便知……
不会用，所以想请教一下。 本帖最后由 hubeiwdlue 于 2024-6-16 11:47 编辑
苦茶大师，有一小段代码感觉很复杂，读不太明白，做了简化，不知道对不对，试了几个图形，感觉也能分对。您帮忙看一下。;对图元进行扎堆分组(矩形分堆),并返回每一个组的包围盒
;时间复杂度为n(1)，测试了17万个图元480组仅10秒
;作者：Tryhi-大海 (优化 by Kucha)
;SS是选择集，Dist是方框之间的间隙容差。
(defun K:RtnBox4SSGroup (SS Dist / K:GetEntBox K:GetSSBoxLst K:2RecIntersect Lst NewLst TmpLst Flag Rdo BasRec FstRec IntRec a b)
(progn ;基础函数
;获取实体最小外接矩形的WCS坐标(忽略Z值)
(defun K:GetEntBox (en / MaxPt MinPt)
(vla-GetBoundingBox (vlax-ename->vla-object en) 'MinPt 'MaxPt) ;取得包容图元的最大点和最小点
(setq MinPt (vlax-safearray->list MinPt)) ;把变体数据转化为表
(setq MaxPt (vlax-safearray->list MaxPt)) ;把变体数据转化为表
(list (car MinPt) (cadr MinPt) (car MaxPt) (cadr MaxPt))
)
;获取选择集每个实体的最小边界框坐标列表
(defun K:GetSSBoxLst (SS / i en Lst)
(if SS
(repeat (setq i (sslength SS))
(setq en (ssname SS (setq i (1- i))))
(setq Lst (cons (K:GetEntBox en) Lst))
)
)
Lst
)
;如果矩形相交，则返回两矩形的最大边界框，否则，返回nil
(defun K:2RecIntersect (A B)
(if
(not
(or;不可能重叠的四种情况
(> (car A) (caddr B)) ;A的左侧比B的右侧大：X
(> (cadr A) (Last B)) ;A的下部比B的上部大：Y
(< (caddr A) (car B)) ;A的右侧比B的左侧小：X
(< (Last A) (cadr B)) ;A的上部比B的下部小：Y
)
)
(list
(min (car A) (car B))
(min (cadr A) (cadr B))
(max (caddr A) (caddr B))
(max (Last A) (Last B))
)
)
)
)
(if (and SS(setq Dist (/ Dist 2)))
(progn
(setq Lst
(vl-sort
(K:GetSSBoxLst SS);嵌套表，每个图元坐标一个子表，(左(minX) 下(miny) 右(maxx) 上(maxy))
'(lambda (A B) ;左下右上
(if (equal (car A) (car B) 1e-3)
(if (equal (cadr A) (cadr B) 1e-3)
(if (equal (caddr A) (caddr B) 1e-3)
(< (cadddr A) (cadddr B)) ;上小在前
(< (caddr A) (caddr B)) ;右小在前
)
(< (cadr A) (cadr B)) ;下小在前
)
(< (car A) (car B)) ;左小在前
)
)
)
);边界框矩形排序,左小->下小->右小->上小，即从左往右，从下往上排序
(setq Lst
(mapcar
'(lambda (x)
(list
(- (car x) Dist)
(- (cadr x) Dist)
(+ (caddr x) Dist)
(+ (cadddr x) Dist)
)
)
Lst
)
);矩形扩大
(setq Flag T
NewLst Nil
)
(while Flag
(setq BasRec (car Lst);第一个元素
TmpLst Nil
)
(repeat (1-(length Lst))
(setq lst (cdr lst))
(if (setq IntRec (K:2RecIntersect BasRec (setq FstRec (car Lst)))) ;如果相交,新表
(setq BasRec IntRec);更新表
(setq TmpLst (cons FstRec TmpLst))
)
)
(setq NewLst (cons BasRec NewLst)
lst (reverse TmpLst)
)
(if (null TmpLst)
(setq Flag Nil)
)
)
(setq Lst
(mapcar
'(lambda (x)
(list
(+ (car x) Dist)
(+ (cadr x) Dist)
(- (caddr x) Dist)
(- (cadddr x) Dist)
)
)
NewLst
)
);矩形缩小
)
);矩形分堆得到互不相交的矩形LST
(setq Lst
(mapcar
'(lambda (x)
(list
(list (car x) (cadr x))
(list (caddr x) (cadddr x))
)
)
Lst
)
);调整LST表的数据结构
)
看看这个，我收藏的
;;对图元进行扎堆分组（方框分组）作者：tryhi-大海
(defun try-ss-zhadui-fenzu2 (ss dist / _intersect a b c ca cc flag l l1 lst n)
(defun _intersect (a b / ax1 ax2 ay1 ay2 bx1 bx1_in_a bx2 bx2_in_a by1 by1_in_a by2 by2_in_a)
(if
(not
(or
(< (setq ax2(caddr a)) (setq bx1(car b)));
(< (setq ay2(cadddr a)) (setq by1(cadr b)));
(> (setq ax1(car a)) (setq bx2(caddr b)));
(> (setq ay1(cadr a)) (setq by2(cadddr b)));
)
)
(list
(min ax1 bx1)(min ay1 by1)
(max ax2 bx2)(max ay2 by2)
)
)
)
;(setq lst '())
(if ss
(progn
(setq l(zd_ssbox ss))
(setq l
(vl-sort;
l
'(lambda (a b / ax1 ax2 ay1 bx1 bx2 by1)
(if (equal (setq ax1(car a)) (setq bx1(car b)) 1e-3)
(if (equal (setq ay1(cadr a)) (setq by1(cadr b)) 1e-3)
(if (equal (setq ax2(caddr a)) (setq bx2(caddr b)) 1e-3)
(< (cadddr a) (cadddr b))
(< ax2 bx2)
)
(< ay1 by1)
)
(< ax1 bx1)
)
)
)
)
(setq dist (* dist 0.5))
(setq l(mapcar '(lambda(x)(list (- (car x) dist)(- (cadr x) dist)(+ (caddr x) dist)(+ (cadddr x) dist)))l))
(setq k t r nil)
(while k
(setq a(car l)lst nil)
(while (setq ca(car l))
(setq l(cdr l))
(if (setq c (_intersect a (setq ca(car l))))
(setq a c)
(if (setq cc(vl-some '(lambda(x / b)(if(setq b(_intersect a x))(list b x)))lst))
(progn
(if (not(equal (car cc) (cadr cc)))
(setq lst(subst (car cc) (cadr cc)lst))
)
(setq a ca)
)
(setq lst(cons a lst)a ca)
)
)
)
(if(=(length lst)(length r))
(setq k nil)
(setq r lst l lst)
)
)
)
)
(setq l(mapcar '(lambda(x)(list (+ (car x) dist)(+ (cadr x) dist)(- (caddr x) dist)(- (cadddr x) dist)))lst))
(mapcar '(lambda(x)(list(list(car x)(cadr x))(list(caddr x)(cadddr x))))l)
)
aws 发表于 2023-3-25 16:52
看看这个，我收藏的
;;对图元进行扎堆分组（方框分组）作者：tryhi-大海
(defun try-ss-zhadui-fenzu2...
感谢，但看着比我现在这个复杂多了 谢谢分享，，大佬们 感谢大佬分享:lol 怎么样求出每组包围盒的最小点与最大点？ qazxswk 发表于 2023-10-13 21:16
怎么样求出每组包围盒的最小点与最大点？
用用便知……