设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › 源码共享 › 【K:RtnBox4SSGroup】矩形分堆/方框分堆
12下一页
返回列表 发新帖
查看: 2198|回复: 19

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

  [复制链接]
kucha007
发表于 2023-3-25 14:35 | 显示全部楼层 |阅读模式
本帖最后由 kucha007 于 2024-3-3 18:37 编辑

20240303-程序又梳理了一遍，参照此贴：





坛友分享的，梳理了一遍。开发者是大海，很好用：
  1. ;对图元进行扎堆分组(矩形分堆),并返回每一个组的包围盒
  2. ;时间复杂度为n(1)，测试了17万个图元480组仅10秒
  3. ;作者：Tryhi-大海 (优化 by Kucha)
  4. ;SS是选择集，Dist是方框之间的间隙容差。
  5. (defun K:RtnBox4SSGroup (SS Dist
  6.   / K:GetEntBox K:GetSSBoxLst K:2RecIntersect Lst NewLst TmpLst Flag Rdo BasRec FstRec IntRec a b)
  7.   (progn ;基础函数
  8.     ;获取实体最小外接矩形的WCS坐标(忽略Z值)
  9.     (defun K:GetEntBox (en / MaxPt MinPt)
  10.       (vla-GetBoundingBox (vlax-ename->vla-object en) 'MinPt 'MaxPt) ;取得包容图元的最大点和最小点
  11.       (setq MinPt (vlax-safearray->list MinPt)) ;把变体数据转化为表
  12.       (setq MaxPt (vlax-safearray->list MaxPt)) ;把变体数据转化为表
  13.       (list (car MinPt) (cadr MinPt) (car MaxPt) (cadr MaxPt))
  14.     )
  15.     ;获取选择集每个实体的最小边界框坐标列表
  16.     (defun K:GetSSBoxLst (SS / i en Lst)
  17.       (if SS
  18.         (repeat (setq i (sslength SS))
  19.           (setq en (ssname SS (setq i (1- i))))
  20.           (setq Lst (cons (K:GetEntBox en) Lst))
  21.         )
  22.       )
  23.       Lst
  24.     )
  25.     ;如果矩形相交，则返回两矩形的最大边界框
  26.     (defun K:2RecIntersect (A B)
  27.       (if
  28.         (not
  29.           (or  ;不可能重叠的四种情况
  30.             (> (car A) (caddr B)) ;A的左侧比B的右侧大：X
  31.             (> (cadr A) (Last B)) ;A的下部比B的上部大：Y
  32.             (< (caddr A) (car B)) ;A的右侧比B的左侧小：X
  33.             (< (Last A) (cadr B)) ;A的上部比B的下部小：Y
  34.           )
  35.         )
  36.         (list
  37.           (min (car A) (car B))
  38.           (min (cadr A) (cadr B))
  39.           (max (caddr A) (caddr B))
  40.           (max (Last A) (Last B))
  41.         )
  42.       )
  43.     )
  44.   )
  45.   (if (and SS  (setq Dist (/ Dist 2)))
  46.     (progn
  47.       (setq Lst
  48.           (vl-sort
  49.               (K:GetSSBoxLst SS)
  50.               '(lambda (A B) ;左下右上
  51.                 (if (equal (car A) (car B) 1e-3)
  52.                   (if (equal (cadr A) (cadr B) 1e-3)
  53.                     (if (equal (caddr A) (caddr B) 1e-3)
  54.                       (< (cadddr A) (cadddr B)) ;上小在前
  55.                       (< (caddr A) (caddr B)) ;右小在前
  56.                     )
  57.                     (< (cadr A) (cadr B)) ;下小在前
  58.                   )
  59.                   (< (car A) (car B)) ;左小在前
  60.                 )
  61.               )
  62.           )
  63.       );边界框矩形排序
  64.       (setq Lst
  65.           (mapcar
  66.             '(lambda (x)
  67.               (list
  68.                 (- (car x) Dist)
  69.                 (- (cadr x) Dist)
  70.                 (+ (caddr x) Dist)
  71.                 (+ (cadddr x) Dist)
  72.               )
  73.             )
  74.             Lst
  75.           )
  76.       );矩形扩大
  77.       (progn ;合并矩形
  78.         (setq Flag T Rdo Nil)
  79.         (while Flag
  80.           (setq BasRec (car Lst)
  81.                 NewLst Nil
  82.           )
  83.           (while (setq FstRec (car Lst)) ;主要耗时点
  84.             (setq Lst (cdr Lst)) ;更新列表
  85.             (if (setq IntRec (K:2RecIntersect BasRec (setq FstRec (car Lst))))
  86.               (setq BasRec IntRec);存在相交矩形
  87.               (if
  88.                 (setq TmpLst (vl-some
  89.                           '(lambda (a / b)
  90.                               (if (setq b (K:2RecIntersect BasRec a))
  91.                                 (list b a)
  92.                               )
  93.                             )
  94.                           NewLst
  95.                         )
  96.                 );NewLst中有和BasRec相交的矩形？
  97.                 (progn
  98.                   (if (not (eq (car TmpLst) (Last TmpLst)))
  99.                     (setq NewLst (subst (car TmpLst) (Last TmpLst) NewLst))
  100.                   )
  101.                   (setq BasRec FstRec)
  102.                 )
  103.                 (setq NewLst (cons BasRec NewLst)
  104.                       BasRec FstRec
  105.                 )
  106.               )
  107.             )
  108.           )
  109.           (if (eq (length NewLst) (length Rdo))
  110.             (setq Flag Nil)
  111.             (setq Rdo NewLst
  112.                   Lst NewLst
  113.             )
  114.           )
  115.         )
  116.       )
  117.       (setq Lst
  118.           (mapcar
  119.             '(lambda (x)
  120.               (list
  121.                 (+ (car x) Dist)
  122.                 (+ (cadr x) Dist)
  123.                 (- (caddr x) Dist)
  124.                 (- (cadddr x) Dist)
  125.               )
  126.             )
  127.             NewLst
  128.           )
  129.       );矩形缩小
  130.     )
  131.   );矩形分堆得到互不相交的矩形LST
  132.   (mapcar
  133.     '(lambda (x)
  134.         (list
  135.           (list (car x) (cadr x))
  136.           (list (caddr x) (cadddr x))
  137.         )
  138.       )
  139.     Lst
  140.   );调整LST表的数据结构
  141. )






本帖被以下淘专辑推荐:

回复

使用道具 举报

kucha007
 楼主| 发表于 2023-3-25 16:31 | 显示全部楼层
本帖最后由 kucha007 于 2023-5-21 11:14 编辑

举个例子：
想要扎堆缩放对象可以这样操作:
ps：为了避免前面缩放的对象和后面的对象打架，这里是先收集对象成表，然后再按表缩放。缩放基点是左下角
  1. (if (not SCVar)(setq SCVar 1.2));设置缩放为1.2
  2. (if (not SCDist) (setq SCDist 2)) ;默认容差为2
  3. (while (setq SS (ssget))
  4.   (setq ObjLst '())
  5.   (setq ObjLst
  6.     (mapcar
  7.       '(lambda (Box)
  8.         (cons
  9.           (car Box);左下角作为缩放基点
  10.           (K:SS->VLA (ssget "C" (car Box) (Last Box)))
  11.         )
  12.       )
  13.       (K:RtnBox4SSGroup SS SCDist)
  14.     )
  15.   );收集缩放基点和VLA对象成表
  16.   (mapcar
  17.     '(lambda (Lst / Pt)
  18.        (setq Pt (vlax-3D-point (car Lst)))
  19.        (foreach obj (cdr Lst)
  20.          (vla-scaleentity obj Pt SCVar)
  21.        )
  22.      )
  23.     ObjLst
  24.   );缩放对象
  25.   (princ "\n——★★★ 所选对象的已缩放完毕！ ★★★——")
  26. )


回复 支持 反对

使用道具 举报

kucha007
 楼主| 发表于 2023-5-21 11:13 | 显示全部楼层
kucha007 发表于 2023-3-25 16:31
举个例子：
想要扎堆缩放对象可以这样操作（这里的缩放基点是左下角）：

补充函数：Lee Mac的选择集转Vla对象成表
  1. ;收集选择集中的Vla对象成表 by Lee Mac
  2. (defun K:SS->VLA (SS / i Lst)
  3.   (if SS
  4.     (repeat (setq i (sslength SS))
  5.       (setq Lst
  6.           (cons
  7.             (vlax-ename->vla-object (ssname SS (setq i (1- i))))
  8.             Lst
  9.           )
  10.       )
  11.     )
  12.   )
  13. )

回复 支持 反对

使用道具 举报

qazxswk
发表于 2023-10-14 01:04 | 显示全部楼层
kucha007 发表于 2023-10-13 22:20
用用便知……

不会用，所以想请教一下。
回复 支持 1 反对 0

使用道具 举报

aws
发表于 2023-3-25 16:52 | 显示全部楼层

看看这个，我收藏的
;;对图元进行扎堆分组（方框分组）作者：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
发表于 2024-4-16 17:52 | 显示全部楼层
楼主，我最近也在看大海的那个分堆函数，梳理一下思路，到了主要耗时点那里，卡住了，根本看不懂，那里感觉很复杂，
        (setq on-off t group nil)
        (while on-off
                (setq recc(car lst))
                (setq boxlst nil)
                (while(setq frec(car lst))
                        (setq lst(cdr lst))
                        (if(setq intrec(recxj recc(setq frec(car lst))))
                                (setq recc intrec);---比较第一个box和第二个box是否有相交矩形
                                (if(setq tmplst(vl-some '(lambda(a / b)(if(setq b(recxj recc a))(list b a)))boxlst))
                                        (progn
                                                (if (not (eq (car tmplst) (last tmplst)))
                                                        (setq boxlst (subst (car tmplst) (last tmplst) boxlst))
                                                )
                                                (setq recc frec)
                                        )
                                        (setq boxlst (cons recc boxlst)
                                                recc frec
                                        )
                                )
                        )
                )
                (if(eq(length boxlst)(length group))
                        (setq on-off nil)
                        (setq group boxlst lst boxlst)
                )
        )
这里能不能换一种写法？完全看不懂逻辑
回复 支持 反对

使用道具 举报

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

感谢，但看着比我现在这个复杂多了
回复 支持 反对

使用道具 举报

yaojing38
发表于 2023-3-30 11:33 | 显示全部楼层
谢谢分享，，大佬们
回复 支持 反对

使用道具 举报

zhangkui9070
发表于 2023-6-20 20:49 | 显示全部楼层
感谢大佬分享
回复 支持 反对

使用道具 举报

qazxswk
发表于 2023-10-13 21:16 | 显示全部楼层
怎么样求出每组包围盒的最小点与最大点？
回复 支持 反对

使用道具 举报

kucha007
 楼主| 发表于 2023-10-13 22:20 | 显示全部楼层
qazxswk 发表于 2023-10-13 21:16
怎么样求出每组包围盒的最小点与最大点？

用用便知……
回复 支持 反对

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-5-17 19:00 , Processed in 0.212486 second(s), 38 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表