Spline精确包围盒ClosestPointToProjection应用

rjtiantian · 发表于 2013-12-3 08:59:54

从动画看起来很精彩.

Highflybird · 发表于 2013-12-3 15:26:35

本帖最后由 Highflybird 于 2013-12-3 15:30 编辑

我再精简一下：

;;;----------------------------------------------------;
;;;功能: 曲线的包围盒 ;
;;;输入: 曲线的图元名 ;
;;;输出: 曲线的包围盒的四个角点(2d) ;
;;;----------------------------------------------------;
(defun Cur:BoundingPoints (Curve / ll ur pts x)
(vla-getboundingbox (vlax-ename->vla-object Curve) 'll 'ur)
(setq ll (vlax-safearray->list ll))
(setq ur (vlax-safearray->list ur))
;;(command "rectangle" ll ur) ; For comparing if it's a spline.
(foreach n '((1 0 0) (0 1 0)) ; Add '(0 0 1) for 3d box.
(foreach p (list ll ur)
(setq x (vlax-curve-getClosestPointToProjection curve p n T))
(and x (setq pts (cons x pts)))
)
)
(setq ll (apply 'mapcar (cons 'min pts)))
(setq ur (apply 'mapcar (cons 'max pts)))
(list ll (list (car ur) (cadr ll) 0)
ur (list (car ll) (cadr ur) 0)
)
)

;;;----------------------------------------------------; 
;;;功能: 曲线的包围盒                                       ; 
;;;输入: 曲线的图元名                                       ; 
;;;输出: 曲线的包围盒的四个角点(2d)                    ; 
;;;----------------------------------------------------; 
(defun Cur:BoundingPoints (Curve / ll ur pts x) 
  (vla-getboundingbox (vlax-ename->vla-object Curve) 'll 'ur) 
  (setq ll (vlax-safearray->list ll)) 
  (setq ur (vlax-safearray->list ur)) 
  ;;(command "rectangle" ll ur)                                ; For comparing if it's a spline. 
  (foreach n '((1 0 0) (0 1 0))                                ; Add  '(0 0 1) for 3d box. 
    (foreach p (list ll ur) 
      (setq x (vlax-curve-getClosestPointToProjection curve p n T)) 
      (and x (setq pts (cons x pts))) 
    ) 
  ) 
  (setq ll (apply 'mapcar (cons 'min pts))) 
  (setq ur (apply 'mapcar (cons 'max pts))) 
  (list ll (list (car ur) (cadr ll) 0) 
        ur (list (car ll) (cadr ur) 0) 
  ) 
)

st788796 · 发表于 2013-12-3 16:13:56

Highflybird 发表于 2013-12-3 15:26
我再精简一下：

对这个Spline Box , 稍加修改, 不需要旋转 spline 就可以改造为适合 UCS

Highflybird · 发表于 2013-12-3 16:30:53

st788796 发表于 2013-12-3 16:13
对这个Spline Box , 稍加修改, 不需要旋转 spline 就可以改造为适合 UCS

是的，无须旋转实体，就可以求出UCS下的。找一个稍微大一点的方形，然后用这个方法即可。

st788796 · 发表于 2013-12-3 17:15:34

本帖最后由 st788796 于 2013-12-3 18:09 编辑

就用 UCS 的轴
(getvar "ucsxdir")
(getvar "ucsydir")

st788796 · 发表于 2013-12-4 07:54:17

本帖最后由 st788796 于 2013-12-4 07:56 编辑

Highflybird 发表于 2013-12-3 16:30
是的，无须旋转实体，就可以求出UCS下的。找一个稍微大一点的方形，然后用这个方法即可。

再扩展下, Spline 的 Box 无需使用 GetboundingBox, 使用 ControlPoint 的 Box 即可
下面代码转换关系还不对，高飞版主给诊断诊断

(defun Spline:Box (e / el pts ll)
(if (and (setq el (entget e))
(= (cdr (assoc 0 el)) "SPLINE")
)
(progn
(setq
pts (mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) el)
)
ll (list (apply 'mapcar (cons 'min pts))
(apply 'mapcar (cons 'max pts))
)
)
(foreach n (list (getvar "ucsxdir") (getvar "ucsydir"))
(foreach p ll
(setq x (vlax-curve-getclosestpointtoprojection e p n t))
(and x (setq ptl (cons x ptl)))
)
)
(list (apply 'mapcar (cons 'min ptl))
(apply 'mapcar (cons 'max ptl))
)
)
)
)

牢固 · 发表于 2013-12-4 11:41:40

本帖最后由牢固于 2013-12-4 11:46 编辑

st788796 发表于 2013-12-4 07:54
再扩展下, Spline 的 Box 无需使用 GetboundingBox, 使用 ControlPoint 的 Box 即可
下面代码转换关系还 ...

更正如下：

(defun Spline:Box (E / EL PTS LL DD X PTL P1 P3 P2 P4) (if (and (setq el (entget e)) (= (cdr (assoc 0 el)) "SPLINE"))
(progn
(setq pts (mapcar
'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) el))
ll (list (apply 'mapcar (cons 'min pts))
(apply 'mapcar (cons 'max pts)))
dd (* 0.5 (apply 'distance ll))
dd (list dd dd 0)
ll (mapcar '(lambda (p) (trans p 0 1)) ll)
ll (list (trans (mapcar '- (car ll) dd) 1 0) (trans (mapcar '+ (cadr ll) dd) 1 0))
)
(foreach n (list (getvar "ucsxdir") (getvar "ucsydir"))
(foreach p ll
(setq x (vlax-curve-getclosestpointtoprojection e p n t))
(and x (setq ptl (cons x ptl)))))
(setq ptl (mapcar '(lambda (p) (trans p 0 1)) ptl))
(setq p1 (apply 'mapcar (cons 'min ptl))
p3 (apply 'mapcar (cons 'max ptl))
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p3))
)
(mapcar '(lambda (p) (trans p 1 0)) (list p1 p2 p3 p4))
)
)
)

(defun Spline:Box  (E / EL PTS LL DD X PTL P1 P3 P2 P4)  (if (and (setq el (entget e)) (= (cdr (assoc 0 el)) "SPLINE")) 
    (progn 
      (setq pts        (mapcar 
                  'cdr 
                  (vl-remove-if-not '(lambda (x) (= (car x) 10)) el)) 
            ll        (list (apply 'mapcar (cons 'min pts)) 
                      (apply 'mapcar (cons 'max pts))) 
            dd (* 0.5 (apply 'distance ll)) 
            dd (list dd dd 0) 
            ll (mapcar '(lambda (p) (trans p 0 1)) ll) 
            ll (list (trans (mapcar '- (car ll) dd) 1 0) (trans (mapcar '+ (cadr ll) dd) 1 0)) 
            ) 
      (foreach n  (list (getvar "ucsxdir") (getvar "ucsydir")) 
        (foreach p  ll 
          (setq x (vlax-curve-getclosestpointtoprojection e p n t)) 
          (and x (setq ptl (cons x ptl))))) 
      (setq ptl (mapcar '(lambda (p) (trans p 0 1)) ptl)) 
      (setq p1 (apply 'mapcar (cons 'min ptl)) 
            p3 (apply 'mapcar (cons 'max ptl)) 
            p2 (list (car p1) (cadr p3) (caddr p1)) 
            p4 (list (car p3) (cadr p1) (caddr p3)) 
            ) 
      (mapcar '(lambda (p) (trans p 1 0)) (list p1 p2 p3 p4)) 
      ) 
    ) 
  )

st788796 · 发表于 2013-12-4 11:46:16

本帖最后由 st788796 于 2013-12-4 11:47 编辑

牢固发表于 2013-12-4 11:41
更正如下：

G 版再改改就适合所有的 Curve 类了

GetBoundingBox + Curve_GetClosestPointToProject

牢固 · 发表于 2013-12-4 11:48:14

st788796 发表于 2013-12-4 11:46
G 版再改改就适合所有的 Curve 类了

适合所有曲线版本：

(defun gxl-GetCurveUcsBox (curve / obj p1 p2 p3 p4 lst d)
(if (= 'ename (type curve))
(setq obj (vlax-ename->vla-object curve))
(setq obj curve)
)
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (trans (vlax-safearray->list p1) 0 1)
p3 (trans (vlax-safearray->list p3) 0 1)
d (* 0.5 (distance p1 p3))
p1 (list (- (car p1) d) (- (cadr p1) d) (caddr p1))
p3 (list (+ (car p3) d) (+ (cadr p3) d) (caddr p3))
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(SETQ lst
(mapcar '(lambda (a b)
(vlax-curve-getClosestPointToProjection curve a b t))
(mapcar '(lambda (p) (trans p 1 0)) (list p1 p2 p3 p4))
(list (getvar 'ucsxdir)
(getvar 'ucsydir)
(getvar 'ucsxdir)
(getvar 'ucsydir))
)
lst (mapcar '(lambda (p) (trans p 0 1)) lst)
)
(setq p1 (apply 'mapcar (cons 'min lst))
p3 (apply 'mapcar (cons 'max lst))
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(mapcar '(lambda (p) (trans p 1 0)) (list p1 p2 p3 p4))
)

(defun gxl-GetCurveUcsBox  (curve / obj p1 p2 p3 p4 lst d) 
  (if (= 'ename (type curve)) 
    (setq obj (vlax-ename->vla-object curve)) 
    (setq obj curve) 
    ) 
  (vla-GetBoundingBox obj 'p1 'p3) 
  (setq  p1 (trans (vlax-safearray->list p1) 0 1) 
  p3 (trans (vlax-safearray->list p3) 0 1) 
  d  (* 0.5 (distance p1 p3)) 
  p1 (list (- (car p1) d) (- (cadr p1) d) (caddr p1)) 
  p3 (list (+ (car p3) d) (+ (cadr p3) d) (caddr p3)) 
  p2 (list (car p1) (cadr p3) (caddr p1)) 
  p4 (list (car p3) (cadr p1) (caddr p1)) 
  ) 
  (SETQ  lst 
      (mapcar '(lambda (a b) 
           (vlax-curve-getClosestPointToProjection curve a b t)) 
        (mapcar '(lambda (p) (trans p 1 0)) (list p1 p2 p3 p4)) 
        (list (getvar 'ucsxdir) 
        (getvar 'ucsydir) 
        (getvar 'ucsxdir) 
        (getvar 'ucsydir)) 
        ) 
  lst (mapcar '(lambda (p) (trans p 0 1)) lst) 
  ) 
  (setq  p1 (apply 'mapcar (cons 'min lst)) 
  p3 (apply 'mapcar (cons 'max lst)) 
  p2 (list (car p1) (cadr p3) (caddr p1)) 
  p4 (list (car p3) (cadr p1) (caddr p1)) 
  ) 
  (mapcar '(lambda (p) (trans p 1 0)) (list p1 p2 p3 p4)) 
  )

st788796 · 发表于 2013-12-4 11:52:39

牢固发表于 2013-12-4 11:48
适合所有曲线版本：

赞一个!
aLisp 在求 Entity Box 的时候用这个可以减少大量的 Rotate 和变换了!

st788796 · 发表于 2013-12-4 14:37:29

本帖最后由 st788796 于 2013-12-4 15:17 编辑

牢固发表于 2013-12-4 11:48
适合所有曲线版本：

稍微简化下, WCS 下返回 WCS 点, UCS 下返回 UCS 点

(defun Curve:Box (obj / p1 p3 lst d xdir ydir)
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (trans (safearray-value p1) 0 1)
p3 (trans (safearray-value p3) 0 1)
d (* 0.5 (distance p1 p3))
lst (list
(setq p1 (list (- (car p1) d) (- (cadr p1) d) (caddr p1)))
(setq p3 (list (+ (car p3) d) (+ (cadr p3) d) (caddr p3)))
(list (car p1) (cadr p3) (caddr p1))
(list (car p3) (cadr p1) (caddr p1))
)
xdir (getvar "ucsxdir")
ydir (getvar "ucsydir")
lst (mapcar '(lambda (a b)
(vlax-curve-getClosestPointToProjection obj a b t)
)
(mapcar '(lambda (p) (trans p 1 0)) lst)
(list xdir ydir xdir ydir)
)
lst (mapcar '(lambda (x) (trans x 0 1)) lst)
p1 (apply 'mapcar (cons 'min lst))
p3 (apply 'mapcar (cons 'max lst))
)
(list p1
(list (car p1) (cadr p3) (caddr p1))
p3
(list (car p3) (cadr p1) (caddr p1))
)
)

(defun Curve:Box (obj / p1 p3 lst d xdir ydir) 
  (vla-GetBoundingBox obj 'p1 'p3) 
  (setq        p1   (trans (safearray-value p1) 0 1) 
        p3   (trans (safearray-value p3) 0 1) 
        d    (* 0.5 (distance p1 p3)) 
        lst  (list 
               (setq p1 (list (- (car p1) d) (- (cadr p1) d) (caddr p1))) 
               (setq p3 (list (+ (car p3) d) (+ (cadr p3) d) (caddr p3))) 
               (list (car p1) (cadr p3) (caddr p1)) 
               (list (car p3) (cadr p1) (caddr p1)) 
             ) 
        xdir (getvar "ucsxdir") 
        ydir (getvar "ucsydir") 
        lst  (mapcar '(lambda (a b) 
                        (vlax-curve-getClosestPointToProjection obj a b t) 
                      ) 
                     (mapcar '(lambda (p) (trans p 1 0)) lst) 
                     (list xdir ydir xdir ydir) 
             ) 
        lst  (mapcar '(lambda (x) (trans x 0 1)) lst) 
        p1   (apply 'mapcar (cons 'min lst)) 
        p3   (apply 'mapcar (cons 'max lst)) 
  ) 
  (list        p1 
        (list (car p1) (cadr p3) (caddr p1)) 
        p3 
        (list (car p3) (cadr p1) (caddr p1)) 
  ) 
)

alisp只能补充一个判断函数，ARX 有 Parent 方法

(defun IsCurve (obj)
(wcmatch (strcase (vla-get-objectname obj))
"*LINE,*ARC,*CIRCLE,*ELLIPSE"
)
)

taner · 发表于 2013-12-4 15:41:35

如果您要查看本帖隐藏内容请回复，哈哈！

renox · 发表于 2013-12-5 13:37:47

看下先

lucas3 · 发表于 2014-1-16 22:24:27

st788796 发表于 2013-12-4 14:37
稍微简化下, WCS 下返回 WCS 点, UCS 下返回 UCS 点

alisp只能补充一个判断函数，ARX 有 Parent 方法
...

请问st788796大师在明经的用户名

st788796 · 发表于 2014-1-16 22:30:33

lucas3 发表于 2014-1-16 22:24
请问st788796大师在明经的用户名

游客

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

[每日一码] Spline精确包围盒ClosestPointToProjection应用

点评

点评

点评

点评

点评

点评

评分

点评

点评