[LISP函数]：块参照的变换矩阵

highflybird

块参照的变换矩阵，可能已经在本论坛上讨论过了，但今天我给大家介绍一个很好的程序。来自于国外的gile.
这个程序能把块内的一点的坐标MCS转换成 WCS或者UCS
或者进行逆转换.在很多场合中都可能用到这样的转换矩阵。
现在共享出来。其中还有几个很简明的矩阵函数，譬如，矩阵和矢量相乘，矢量的点积，矩阵的转置，矩阵的乘法。等等。
这个转换函数流程清晰简明，值得一看。
[php]
;; TransNested (gile)
;; Translates a point coordinates from WCS or UCS to RCS -coordinates system of a
;; reference (xref or block) whatever its nested level-
;;
;; Arguments
;; pt : the point to translate
;; rlst : the parents entities list from the deepest nested to the one inserted in
;;        current space -same as (last (nentsel)) or (last (nentselp))
;; from to : as with trans function: 0 for WCS, 1 for current UCS, 2 for RCS

(defun TransNested (pt rlst from to / mat dep)
  (setq mat '((1 0 0) (0 1 0) (0 0 1)))
  (and (= 1 from) (setq pt (trans pt 1 0)))
  (and (= 2 to) (setq rlst (reverse rlst)))
  (and (or (= 2 from) (= 2 to))
       (while rlst
        (setq geom (if        (= 2 to)
                      (RevRefGeom (car rlst))
                      (RefGeom (car rlst))
                    )
               rlst (cdr rlst)
               mat  (mxm (car geom) mat)
               pt   (mapcar '+ (mxv (car geom) pt) (cadr geom))
        )
       )
  )
  (if (= 1 to)
    (trans pt 0 1)
    pt
  )
)

;; RefGeom (gile)
;; Returns a list which first item is a 3x3 transformation matrix (rotation,
;; scales, normal) and second item the object insertion point in its parent
;; (xref, bloc or space)
;;
;; Argument : an ename

(defun RefGeom (ename / elst ang norm)
  (setq        elst (entget ename)
        ang  (cdr (assoc 50 elst))
        norm (cdr (assoc 210 elst))
  )
  (list
    (setq mat
           (mxm
             (mapcar (function (lambda (v) (trans v 0 norm T)))
                     '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
             )
             (mxm
               (list (list (cos ang) (- (sin ang)) 0.0)
                     (list (sin ang) (cos ang) 0.0)
                     '(0.0 0.0 1.0)
               )
               (list (list (cdr (assoc 41 elst)) 0.0 0.0)
                     (list 0.0 (cdr (assoc 42 elst)) 0.0)
                     (list 0.0 0.0 (cdr (assoc 43 elst)))
               )
             )
           )
    )
    (trans
      (mapcar
        '-
        (cdr (assoc 10 elst))
        (mxv mat
             (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))
        )
      )
      norm
      0
    )
  )
)

;; RevRefGeom (gile)
;; RefGeom inverse function

(defun RevRefGeom (ename / entData ang norm mat)
  (setq        entData        (entget ename)
        ang        (- (cdr (assoc 50 entData)))
        norm        (cdr (assoc 210 entData))
  )
  (list
    (setq mat
           (mxm
             (list (list (/ 1 (cdr (assoc 41 entData))) 0.0 0.0)
                   (list 0.0 (/ 1 (cdr (assoc 42 entData))) 0.0)
                   (list 0.0 0.0 (/ 1 (cdr (assoc 43 entData))))
             )
             (mxm
               (list (list (cos ang) (- (sin ang)) 0.0)
                     (list (sin ang) (cos ang) 0.0)
                     '(0.0 0.0 1.0)
               )
               (mapcar (function (lambda (v) (trans v norm 0 T)))
                       '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
               )
             )
           )
    )
    (mapcar '-
            (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 entData)))))
            (mxv mat (trans (cdr (assoc 10 entData)) norm 0))
    )
  )
)

;;; VXV Returns the dot product of 2 vectors
(defun vxv (v1 v2)
  (apply '+ (mapcar '* v1 v2))
)

;; TRP Transpose a matrix -Doug Wilson-
(defun trp (m)
  (apply 'mapcar (cons 'list m))
)

;; MXV Apply a transformation matrix to a vector -Vladimir Nesterovsky-
(defun mxv (m v)
  (mapcar '(lambda (r) (vxv r v)) m)
)

;; MXM Multiply two matrices -Vladimir Nesterovsky-
(defun mxm (m q)
  (mapcar '(lambda (r) (mxv (trp q) r)) m)
)


;;; Get-TMatrix (gile)
;;; Returns a transformation matrix (4X4) as this returned by nentselp
;;;
;;; Argument : the parents entities list from the deepest nested to the one inserted in
;;                  current space -same as (last (nentsel)) or (last (nentselp))

(defun get-tmatrix (lst / mat pt geom)
    (setq geom (refgeom (car lst))
          mat  (car geom)
          pt   (cadr geom)
          lst  (cdr lst)
    )
  (while lst
    (setq geom (refgeom (car lst))
          mat  (mxm (car geom) mat)
          pt   (mapcar '+ (mxv (car geom) pt) (cadr geom))
          lst  (cdr lst)
    )
  )
  (append
    (mapcar '(lambda (v x) (append v (list x))) mat pt)
    (list '(0.0 0.0 0.0 1.0))
  )
)
[/php]

carrot1983

谢谢楼主分享。

It's great!Now it's perfect!
I learned a lot from this topic.
Now I am going to write a routine  about how to get the boundingBox  of  a insert.
Because just use "vla-GetBoundingBox" simply,it will get a wrong result,sometimes badly.

我现在也遇到了类似的问题。
于是也想到了转换矩阵。
正在学习。。。
还没得到我想要的结果。
－－－－－－－－－－－－－－借宝地，求助
得到多文字的最小矩形包围盒，如图：

taner

http://www.theswamp.org/index.php?topic=26591.0

zteykmgscqh

果然是大师风范啊

kocer

谢谢分享                  

yuanziyou

求块内的坐标太需要了