【K:RtnBox4SSGroup】矩形分堆/方框分堆
;对图元进行扎堆分组(矩形分堆),并返回每一个组的包围盒;时间复杂度为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表的数据结构
)
页:
[1]