【越飞越高讲堂15】用LISP论矩阵

highflybir · 发表于 2013-1-4 19:30:43

本帖最后由 highflybir 于 2013-1-9 12:51 编辑

用LISP论矩阵

矩阵的LISP程序，国内讨论的比较少，而国外的研究比较深入。
经过长时间的收藏和探索，我综合成了这篇帖子。
这个帖子里面的函数主要是跟CAD 相关。附件包含了本帖完整的lisp代码，还有测试样例。
是一个比较完整的矩阵库。
另外，本帖附上了一些矩阵相关链接。

错误和纰漏之处请大家多多指教。

样例及演示可以参考12楼，另外附件中也有样例。

一、向量的运算
向量，矩阵是息息相关的。这里列出了向量的一些基本运算。

;;;-----------------------------------------------------------;;
;;; 两向量相加 addition ;;
;;; Input: v1,v2 -vectors in R^n ;;
;;; OutPut: A vector ;;
;;;-----------------------------------------------------------;;
(defun MAT:v+v (v1 v2)
(mapcar '+ v1 v2)
)
;;;-----------------------------------------------------------;;
;;; 两向量相减 subtraction ;;
;;; Input: v1,v2 -vectors in R^n ;;
;;; OutPut: A vector ;;
;;;-----------------------------------------------------------;;
(defun MAT:v-v (v1 v2)
(mapcar '- v1 v2)
)
;;;-----------------------------------------------------------;;
;;; 两向量相乘 multiplication ;;
;;; Input: v1,v2 -vectors in R^n ;;
;;; OutPut: A vector ;;
;;;-----------------------------------------------------------;;
(defun MAT:v*v (v1 v2)
(mapcar '* v1 v2)
)
;;;-----------------------------------------------------------;;
;;; 两向量相除 division ;;
;;; Input: v1,v2 -vectors in R^n ;;
;;; OutPut: A vector ;;
;;;-----------------------------------------------------------;;
(defun MAT:v/v (v1 v2)
(mapcar '/ v1 v2)
)
;;;-----------------------------------------------------------;;
;;; 向量乘标量(系数) ;;
;;; Vector x Scalar - Lee Mac ;;
;;; Args: v - vector in R^n, s - real scalar ;;
;;;-----------------------------------------------------------;;
(defun MAT:vxs ( v s )
(mapcar (function (lambda ( n ) (* n s))) v)
)
;;;-----------------------------------------------------------;;
;;; 两向量的点积 ;;
;;; Vector Dot Product ;;
;;; Input: v1,v2 -vectors in R^n ;;
;;;-----------------------------------------------------------;;
(defun MAT:Dot (v1 v2)
(apply '+ (mapcar '* v1 v2))
)
;;;-----------------------------------------------------------;;
;;; 两向量的叉积 ;;
;;; Vector Cross Product ;;
;;; Args: u,v - vectors in R^3 ;;
;;;-----------------------------------------------------------;;
(defun MAT:vxv ( u v )
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(- (* (car v) (caddr u)) (* (car u) (caddr v)))
(- (* (car u) (cadr v)) (* (car v) (cadr u)))
)
)
;;;-----------------------------------------------------------;;
;;; 线性组合标量组乘向量组 ;;
;;; Linear combination - highflybird ;;
;;; Input: Vectors - vectors, Scalars, - a real number list ;;
;;; Output: a vector ;;
;;;-----------------------------------------------------------;;
(defun MAT:SxVs (Vectors Scalars)
(apply 'mapcar (cons '+ (mapcar 'MAT:vxs Vectors Scalars)))
)
;;;-----------------------------------------------------------;;
;;; 向量的模(长度) ;;
;;; Vector Norm - Lee Mac ;;
;;; Args: v - vector in R^n ;;
;;;-----------------------------------------------------------;;
(defun MAT:norm ( v )
(sqrt (apply '+ (mapcar '* v v)))
)
;;;-----------------------------------------------------------;;
;;; 向量的模(长度) ;;
;;; Vector Norm - highflybird ;;
;;; Args: v - vector in R^3 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Norm3D ( v )
(distance '(0 0 0) v)
)
;;;-----------------------------------------------------------;;
;;; 单位向量 ;;
;;; Unit Vector - Lee Mac ;;
;;; Args: v - vector in R^n ;;
;;;-----------------------------------------------------------;;
(defun MAT:Unitization (v)
( (lambda (n)
(if (equal 0.0 n 1e-14)
nil
(MAT:vxs v (/ 1.0 n))
)
)
(MAT:norm v)
)
)
;;;-----------------------------------------------------------;;
;;; 单位向量 ;;
;;; Unit Vector - highflybird ;;
;;; Args: v - vector in R^3 ;;
;;;-----------------------------------------------------------;;
(defun MAT:unit ( v / l)
(cond
( (= (setq l (MAT:Norm3D v)) 1.0 ) v)
( (> l 1e-14) (MAT:vxs v (/ 1.0 l)))
)
)
;;;-----------------------------------------------------------;;
;;; 两个2d向量的叉积的数值 ;;
;;; 输入: 两个点（或者两个向量） ;;
;;; 输出: 一个数值.如果为正则是逆时针,两向量形成的平面法线向量;;
;;; 向上，为负则是顺时针，为零则两向量共线或平行。 ;;
;;; 这个数值也为原点,P1,P2三点面积的两倍。 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Det2V (v1 v2)
(- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
)

;;;-----------------------------------------------------------;; 
;;; 两向量相加 addition                                       ;; 
;;; Input: v1,v2 -vectors in R^n                              ;; 
;;; OutPut: A vector                                          ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:v+v (v1 v2) 
  (mapcar '+ v1 v2) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两向量相减  subtraction                                   ;; 
;;; Input: v1,v2 -vectors in R^n                              ;; 
;;; OutPut: A vector                                          ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:v-v (v1 v2) 
  (mapcar '- v1 v2) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两向量相乘  multiplication                                ;; 
;;; Input: v1,v2 -vectors in R^n                              ;; 
;;; OutPut: A vector                                          ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:v*v (v1 v2) 
  (mapcar '* v1 v2) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两向量相除  division                                      ;; 
;;; Input: v1,v2 -vectors in R^n                              ;; 
;;; OutPut: A vector                                          ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:v/v (v1 v2) 
  (mapcar '/ v1 v2) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 向量乘标量(系数)                                              ;; 
;;; Vector x Scalar - Lee Mac                                      ;; 
;;; Args: v - vector in R^n, s - real scalar                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:vxs ( v s ) 
  (mapcar (function (lambda ( n ) (* n s))) v) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两向量的点积                                              ;; 
;;; Vector Dot Product                                        ;; 
;;; Input: v1,v2 -vectors in R^n                              ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Dot (v1 v2) 
  (apply '+ (mapcar '* v1 v2)) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两向量的叉积                                              ;; 
;;; Vector Cross Product                                       ;; 
;;; Args: u,v - vectors in R^3                                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:vxv ( u v ) 
  (list 
    (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u))) 
    (- (* (car  v) (caddr u)) (* (car  u) (caddr v))) 
    (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u))) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 线性组合  标量组乘向量组                                  ;; 
;;; Linear combination - highflybird                          ;; 
;;; Input: Vectors - vectors, Scalars, - a real number list   ;; 
;;; Output: a vector                                          ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:SxVs (Vectors Scalars) 
  (apply 'mapcar (cons '+ (mapcar 'MAT:vxs Vectors Scalars))) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 向量的模(长度)                                              ;; 
;;; Vector Norm - Lee Mac                                             ;; 
;;; Args: v - vector in R^n                                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:norm ( v ) 
  (sqrt (apply '+ (mapcar '* v v))) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 向量的模(长度)                                              ;; 
;;; Vector Norm - highflybird                                      ;; 
;;; Args: v - vector in R^3                                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Norm3D ( v ) 
  (distance '(0 0 0) v) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 单位向量                                                      ;; 
;;; Unit Vector - Lee Mac                                     ;; 
;;; Args: v - vector in R^n                                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Unitization (v) 
  ( (lambda (n) 
      (if (equal 0.0 n 1e-14) 
        nil 
        (MAT:vxs v (/ 1.0 n)) 
      ) 
    ) 
    (MAT:norm v) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 单位向量                                                      ;; 
;;; Unit Vector - highflybird                                 ;; 
;;; Args: v - vector in R^3                                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:unit ( v / l) 
  (cond 
    ( (= (setq l (MAT:Norm3D v)) 1.0 ) v) 
    ( (> l 1e-14) (MAT:vxs v (/ 1.0 l))) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 两个2d向量的叉积的数值                                    ;; 
;;; 输入: 两个点（或者两个向量）                              ;; 
;;; 输出: 一个数值.如果为正则是逆时针,两向量形成的平面法线向量;; 
;;;       向上，为负则是顺时针，为零则两向量共线或平行。      ;; 
;;;       这个数值也为原点,P1,P2三点面积的两倍。              ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Det2V (v1 v2) 
  (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))) 
)

二、向量的旋转

;;;-----------------------------------------------------------;;
;;; 旋转一个向量或者点90度 ;;
;;; 输入: 一个向量 ;;
;;; 输出: 被旋转90度后的向量 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Rot90 (vec)
(vl-list* (- (cadr vec)) (car vec) (cddr vec))
)
;;;-----------------------------------------------------------;;
;;; 旋转向量到指定角度 ;;
;;; 输入: 一个向量和指定的角度 ;;
;;; 输出: 被旋转后的向量 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Rot2D (v a / c s x y)
(setq c (cos a) s (sin a))
(setq x (car v) y (cadr v))
(list (- (* x c) (* y s)) (+ (* x s) (* y c)))
)

三、行列式
这里只讨论二阶和三阶的行列式

;;;-----------------------------------------------------------;;
;;; 2d行列式 determinant in R^2 ;;
;;; Args: 4 numbers ;;
;;;-----------------------------------------------------------;;
(defun MAT:Det2 (x1 y1 x2 y2)
(- (* x1 y2) (* x2 y1))
)
;;;-----------------------------------------------------------;;
;;; 3d行列式 determinant in R^3 ;;
;;; Args: 9 numbers ;;
;;;-----------------------------------------------------------;;
(defun MAT:Det3 (a1 b1 c1 a2 b2 c2 a3 b3 c3)
(+ (* a1 (- (* b2 c3) (* b3 c2)))
(* a2 (- (* b3 c1) (* b1 c3)))
(* a3 (- (* b1 c2) (* b2 c1)))
)
)

四、矩阵的基本运算

;;;-----------------------------------------------------------;;
;;; 矩阵转置 ;;
;;; MAT:trp Transpose a matrix -Doug Wilson- ;;
;;; 输入：矩阵 ;;
;;; 输出：转置后的矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:trp (m)
(apply 'mapcar (cons 'list m))
)
;;;-----------------------------------------------------------;;
;;; 矩阵相加 ;;
;;; Matrix + Matrix - Lee Mac ;;
;;; Args: m,n - nxn matrices ;;
;;;-----------------------------------------------------------;;
(defun MAT:m+m ( m n )
(mapcar '(lambda ( r s ) (mapcar '+ r s)) m n)
)
;;;-----------------------------------------------------------;;
;;; 矩阵相减 ;;
;;; Matrix - Matrix - Lee Mac ;;
;;; Args: m,n - nxn matrices ;;
;;;-----------------------------------------------------------;;
(defun MAT:m-m ( m n )
(mapcar '(lambda ( r s ) (mapcar '- r s)) m n)
)
;;;-----------------------------------------------------------;;
;;; 矩阵相乘 ;;
;;; MAT:mxm Multiply two matrices -Vladimir Nesterovsky- ;;
;;;-----------------------------------------------------------;;
(defun MAT:mxm (m q)
(mapcar (function (lambda (r) (MAT:mxv (MAT:trp q) r))) m)
)
;;;-----------------------------------------------------------;;
;;; 矩阵乘标量 ;;
;;; Matrix x Scalar - Lee Mac ;;
;;; Args: m - nxn matrix, n - real scalar ;;
;;;-----------------------------------------------------------;;
(defun MAT:mxs ( m s )
(mapcar (function (lambda ( v )(MAT:VxS v s))) m)
)

;;;-----------------------------------------------------------;; 
;;; 矩阵转置                                                  ;; 
;;; MAT:trp Transpose a matrix -Doug Wilson-                  ;; 
;;; 输入：矩阵                                                ;; 
;;; 输出：转置后的矩阵                                        ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:trp (m) 
  (apply 'mapcar (cons 'list m)) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 矩阵相加                                                  ;; 
;;; Matrix + Matrix - Lee Mac                                 ;; 
;;; Args: m,n - nxn matrices                                  ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:m+m ( m n ) 
  (mapcar '(lambda ( r s ) (mapcar '+ r s)) m n) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 矩阵相减                                                  ;; 
;;; Matrix - Matrix - Lee Mac                                 ;; 
;;; Args: m,n - nxn matrices                                  ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:m-m ( m n ) 
  (mapcar '(lambda ( r s ) (mapcar '- r s)) m n) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 矩阵相乘                                                  ;; 
;;; MAT:mxm Multiply two matrices -Vladimir Nesterovsky-      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:mxm (m q) 
  (mapcar (function (lambda (r) (MAT:mxv (MAT:trp q) r))) m) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 矩阵乘标量                                                ;; 
;;; Matrix x Scalar - Lee Mac                                 ;; 
;;; Args: m - nxn matrix, n - real scalar                     ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:mxs ( m s ) 
  (mapcar (function (lambda ( v )(MAT:VxS v s))) m) 
)

五、矩阵与向量的运算

;;;-----------------------------------------------------------;;
;;; 向量或点的矩阵变换(向量乘矩阵) ;;
;;; Matrix x Vector - Vladimir Nesterovsky ;;
;;; Args: m - nxn matrix, v - vector in R^n ;;
;;;-----------------------------------------------------------;;
(defun MAT:mxv (m v)
(mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
)
;;;-----------------------------------------------------------;;
;;; 点的矩阵(4x4 matrix) 变换 ;;
;;; 输入：矩阵m和一个三维点p ;;
;;; 输出：点变换后的位置 ;;
;;;-----------------------------------------------------------;;
(defun MAT:mxp (m p)
(reverse (cdr (reverse (MAT:mxv m (append p '(1.0))))))
)

六、矩阵的平面和空间变换
以下是一些矩阵变换的函数。

平移变换

;;;-----------------------------------------------------------;;
;;; 平移变换矩阵方式1 ;;
;;; 参数: ;;
;;; v - 位移矢量 ;;
;;;-----------------------------------------------------------;;
;;;---------------=={ Translate by Matrix }==-----------------;;
;;; ;;
;;; Translation Matrix ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012 ;;
;;;-----------------------------------------------------------;;
;;; Arguments: ;;
;;; v - Displacement vector by which to translate ;;
;;;-----------------------------------------------------------;;
(defun MAT:Translation ( v )
(list
(list 1. 0. 0. (car v))
(list 0. 1. 0. (cadr v))
(list 0. 0. 1. (caddr v))
(list 0. 0. 0. 1.)
)
)

;;;-----------------------------------------------------------;; 
;;; 平移变换矩阵方式1                                              ;; 
;;; 参数:                                                      ;; 
;;; v - 位移矢量                                              ;; 
;;;-----------------------------------------------------------;; 
;;;---------------=={ Translate by Matrix }==-----------------;; 
;;;                                                           ;; 
;;; Translation Matrix                                        ;; 
;;;-----------------------------------------------------------;; 
;;; Author: highflybird, Copyright ? 2012                     ;; 
;;;-----------------------------------------------------------;; 
;;; Arguments:                                                ;; 
;;; v  - Displacement vector by which to translate            ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Translation ( v ) 
  (list 
    (list 1. 0. 0. (car v)) 
    (list 0. 1. 0. (cadr v)) 
    (list 0. 0. 1. (caddr v)) 
    (list 0. 0. 0. 1.) 
  ) 
)

等比缩放变换

;;;-----------------------------------------------------------;;
;;; 比例缩放矩阵 ;;
;;; 参数: ;;
;;; Cen - 基点 ;;
;;; scale - 缩放比例 ;;
;;;-----------------------------------------------------------;;
;;;-----------------=={ Scale by Matrix }==-------------------;;
;;; ;;
;;; Scaling Matrix ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012 ;;
;;;-----------------------------------------------------------;;
;;; Arguments: ;;
;;; Cen - Base Point for Scaling Transformation ;;
;;; scale - Scale Factor by which to scale object ;;
;;;-----------------------------------------------------------;;
(defun MAT:Scaling ( Cen scale / s)
(setq s (- 1 scale))
(list
(list scale 0. 0. (* s (car Cen)))
(list 0. scale 0. (* s (cadr Cen)))
(list 0. 0. scale (* s (caddr Cen)))
'(0. 0. 0. 1.)
)
)

;;;-----------------------------------------------------------;; 
;;; 比例缩放矩阵                                              ;; 
;;; 参数:                                                      ;; 
;;; Cen   - 基点                                              ;; 
;;; scale - 缩放比例                                          ;; 
;;;-----------------------------------------------------------;; 
;;;-----------------=={ Scale by Matrix }==-------------------;; 
;;;                                                           ;; 
;;; Scaling Matrix                                            ;; 
;;;-----------------------------------------------------------;; 
;;; Author: highflybird, Copyright ? 2012                     ;; 
;;;-----------------------------------------------------------;; 
;;; Arguments:                                                ;; 
;;; Cen    - Base Point for Scaling Transformation            ;; 
;;; scale  - Scale Factor by which to scale object            ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Scaling ( Cen scale / s) 
  (setq s (- 1 scale)) 
  (list 
    (list scale 0. 0. (* s (car Cen))) 
    (list 0. scale 0. (* s (cadr Cen))) 
    (list 0. 0. scale (* s (caddr Cen))) 
    '(0. 0. 0. 1.) 
  ) 
)

二维旋转变换

;;;-----------------------------------------------------------;;
;;; 二维旋转变换矩阵 ;;
;;; 参数: ;;
;;; Cen - 基点 ;;
;;; ang - 旋转角度 ;;
;;;-----------------------------------------------------------;;
;;;-----------------=={ Rotate by Matrix }==------------------;;
;;; ;;
;;; Rotation Matrix ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012 ;;
;;;-----------------------------------------------------------;;
;;; Arguments: ;;
;;; Cen - Base Point for Rotation Transformation ;;
;;; ang - Angle through which to rotate object ;;
;;;-----------------------------------------------------------;;
(defun MAT:Rotation ( Cen ang / c s x y)
(setq c (cos ang) s (sin ang))
(setq x (car Cen) y (cadr Cen))
(list
(list c (- s) 0. (- x (- (* c x) (* s y))))
(list s c 0. (- y (+ (* s x) (* c y))))
'(0. 0. 1. 0.)
'(0. 0. 0. 1.)
)
)

;;;-----------------------------------------------------------;; 
;;; 二维旋转变换矩阵                                              ;; 
;;; 参数:                                                      ;; 
;;; Cen - 基点                                                ;; 
;;; ang - 旋转角度                                            ;; 
;;;-----------------------------------------------------------;; 
;;;-----------------=={ Rotate by Matrix }==------------------;; 
;;;                                                           ;; 
;;; Rotation Matrix                                           ;; 
;;;-----------------------------------------------------------;; 
;;; Author: highflybird, Copyright ? 2012                     ;; 
;;;-----------------------------------------------------------;; 
;;; Arguments:                                                ;; 
;;; Cen    - Base Point for Rotation Transformation           ;; 
;;; ang    - Angle through which to rotate object             ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Rotation ( Cen ang / c s x y) 
  (setq c (cos ang) s (sin ang)) 
  (setq x (car Cen) y (cadr Cen)) 
  (list 
    (list c (- s) 0. (- x (- (* c x) (* s y)))) 
    (list s    c  0. (- y (+ (* s x) (* c y)))) 
    '(0. 0. 1. 0.) 
    '(0. 0. 0. 1.) 
  ) 
)

三维旋转变换

;;;-----------------------------------------------------------;;
;;; 三维旋转变换矩阵 ;;
;;; 参数: ;;
;;; Cen - 基点 ;;
;;; Axis - 旋转轴 ;;
;;; ang - 旋转角 ;;
;;;-----------------------------------------------------------;;
;;;---------------=={ 3D Rotate by Matrix }==-----------------;;
;;; Author: highflybird. ;;
;;; Arguments: ;;
;;; Cen ---Input origin point of rotation ;;
;;; Axis---Input axis vector of rotation ;;
;;; Ang ---Input angle of rotation ;;
;;;-----------------------------------------------------------;;
(defun MAT:Rotation3D (Cen Axis Ang / A B C D M N P x y z)
(setq D (distance '(0 0 0) Axis))
(if (or (< D 1e-8) (zerop ang))
'((1. 0. 0. 0.) (0. 1. 0. 0.) (0. 0. 1. 0.) (0. 0. 0. 1.))
(setq N (mapcar '/ Axis (list D D D))
x (car N)
y (cadr N)
z (caddr N)
A (cos Ang)
B (sin Ang)
C (- 1 A)
M (list (list (+ A (* x x C))
(- (* x y C) (* z B))
(+ (* y B) (* x z C))
)
(list (+ (* z B) (* x y C))
(+ A (* y y C))
(- (* y z C) (* x B))
)
(list (- (* x z C) (* y B))
(+ (* x B) (* y z C))
(+ A (* z z C))
)
)
p (mapcar '- Cen (Mat:mxv M Cen))
M (Mat:DispToMatrix M p)
)
)
)

;;;-----------------------------------------------------------;; 
;;; 三维旋转变换矩阵                                              ;; 
;;; 参数:                                                      ;; 
;;; Cen  - 基点                                               ;; 
;;; Axis - 旋转轴                                             ;; 
;;; ang  - 旋转角                                             ;; 
;;;-----------------------------------------------------------;; 
;;;---------------=={ 3D Rotate by Matrix }==-----------------;; 
;;; Author: highflybird.                                      ;; 
;;; Arguments:                                                ;; 
;;; Cen ---Input origin point of rotation                      ;; 
;;; Axis---Input axis vector of rotation                       ;; 
;;; Ang ---Input angle of rotation                              ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Rotation3D (Cen Axis Ang / A B C D M N P x y z) 
  (setq D (distance '(0 0 0) Axis)) 
  (if (or (< D 1e-8) (zerop ang)) 
    '((1. 0. 0. 0.) (0. 1. 0. 0.) (0. 0. 1. 0.) (0. 0. 0. 1.)) 
    (setq N (mapcar '/ Axis (list D D D)) 
          x (car N) 
          y (cadr N) 
          z (caddr N) 
          A (cos Ang) 
          B (sin Ang) 
          C (- 1 A) 
          M (list (list (+ A (* x x C)) 
                        (- (* x y C) (* z B)) 
                        (+ (* y B) (* x z C)) 
                  ) 
                  (list (+ (* z B) (* x y C)) 
                        (+ A (* y y C)) 
                        (- (* y z C) (* x B)) 
                  ) 
                  (list (- (* x z C) (* y B)) 
                        (+ (* x B) (* y z C)) 
                        (+ A (* z z C)) 
                  ) 
            ) 
          p (mapcar '- Cen (Mat:mxv M Cen)) 
          M (Mat:DispToMatrix M p) 
    ) 
  ) 
)

二维镜像变换

;;;-----------------------------------------------------------;;
;;; 二维镜像变换矩阵 ;;
;;; 参数: ;;
;;; p1 - 镜像向量第一点 ;;
;;; p2 - 镜像向量第二点 ;;
;;;-----------------------------------------------------------;;
;;;----------------=={ Reflect by Matrix }==------------------;;
;;; ;;
;;; Reflects a VLA-Object or Point List using a ;;
;;; Transformation Matrix ;;
;;;-----------------------------------------------------------;;
;;; Author: Lee Mac, Copyright ? 2010 - www.lee-mac.com ;;
;;;-----------------------------------------------------------;;
;;; Arguments: ;;
;;; target - VLA-Object or Point List to transform ;;
;;; p1, p2 - Points representing vector in which to reflect ;;
;;;-----------------------------------------------------------;;
(defun MAT:Reflect ( p1 p2 / a c s x y)
(setq a (angle p1 p2) a (+ a a))
(setq c (cos a) s (sin a))
(setq x (car p1) y (cadr p1))
(list
(list c s 0. (- x (+ (* c x) (* s y))))
(list s (- c) 0. (- y (- (* s x) (* c y))))
'(0. 0. 1. 0.)
'(0. 0. 0. 1.)
)
)

;;;-----------------------------------------------------------;; 
;;; 二维镜像变换矩阵                                              ;; 
;;; 参数:                                                      ;; 
;;; p1     - 镜像向量第一点                                   ;; 
;;; p2     - 镜像向量第二点                                   ;; 
;;;-----------------------------------------------------------;; 
;;;----------------=={ Reflect by Matrix }==------------------;; 
;;;                                                           ;; 
;;; Reflects a VLA-Object or Point List using a               ;; 
;;; Transformation Matrix                                     ;; 
;;;-----------------------------------------------------------;; 
;;; Author: Lee Mac, Copyright ? 2010 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;;-----------------------------------------------------------;; 
;;; Arguments:                                                ;; 
;;; target - VLA-Object or Point List to transform            ;; 
;;; p1, p2 - Points representing vector in which to reflect   ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Reflect ( p1 p2 / a c s x y) 
  (setq a (angle p1 p2) a (+ a a)) 
  (setq c (cos a) s (sin a)) 
  (setq x (car p1) y (cadr p1)) 
  (list 
    (list c    s  0. (- x (+ (* c x) (* s y)))) 
    (list s (- c) 0. (- y (- (* s x) (* c y)))) 
    '(0. 0. 1. 0.) 
    '(0. 0. 0. 1.) 
  ) 
)

三维镜像变换

;;;-----------------------------------------------------------;;
;;; 三维镜像变换矩阵 ;;
;;; 参数: ;;
;;; p1,p2,p3 - 三点定义的镜像平面 ;;
;;;-----------------------------------------------------------;;
;;;---------------=={ 3D Reflect by Matrix }==----------------;;
;;; ;;
;;; Reflection matrix ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012- ;;
;;;-----------------------------------------------------------;;
;;; Arguments: ;;
;;; p1,p2,p3 - Three 3D points defining the reflection plane ;;
;;;-----------------------------------------------------------;;
(defun MAT:Reflect3D (p1 p2 p3 / m ux uy uz)
(mapcar
'set
'(ux uy uz)
(MAT:unit (MAT:vxv (mapcar '- p2 p1) (mapcar '- p3 p1)))
)
(setq m (list (list (- 1. (* 2. ux ux)) (* -2. uy ux) (* -2. ux uz))
(list (* -2. ux uy) (- 1. (* 2. uy uy)) (* -2. uy uz))
(list (* -2. ux uz) (* -2. uy uz) (- 1. (* 2. uz uz)))
)
)
(Mat:DispToMatrix m (mapcar '- p1 (MAT:mxv m p1)))
)

;;;-----------------------------------------------------------;; 
;;; 三维镜像变换矩阵                                              ;; 
;;; 参数:                                                      ;; 
;;; p1,p2,p3 - 三点定义的镜像平面                             ;; 
;;;-----------------------------------------------------------;; 
;;;---------------=={ 3D Reflect by Matrix }==----------------;; 
;;;                                                           ;; 
;;; Reflection matrix                                         ;; 
;;;-----------------------------------------------------------;; 
;;; Author: highflybird, Copyright ? 2012-                    ;; 
;;;-----------------------------------------------------------;; 
;;; Arguments:                                                ;; 
;;; p1,p2,p3 - Three 3D points defining the reflection plane  ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Reflect3D (p1 p2 p3 / m ux uy uz) 
  (mapcar 
    'set 
    '(ux uy uz) 
    (MAT:unit (MAT:vxv (mapcar '- p2 p1) (mapcar '- p3 p1))) 
  ) 
  (setq        m (list        (list (- 1. (* 2. ux ux)) (* -2. uy ux) (* -2. ux uz)) 
                (list (* -2. ux uy) (- 1. (* 2. uy uy)) (* -2. uy uz)) 
                (list (* -2. ux uz) (* -2. uy uz) (- 1. (* 2. uz uz))) 
          ) 
  ) 
  (Mat:DispToMatrix m (mapcar '- p1 (MAT:mxv m p1))) 
)

附件中包含Lee-mac的一些算法，与我的大同小异。区别在于，我的矩阵是为大量运算准备，
Lee-mac的为单次次数不多时运用。

七、块参照，属性的变换矩阵和逆矩阵
附件

;;;-----------------------------------------------------------;;
;;; 功能：某点在块内坐标系统和世界或者用户坐标系统的转换 ;;
;;; 参数： pt 要变换的点。 ;;
;;; rlst 用 nentselp或者nentsel得到的表的最后一项 ;;
;;; from 坐标系：0,WCS; 1,当前UCS; 2,块参照坐标系RCS ;;
;;; to 坐标系：0,WCS; 1,当前UCS; 2,块参照坐标系RCS ;;
;;;-----------------------------------------------------------;;
;;; MAT: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.WCS, 1.UCS, 2.RCS ;;
;;;-----------------------------------------------------------;;
(defun MAT:TransNested (pt rlst from to / GEOM)
(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)
(MAT:RevRefGeom (car rlst))
(MAT:RefGeom (car rlst))
)
rlst (cdr rlst)
pt (mapcar '+ (MAT:mxv (car geom) pt) (cadr geom))
)
)
)
(if (= 1 to)
(trans pt 0 1)
pt
)
)
;;;-----------------------------------------------------------;;
;;; 功能：图块的变换矩阵 ;;
;;; 输入：块参照的图元名 ;;
;;; 输出：块参照的变换矩阵 ;;
;;;-----------------------------------------------------------;;
;;; MAT: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 MAT:RefGeom (ename / elst ang norm mat)
(setq elst (entget ename)
ang (cdr (assoc 50 elst))
norm (cdr (assoc 210 elst))
)
(list
(setq mat
(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))
)
(MAT: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)))
)
)
)
)
(mapcar
'-
(trans (cdr (assoc 10 elst)) norm 0)
(MAT:mxv mat
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))
)
)
)
)
;;;-----------------------------------------------------------;;
;;; 功能：图块的变换矩阵的逆矩阵 ;;
;;;-----------------------------------------------------------;;
;;; MAT:RevRefGeom (gile) ;;
;;; MAT:RefGeom inverse function ;;
;;; 输入：块参照的图元名 ;;
;;; 输出：块参照的变换矩阵的逆矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:RevRefGeom (ename / entData ang norm mat)
(setq entData (entget ename)
ang (- (cdr (assoc 50 entData)))
norm (cdr (assoc 210 entData))
)
(list
(setq mat
(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))))
)
(MAT: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)))))
(MAT:mxv mat (trans (cdr (assoc 10 entData)) norm 0))
)
)
)
;;;-----------------------------------------------------------;;
;;; 属性的变换矩阵Attrib Transformation Matrix. -highflybird ;;
;;; 输入：Ename 属性的图元名 ;;
;;; 输出：属性的变换矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:AttGeom (ename / ang norm mat elst)
(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))
)
(list (list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
)
)
(trans (cdr (assoc 10 elst)) norm 0)
)
)

;;;-----------------------------------------------------------;; 
;;; 功能： 某点在块内坐标系统和世界或者用户坐标系统的转换     ;; 
;;; 参数： pt 要变换的点。                                    ;; 
;;;        rlst 用 nentselp或者nentsel得到的表的最后一项      ;; 
;;;        from  坐标系：0,WCS; 1,当前UCS; 2,块参照坐标系RCS  ;; 
;;;        to    坐标系：0,WCS; 1,当前UCS; 2,块参照坐标系RCS  ;; 
;;;-----------------------------------------------------------;; 
;;; MAT: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.WCS, 1.UCS, 2.RCS     ;; 
;;;-----------------------------------------------------------;; 
 
(defun MAT:TransNested (pt rlst from to / GEOM) 
  (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) 
                      (MAT:RevRefGeom (car rlst)) 
                      (MAT:RefGeom (car rlst)) 
                    ) 
               rlst (cdr rlst) 
               pt   (mapcar '+ (MAT:mxv (car geom) pt) (cadr geom)) 
        ) 
       ) 
  ) 
  (if (= 1 to) 
    (trans pt 0 1) 
    pt 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 功能：图块的变换矩阵                                      ;; 
;;; 输入：块参照的图元名                                      ;; 
;;; 输出：块参照的变换矩阵                                    ;; 
;;;-----------------------------------------------------------;; 
;;; MAT: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 MAT:RefGeom (ename / elst ang norm mat) 
  (setq        elst (entget ename) 
        ang  (cdr (assoc 50 elst)) 
        norm (cdr (assoc 210 elst)) 
  ) 
  (list 
    (setq mat 
           (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)) 
             ) 
             (MAT: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))) 
               ) 
             ) 
           ) 
    ) 
    (mapcar 
      '- 
      (trans (cdr (assoc 10 elst)) norm 0) 
      (MAT:mxv mat 
           (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst))))) 
      ) 
    ) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 功能：图块的变换矩阵的逆矩阵                              ;; 
;;;-----------------------------------------------------------;; 
;;; MAT:RevRefGeom (gile)                                      ;; 
;;; MAT:RefGeom inverse function                              ;; 
;;; 输入：块参照的图元名                                      ;; 
;;; 输出：块参照的变换矩阵的逆矩阵                            ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:RevRefGeom (ename / entData ang norm mat) 
  (setq        entData        (entget ename) 
        ang        (- (cdr (assoc 50 entData))) 
        norm        (cdr (assoc 210 entData)) 
  ) 
  (list 
    (setq mat 
           (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)))) 
             ) 
             (MAT: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))))) 
            (MAT:mxv mat (trans (cdr (assoc 10 entData)) norm 0)) 
    ) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 属性的变换矩阵Attrib Transformation Matrix.        -highflybird  ;; 
;;; 输入：Ename 属性的图元名                                  ;; 
;;; 输出：属性的变换矩阵                                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:AttGeom (ename / ang norm mat elst) 
  (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)) 
             ) 
             (list (list (cos ang) (- (sin ang)) 0.0) 
                   (list (sin ang) (cos ang) 0.0) 
                   '(0.0 0.0 1.0) 
             ) 
           ) 
    ) 
    (trans (cdr (assoc 10 elst)) norm 0) 
  ) 
)

八、三点变换矩阵，UCS变换矩阵，图元变换矩阵和通用变换矩阵

;;;-----------------------------------------------------------;;
;;; Append displacement vector to a matrix -Highflybird- ;;
;;; 把位移矢量添加到矩阵中 ;;
;;; 输入：mat -- 矩阵(3x3)，disp -- 位移矢量 ;;
;;; 输出：一个4X4的变换CAD的标准变换矩阵 ;;
;;;-----------------------------------------------------------;;
(defun Mat:DispToMatrix (mat disp)
(append
(mapcar 'append mat (mapcar 'list disp))
'((0. 0. 0. 1.))
)
)
;;;-----------------------------------------------------------;;
;;; 从一个坐标系统到另一个坐标系统的变换矩阵 ;;
;;; 输入：from - 源坐标系；to - 目的坐标系 ;;
;;; 输出：一个4X4的变换CAD的标准变换矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Trans (from to)
(Mat:DispToMatrix
(mapcar
(function (lambda (v) (trans v from to t)))
'((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
)
(trans '(0 0 0) to from)
)
)
;;;-----------------------------------------------------------;;
;;; wcs到ucs矩阵，也可称UCS的变换矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:w2u () (MAT:Trans 0 1))
;;;-----------------------------------------------------------;;
;;; ucs到wcs矩阵，也可称UCS的逆变换矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:u2w () (MAT:Trans 1 0))
;;;-----------------------------------------------------------;;
;;; 通用变换矩阵 by highflybird ;;
;;; 输入：from - 原坐标系， ;;
;;; to - 目的坐标系， ;;
;;; Org - 目的坐标系的原点相对原坐标系的位置 ;;
;;; Ang - 相对于原坐标系的旋转角度 ;;
;;; 输出：两个矩阵，一个是从原坐标系变换到目的坐标系的变换矩阵;;
;;; 一个是从目的坐标系变换到原坐标系的变换矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:Trans1 (from to Org Ang / Mat Rot Inv Cen)
(setq Mat (mapcar (function (lambda (v) (trans v from to T)))
'((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
)
)
(if (not (equal ang 0 1e-14))
(setq Rot (list (list (cos ang) (- (sin ang)) 0.)
(list (sin ang) (cos ang) 0.)
(list 0. 0. 1.)
)
mat (MAT:mxm mat Rot)
)
)
(setq Cen (trans Org to from))
(setq Inv (mat:trp mat))
(list
(Mat:DispToMatrix Inv (mat:mxv Inv (mapcar '- Cen))) ;from->to (trans pt from to)
(Mat:DispToMatrix mat Cen) ;to->from (trans pt to from)
)
)
;;;-----------------------------------------------------------;;
;;; 通过两个坐标轴和坐标原点定义的变换矩阵 -by highflybird ;;
;;; 输入：Org - 坐标系原点， ;;
;;; Vx - 坐标系X 方向， ;;
;;; Vy - 坐标系y 方向 ;;
;;; 输出：两个矩阵，一个是该坐标系的变换矩阵，一个是其逆矩阵 ;;
;;;-----------------------------------------------------------;;
(defun MAT:2VMatrix (Org Vx Vy / Vz Rot)
(if (or (equal Vx '(0 0 0) 1e-14) (equal Vy '(0 0 0) 1e-14))
'((1. 0. 0. 0.) (0. 1. 0. 0.) (0. 0. 1. 0.) (0. 0. 0. 1.))
(progn
(setq Vx (Mat:Unit Vx)) ;X Axis
(setq Vy (Mat:Unit Vy)) ;Y Axis
(setq Vz (Mat:unit (MAT:vxv Vx Vy))) ;Z Axis
(setq Vy (Mat:unit (MAT:vxv Vz Vx))) ;Y Axis
(setq Rot (list Vx Vy Vz)) ;Rotation matrix
(list ;Inverse Rotation matrix
(Mat:DispToMatrix (MAT:trp Rot) Org) ;The transformation matrix from UCS to WCS
(Mat:DispToMatrix Rot (MAT:mxv Rot (mapcar '- Org))) ;The transformation matrix from WCS to UCS
)
)
)
)
;;;-----------------------------------------------------------;;
;;; Mat:3PMatrix -Highflybird- ;;
;;; 通过两个坐标轴和坐标原点定义的变换矩阵 -by highflybird ;;
;;; 输入：P1 - 坐标系原点， ;;
;;; P2 - 坐标系的第2点 ;;
;;; P3 - 坐标系的第3点 ;;
;;; 输出：两个矩阵，一个是该坐标系的变换矩阵，一个是其逆矩阵 ;;
;;;-----------------------------------------------------------;;
(defun Mat:3PMatrix (p1 p2 p3 / v1 v2 v3)
(MAT:2VMatrix P1 (mapcar '- p2 p1) (mapcar '- p3 p1))
)
;;;-----------------------------------------------------------;;
;;; 平齐实体的变换矩阵 -by highflybird ;;
;;; 输入：Ent - 实体名 ;;
;;; 输出：平齐这个实体的变换矩阵和它的逆矩阵 ;;
;;;-----------------------------------------------------------;;
(defun Mat:EntityMatrix (Ent / z dxf Cen obj an m1 mat Inv org)
(setq dxf (entget ent))
(if (setq Cen (cdr (assoc 10 dxf))) ;Insertpoint,center or startpoint,etc.
(if (null (caddr Cen))
(setq Cen (append Cen '(0.0)))
)
(setq Cen '(0 0 0))
)
(setq obj (vlax-ename->vla-object Ent))
(if (and (vlax-property-available-p obj 'elevation) ;If it has elevation value.
(wcmatch (vla-get-objectname obj) "*Polyline") ;It's a "AcDb2dPolyline" or "AcDbPolyline" object
)
(setq z (vla-get-elevation obj)
Cen (list (car Cen) (cadr Cen) (+ (caddr Cen) z)) ;add elevation value
)
)
(if (vlax-property-available-p obj 'rotation) ;if it has a rotaion angle
(setq an (vla-get-rotation obj))
(setq an 0)
)
(MAT:Trans1 0 Ent Cen an) ;return two matrices, the first is WCS->OCS,the second is OCS->WCS
)

;;;-----------------------------------------------------------;; 
;;; Append displacement vector to a matrix         -Highflybird- ;; 
;;; 把位移矢量添加到矩阵中                                    ;; 
;;; 输入：mat -- 矩阵(3x3)，disp -- 位移矢量                  ;; 
;;; 输出：一个4X4的变换CAD的标准变换矩阵                      ;; 
;;;-----------------------------------------------------------;; 
(defun Mat:DispToMatrix        (mat disp) 
  (append 
    (mapcar 'append mat (mapcar 'list disp)) 
    '((0. 0. 0. 1.)) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 从一个坐标系统到另一个坐标系统的变换矩阵                  ;; 
;;; 输入：from - 源坐标系；to - 目的坐标系                    ;; 
;;; 输出：一个4X4的变换CAD的标准变换矩阵                      ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Trans (from to) 
  (Mat:DispToMatrix 
    (mapcar 
      (function (lambda (v) (trans v from to t))) 
      '((1. 0. 0.) (0. 1. 0.) (0. 0. 1.)) 
    ) 
    (trans '(0 0 0) to from) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; wcs到ucs矩阵，也可称UCS的变换矩阵                               ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:w2u () (MAT:Trans 0 1)) 
 
;;;-----------------------------------------------------------;; 
;;; ucs到wcs矩阵，也可称UCS的逆变换矩阵                       ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:u2w () (MAT:Trans 1 0)) 
 
;;;-----------------------------------------------------------;; 
;;; 通用变换矩阵 by highflybird                                      ;; 
;;; 输入：from - 原坐标系，                                   ;; 
;;;       to   - 目的坐标系，                                 ;; 
;;;       Org  - 目的坐标系的原点相对原坐标系的位置           ;; 
;;;       Ang  - 相对于原坐标系的旋转角度                     ;; 
;;; 输出：两个矩阵，一个是从原坐标系变换到目的坐标系的变换矩阵;; 
;;;       一个是从目的坐标系变换到原坐标系的变换矩阵          ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:Trans1 (from to Org Ang / Mat Rot Inv Cen) 
  (setq Mat (mapcar (function (lambda (v) (trans v from to T))) 
                    '((1. 0. 0.) (0. 1. 0.) (0. 0. 1.)) 
            ) 
  ) 
  (if (not (equal ang 0 1e-14)) 
    (setq Rot (list (list (cos ang) (- (sin ang)) 0.) 
                    (list (sin ang) (cos ang) 0.) 
                    (list 0. 0. 1.) 
              ) 
          mat (MAT:mxm mat Rot) 
    ) 
  ) 
  (setq Cen (trans Org to from)) 
  (setq Inv (mat:trp mat)) 
  (list 
    (Mat:DispToMatrix Inv (mat:mxv Inv (mapcar '- Cen)))        ;from->to (trans pt from to) 
    (Mat:DispToMatrix mat Cen)                                         ;to->from (trans pt to from) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 通过两个坐标轴和坐标原点定义的变换矩阵  -by highflybird   ;; 
;;; 输入：Org  - 坐标系原点，                                 ;; 
;;;       Vx   - 坐标系X 方向，                               ;; 
;;;       Vy   - 坐标系y 方向                                 ;; 
;;; 输出：两个矩阵，一个是该坐标系的变换矩阵，一个是其逆矩阵  ;; 
;;;-----------------------------------------------------------;; 
(defun MAT:2VMatrix (Org Vx Vy / Vz Rot) 
  (if (or (equal Vx '(0 0 0) 1e-14) (equal Vy '(0 0 0) 1e-14)) 
    '((1. 0. 0. 0.) (0. 1. 0. 0.) (0. 0. 1. 0.) (0. 0. 0. 1.)) 
    (progn 
      (setq Vx        (Mat:Unit Vx))                                         ;X Axis 
      (setq Vy        (Mat:Unit Vy))                                        ;Y Axis 
      (setq Vz        (Mat:unit (MAT:vxv Vx Vy)))                         ;Z Axis 
      (setq Vy        (Mat:unit (MAT:vxv Vz Vx)))                         ;Y Axis 
      (setq Rot (list Vx Vy Vz))                                 ;Rotation matrix 
      (list                                                         ;Inverse Rotation matrix 
        (Mat:DispToMatrix (MAT:trp Rot) Org)                        ;The transformation matrix from UCS to WCS 
        (Mat:DispToMatrix Rot (MAT:mxv Rot (mapcar '- Org)))        ;The transformation matrix from WCS to UCS 
      ) 
    ) 
  ) 
) 
 
;;;-----------------------------------------------------------;; 
;;; Mat:3PMatrix  -Highflybird-                               ;; 
;;; 通过两个坐标轴和坐标原点定义的变换矩阵  -by highflybird   ;; 
;;; 输入：P1 - 坐标系原点，                                   ;; 
;;;       P2 - 坐标系的第2点                                  ;; 
;;;       P3 - 坐标系的第3点                                  ;; 
;;; 输出：两个矩阵，一个是该坐标系的变换矩阵，一个是其逆矩阵  ;; 
;;;-----------------------------------------------------------;; 
(defun Mat:3PMatrix (p1 p2 p3 / v1 v2 v3) 
  (MAT:2VMatrix P1 (mapcar '- p2 p1) (mapcar '- p3 p1)) 
) 
 
;;;-----------------------------------------------------------;; 
;;; 平齐实体的变换矩阵  -by highflybird                              ;; 
;;; 输入：Ent - 实体名                                        ;; 
;;; 输出：平齐这个实体的变换矩阵和它的逆矩阵                  ;; 
;;;-----------------------------------------------------------;; 
(defun Mat:EntityMatrix (Ent / z dxf Cen obj an m1 mat Inv org) 
  (setq dxf (entget ent)) 
  (if (setq Cen (cdr (assoc 10 dxf)))                                ;Insertpoint,center or startpoint,etc. 
    (if (null (caddr Cen)) 
      (setq Cen (append Cen '(0.0))) 
    ) 
    (setq Cen '(0 0 0)) 
  ) 
  (setq obj (vlax-ename->vla-object Ent))                         
  (if (and (vlax-property-available-p obj 'elevation)                ;If it has elevation value. 
           (wcmatch (vla-get-objectname obj) "*Polyline")        ;It's a "AcDb2dPolyline" or "AcDbPolyline" object 
      ) 
    (setq z   (vla-get-elevation obj) 
          Cen (list (car Cen) (cadr Cen) (+ (caddr Cen) z))        ;add elevation value 
    ) 
  ) 
  (if (vlax-property-available-p obj 'rotation)                 ;if it has a rotaion angle 
    (setq an (vla-get-rotation obj)) 
    (setq an 0) 
  ) 
  (MAT:Trans1 0 Ent Cen an)                                         ;return two matrices, the first is WCS->OCS,the second is OCS->WCS 
)

九、轴测变换矩阵

;;;-----------------------------------------------------------;;
;;;通用的轴测变换矩阵 highflybird 2012.12 ;;
;;;Axonometric projections Rotation matrices ;;
;;;Isometric projection: a = (/ pi 4),b = (atan (- (sqrt 2))) ;;
;;;Input: a - Rotation angle about the vertical axis ;;
;;; b - Rotation angle about the horizontal axis ;;
;;;Output: transforamtion matrix of this projection ;;
;;;-----------------------------------------------------------;;
(defun MAT:ISO (a b / ca sa cb sb)
(setq ca (cos a))
(setq sa (sin a))
(setq cb (cos b))
(setq sb (sin b))
(list (list ca (- sa) 0 0)
(list (* sa cb) (* ca cb) (- sb) 0)
(list (* sa sb) (* ca sb) cb 0)
(list 0 0 0 1)
)
)

演示：

十、矩阵的特征值和特征向量
chlh_jd讨论比较深入，参见如下链接：
http://bbs.mjtd.com/thread-99908-1-1.html
http://www.theswamp.org/index.php?topic=43453.0

十一、矩阵的分解、求逆和解方程组
http://www.theswamp.org/index.php?topic=32478.0
http://www.theswamp.org/index.php?topic=22638.msg439381#msg439381
http://www.theswamp.org/index.php?topic=13505.msg163485#msg163485

关于上面的几个链接地址的源代码已经录入下面的附件中了。

夏生生 · 发表于 2021-12-12 21:06:52

高版主，如您有空，可否至http://bbs.mjtd.com/thread-184557-1-1.html稍作指导？是矩阵转换问题，谢谢您。

电赛加油 · 发表于 2020-8-22 23:14:32

感谢大神分享，学习一下！

yjr111 · 发表于 2013-1-4 19:52:00

沙发，慢慢看

hao3ren · 发表于 2013-1-4 20:13:08

这玩意，有难度，看不懂

qjcpj · 发表于 2013-1-4 20:18:09

楼主真乃高人也。

自贡黄明儒 · 发表于 2013-1-4 20:28:59

忘了这么久的线性代数，捡回来不容易，顶顶算了

tth02 · 发表于 2013-1-4 20:36:56

非常好的帖子，楼主强大。

cable2004 · 发表于 2013-1-4 22:05:56

一定要顶的！

xiabin68 · 发表于 2013-1-4 22:32:23

这个一定要顶起来，，，

gzxl · 发表于 2013-1-4 22:46:05

对，一定要顶，高版真乃神人

留个迹在这，日后已便查看学习

kwok · 发表于 2013-1-4 22:53:57

好多,有得看学习了.

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

[【高飞鸟】] 【越飞越高讲堂15】用LISP论矩阵

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

点评