请选择 进入手机版 | 继续访问电脑版
天气与日历 切换到窄版

 找回密码
 立即注册
中国膜结构网
十大进口膜材评选 十大国产膜材评选 十大膜结构设计评选 十大膜结构公司评选
查看: 18|回复: 2

矩形分堆/方框分堆

[复制链接]
  • TA的每日心情
    开心
    3 天前
  • 签到天数: 54 天

    [LV.5]常住居民I

    1263

    主题

    149

    回帖

    214748万

    积分

    管理员

    积分
    2147483647
    发表于 2024-3-6 12:47:05 | 显示全部楼层 |阅读模式
    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. )
    复制代码

     

     

     

     

    矩形分堆/方框分堆
    中国膜结构网打造全中国最好的膜结构综合平台 ,统一协调膜结构设计,膜结构施工,膜材采购,膜材定制,膜结构预算全方位服务。 中国空间膜结构协会合作单位。
  • TA的每日心情
    开心
    3 天前
  • 签到天数: 54 天

    [LV.5]常住居民I

    1263

    主题

    149

    回帖

    214748万

    积分

    管理员

    积分
    2147483647
     楼主| 发表于 2024-3-6 12:47:25 | 显示全部楼层
    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. )
    复制代码

     

     

     

     

    矩形分堆/方框分堆
    中国膜结构网打造全中国最好的膜结构综合平台 ,统一协调膜结构设计,膜结构施工,膜材采购,膜材定制,膜结构预算全方位服务。 中国空间膜结构协会合作单位。
  • TA的每日心情
    开心
    3 天前
  • 签到天数: 54 天

    [LV.5]常住居民I

    1263

    主题

    149

    回帖

    214748万

    积分

    管理员

    积分
    2147483647
     楼主| 发表于 2024-3-6 12:47:36 | 显示全部楼层
    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. )
    复制代码

     

     

     

     

    矩形分堆/方框分堆
    中国膜结构网打造全中国最好的膜结构综合平台 ,统一协调膜结构设计,膜结构施工,膜材采购,膜材定制,膜结构预算全方位服务。 中国空间膜结构协会合作单位。
    您需要登录后才可以回帖 登录 | 立即注册

    本版积分规则

    QQ|Archiver|手机版|中国膜结构网_中国空间膜结构协会

    GMT+8, 2024-3-29 20:26 , Processed in 0.058765 second(s), 21 queries .

    Powered by Discuz! X3.5

    © 2001-2024 Discuz! Team.

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