选择集对角点（包容盒）--快速求法的思考

尘缘一生 · 发表于 2021-12-30 18:56:29

本帖最后由尘缘一生于 2021-12-30 19:50 编辑

;;求屏幕（左下角右上角中点）-------（一级）------------
(defun sl_pm2pt (/ a b c d x)
(setq b (getvar "viewsize")
c (car (getvar "screensize"))
d (cadr (getvar "screensize"))
a (* b (/ c d))
x (trans (getvar "viewctr") 1 2)
c (trans (list (- (car x) (* a 0.5)) (- (cadr x) (* b 0.5)) 0.0) 2 1)
d (trans (list (+ (car x) (* a 0.5)) (+ (cadr x) (* b 0.5)) 0.0) 2 1)
e (sl:mid c d)
)
(list c d e) ;;c 左下 d 右上 e 中心
)
;返回最大外型两对角点的表 -----（一级)-------------
(defun get-box (ss / len ptlis pp objlst boxlst minlst maxlst enam obj)
(defun get-ssbox (ss) ;返回集最大外框两对角点的表
(setq len (sslength ss))
(cond
((< len 500) ;实体小于500，采用高飞鸟求凸包
(setq ptlis (getpt ss 50))
(setq ptlis (graham-scan ptlis))
(if (<= (det (car ptlis) (cadr ptlis) (caddr ptlis)) 0.0)
(setq ptlis (reverse ptlis))
)
(setq pp (car (minarearectangle ptlis)))
(setq ptlis (list (car pp) (caddr pp)))
)
((and (>= len 500) (< len 10000)) ;实体大于500，小于10000，采用常规
(setq objlst (mapcar 'en2obj (ss-enlst ss)))
(setq boxlst (mapcar 'get-enbox objlst))
(setq minlst (mapcar 'car boxlst))
(setq maxlst (mapcar 'cadr boxlst))
(setq ptlis (list (apply 'mapcar (cons 'min minlst)) (apply 'mapcar (cons 'max maxlst))))
)
((>= len 10000) ;;实体多于 10000，采用视口近似
(command "_zoom" "_object" ss "")
(setq pp (sl_pm2pt))
(setq ptlis (list (car pp) (cadr pp)))
(command "_zoom" "_p")
)
)
)
;;返回对象最大外框两对角点的表---------
(defun get-enbox (obj)
(if (= (type obj) 'ENAME) (setq obj (en2obj obj)))
(vla-getboundingbox obj 'Minp 'Maxp)
(setq ptlis (mapcar 'vlax-safearray->list (list Minp Maxp)))
)
;返回点表最大外框两对角点的表
(defun get-extents (lst)
(setq ptlis (list (apply 'mapcar (cons 'min lst)) (apply 'mapcar (cons 'max lst))))
)
(cond
((= (type ss) 'PICKSET) (get-ssbox ss)) ;集
((= (type ss) 'ENAME) (get-enbox ss)) ;图元
((= (type ss) 'LIST) (get-extents ss)) ;点表
(t nil)
)
ptlis
)

Wanda · 发表于 2021-12-31 08:22:48

楼主居然还活跃

tigcat · 发表于 2022-1-1 10:23:23

;by MP

(defun SSBoundingBox ( ss / _GetBoundingBox _SStoObjects _Main )
(defun _GetBoundingBox ( object / p1 p2 )
(vl-catch-all-apply
'(lambda ( )
(vlax-invoke-method
object
'GetBoundingBox
'p1
'p2
)
)
)
(if p1
( (lambda (data)
(mapcar
'(lambda (funcs)
(mapcar
'(lambda (func)
(apply func data)
)
funcs
)
)
'( (caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
(list
(mapcar
'vlax-safearray->list
(list p1 p2)
)
)
)
)
)
(defun _SStoObjects ( ss / i objects )
(if (eq 'pickset (type ss))
(repeat (setq i (sslength ss))
(setq objects
(cons
(vlax-ename->vla-object
(ssname ss
(setq i (1- i))
)
)
objects
)
)
)
)
objects
)
(defun _Main ( ss / boundingboxes )
(cond
( (setq boundingboxes
(vl-remove-if 'null
(mapcar '_GetBoundingBox
(_SStoObjects ss)
)
)
)
(mapcar
'(lambda ( func pair / lst )
(list
(apply (car pair)
(mapcar 'car
(setq lst
(mapcar
func
boundingboxes
)
)
)
)
(apply (cadr pair)
(mapcar 'cadr lst)
)
)
)
'(car cadr caddr cadddr)
'((min min)(max min)(max max)(min max))
)
)
)
)
(_Main ss)
)

(defun SSBoundingBox ( ss / _GetBoundingBox _SStoObjects _Main ) 
 
   (defun _GetBoundingBox ( object / p1 p2 ) 
       (vl-catch-all-apply 
          '(lambda ( ) 
               (vlax-invoke-method 
                   object 
                  'GetBoundingBox 
                  'p1 
                  'p2 
               ) 
           ) 
       ) 
       (if p1 
           (   (lambda (data) 
                   (mapcar 
                      '(lambda (funcs) 
                           (mapcar 
                              '(lambda (func) 
                                   (apply func data) 
                               ) 
                               funcs 
                           ) 
                       )    
                      '(   (caar cadar) 
                           (caadr cadar) 
                           (caadr cadadr) 
                           (caar cadadr) 
                       ) 
                   ) 
               )    
               (list 
                   (mapcar 
                       'vlax-safearray->list 
                       (list p1 p2) 
                   ) 
               ) 
           ) 
       )    
   ) 
    
   (defun _SStoObjects ( ss / i objects ) 
       (if (eq 'pickset (type ss)) 
           (repeat (setq i (sslength ss)) 
               (setq objects 
                   (cons 
                       (vlax-ename->vla-object 
                           (ssname ss 
                               (setq i (1- i)) 
                           ) 
                       ) 
                       objects 
                   ) 
               ) 
           ) 
       ) 
       objects 
   ) 
    
   (defun _Main ( ss / boundingboxes )   
       (cond 
           (   (setq boundingboxes 
                   (vl-remove-if 'null 
                       (mapcar '_GetBoundingBox 
                           (_SStoObjects ss) 
                       ) 
                   ) 
               )    
               (mapcar 
                  '(lambda ( func pair / lst ) 
                       (list 
                           (apply (car pair) 
                               (mapcar 'car 
                                   (setq lst 
                                       (mapcar 
                                           func 
                                           boundingboxes 
                                       ) 
                                   ) 
                               )    
                           ) 
                           (apply (cadr pair) 
                               (mapcar 'cadr lst) 
                           ) 
                       )    
                   ) 
                  '(car cadr caddr cadddr) 
                  '((min min)(max min)(max max)(min max))    
               )    
           )    
       ) 
   ) 
    
   (_Main ss) 
    
)

894560869 · 发表于 2022-2-11 07:04:26

感谢大佬分享

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