求分堆分组后包围盒的最小点与最大点

qazxswk · 发表于 2023-10-20 23:01:36

以下代码来自：http://bbs.mjtd.com/thread-187448-1-1.html
kucha007大神整理的
我的疑问是，怎么样求出每组包围盒的最小点与最大点？

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

yaojing38 · 发表于 2023-10-20 23:01:37

本帖最后由 yaojing38 于 2023-10-23 19:52 编辑

(mapcar
'(lambda (x)
(list
(list (car x) (cadr x))
(list (caddr x) (cadddr x))
(command "line" (list (car x) (cadr x)) (list (caddr x) (cadddr x)) "")
)
)
Lst
)

yaojing38 · 发表于 2023-10-21 11:12:18

返回值本来就是每组的最小点，，最大点了

qazxswk · 发表于 2023-10-22 00:47:02

yaojing38 发表于 2023-10-21 11:12
返回值本来就是每组的最小点，，最大点了

我就以每组的最小点与最大点画一条直线，没有成功。看来是我获取的最小点，最大点出现错误了。

yaojing38 · 发表于 2023-10-22 22:37:12

qazxswk 发表于 2023-10-22 00:47
我就以每组的最小点与最大点画一条直线，没有成功。看来是我获取的最小点，最大点出现错误了。

你的图形有问题估计

qazxswk · 发表于 2023-10-22 23:08:38

yaojing38 发表于 2023-10-22 22:37
你的图形有问题估计

应该是我设定的最小点与最大点有问题。
最小点也就是左下角点，(setq Pt1 (vlax-3D-point (car Lst)))
最大点，也就是右上角点，我搞不懂了。

yaojing38 · 发表于 2023-10-23 11:32:56

qazxswk 发表于 2023-10-22 23:08
应该是我设定的最小点与最大点有问题。
最小点也就是左下角点，(setq Pt1 (vlax-3D-point (car Lst))) ...

(mapcar
'(lambda (x)
      (list
      (list (car x) (cadr x)) ;最小点
      (list (caddr x) (cadddr x));最大点
      )
   )
Lst
  );调整LST表的数据结构

qazxswk · 发表于 2023-10-23 16:19:00

yaojing38 发表于 2023-10-23 11:32
(mapcar
'(lambda (x)
(list

这个是最小点点集，与最大点点集吧。我现在想做的是，分堆后，把每组的最小点与最大点之间，画一条直线。可能是我太笨，望赐教。

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

[讨论] 求分堆分组后包围盒的最小点与最大点

最佳答案