矩形分堆/方框分堆

admin

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

复制代码

admin

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

复制代码

admin

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

复制代码