【K:RtnBox4SSGroup】矩形分堆/方框分堆

kucha007 · 发表于 2023-3-25 14:35:55

本帖最后由 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表的数据结构
)

;对图元进行扎堆分组(矩形分堆),并返回每一个组的包围盒 
;时间复杂度为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-3-25 16:31:03

本帖最后由 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-5-21 11:13:15

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
)
)
)
)
)

qazxswk · 发表于 2023-10-14 01:04:07

kucha007 发表于 2023-10-13 22:20
用用便知……

不会用，所以想请教一下。

hubeiwdlue · 发表于 2024-6-8 12:24:41

本帖最后由 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表的数据结构
)

;对图元进行扎堆分组(矩形分堆),并返回每一个组的包围盒 
;时间复杂度为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表的数据结构 
)

aws · 发表于 2023-3-25 16:52:14

看看这个，我收藏的
;;对图元进行扎堆分组（方框分组）作者：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)
)

kucha007 · 发表于 2023-3-25 17:48:03

aws 发表于 2023-3-25 16:52
看看这个，我收藏的
;;对图元进行扎堆分组（方框分组）作者：tryhi-大海
(defun try-ss-zhadui-fenzu2 ...

感谢，但看着比我现在这个复杂多了

yaojing38 · 发表于 2023-3-30 11:33:39

谢谢分享，，大佬们

zhangkui9070 · 发表于 2023-6-20 20:49:06

感谢大佬分享

qazxswk · 发表于 2023-10-13 21:16:41

怎么样求出每组包围盒的最小点与最大点？

kucha007 · 发表于 2023-10-13 22:20:33

qazxswk 发表于 2023-10-13 21:16
怎么样求出每组包围盒的最小点与最大点？

用用便知……

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

【K:RtnBox4SSGroup】矩形分堆/方框分堆

评分

本帖被以下淘专辑推荐: