lisp中有没有矩阵运算函数

wanghangshun · 发表于 2009-8-11 14:06:00

请哪位大侠指点，lisp中有没有有关矩阵运算的函数?

ZZXXQQ · 发表于 2009-8-11 19:44:00

2000以后版的VLISP有此功能。看vlax-make-safearray函数。

wanghangshun · 发表于 2009-8-12 13:15:00

可是没有找到像两个矩阵相加或相乘的函数

TANER · 发表于 2009-8-12 13:32:00

theswamp上找到的代码，不记得具体链接了。

;;; gile-trp transpose a matrix -doug wilson-
(defun gile-trp (m)
(apply
'mapcar
(cons 'list m)
)
)
;;; gile-cofact (gile)
;;; returns the gile-cofactor associated to ij item of a matrix
;;;
;;; arguments
;;; i = row index (first row = 1)
;;; j = column index (first column = 1)
;;; m = a matrix
(defun gile-cofact (i j m)
(* (gile-determ (th-remove-nth (1- i) (mapcar
(function (lambda (x)
(th-remove-nth
(1- j)
x
)
)
)
m
)
)
) (expt -1 (+ i j))
)
)
;;; gile-determ (gile)
;;; returns the déterminant of a matrix
;;;
;;; argument : a matrix
(defun gile-determ (m)
(if (= 2 (length m))
(- (* (caar m) (cadadr m)) (* (caadr m) (cadar m)))
((lambda (r n)
(apply
'+
(mapcar
(function (lambda (x)
(* x (gile-cofact 1 (setq n (1+ n))
m
)
)
)
)
r
)
)
)
(car m)
0
)
)
)
;;; gile-adj-mat (gile)
;;; returns the adjugate matrix
;;;
;;; argument : a matrix
(defun gile-adj-mat (m / i)
(setq i 0)
(gile-trp (mapcar
(function (lambda (v / j)
(setq i (1+ i)
j 0
)
(mapcar
(function (lambda (x)
(gile-cofact i (setq j (1+ j))
m
)
)
)
v
)
)
)
m
)
)
)
;;; gile-inv-mat (gile)
;;; inverse a matrix
;;;
;;; argument : a matrix
(defun gile-inv-mat (m / d)
(if (/= 0 (setq d (gile-determ m)))
(mapcar
(function (lambda (v)
(mapcar
(function (lambda (x)
(* (/ 1 d) x)
)
)
v
)
)
)
(gile-adj-mat m)
)
)
)
;;; gile-vxv returns the dot product of 2 vectors
(defun gile-vxv (v1 v2)
(apply
'+
(mapcar
'*
v1
v2
)
)
)
;;; gile-trp transpose a matrix -doug wilson-
(defun gile-trp (m)
(apply
'mapcar
(cons 'list m)
)
)
;;; gile-mxv apply a transformation matrix to a vector -vladimir
;;; nesterovsky-
(defun gile-mxv (m v)
(mapcar
'(lambda (r)
(gile-vxv r v)
)
m
)
)
;;; gile-mxm multiply two matrices -vladimir nesterovsky-
(defun gile-mxm (m q)
(mapcar
'(lambda (r)
(gile-mxv (gile-trp q) r)
)
m
)
)
;;; gile-wcs2rcs (gile)
;;; translates coordinates from wcs to reference (block or xref) coordinate
;;; system
;;; pt : a point in wcs
;;; mat : a transformation matrix as those returned either by (nentsel) or
;;; (nentselp)
(defun gile-wcs2rcs (pt mat)
(setq pt (trans pt 0 0))
(if (= 3 (length (car mat)))
(setq mat (append
(gile-trp mat)
(list '(0.0 0.0 0.0 1.0))
)
)
)
(setq mat (gile-inv-mat mat))
(mapcar
'+
(gile-mxv mat pt)
(th-butlast (mapcar
'last
mat
)
)
)
)
;;; gile-rcs2wcs (gile)
;;; translates coordinates from reference (block or xref) coordinate system
;;; to wcs
;;; arguments :
;;; pt : a point in rcs, got by (cdr (assoc 10 (entget (car (nentsel)))))
;;; i.e.
;;; mat : a transformation matrix as those returned either by (nentsel) or
;;; (nentselp)
(defun gile-rcs2wcs (pt mat)
(if (= 3 (length (car mat)))
(mapcar
'+
(gile-mxv (gile-trp (th-butlast mat)) pt)
(last mat)
)
(mapcar
'+
(gile-mxv (mapcar
'th-butlast
(th-butlast mat)
) pt
)
(th-butlast (mapcar
'last
mat
)
)
)
)
)
;;; gile-inverse-matrix (gile) 2009/03/17
;;; uses the gauss-jordan elimination method to calculate the inverse
;;; matrix of any dimension square matrix
;;;
;;; argument : a square matrix
;;; return : the inverse matrix (or nil if singular)
(defun gile-inverse-matrix (mat / col piv row res)
(setq mat (mapcar
'(lambda (x1 x2)
(append
x1
x2
)
)
mat
(gile-imat (length mat))
)
)
(while mat
(setq col (mapcar
'(lambda (x)
(abs (car x))
)
mat
)
)
(repeat (vl-position (apply
'max
col
) col
)
(setq mat (append
(cdr mat)
(list (car mat))
)
)
)
(if (equal (setq piv (caar mat))
0.0 1e-14
)
(setq mat nil
res nil
)
(setq piv (/ 1.0 piv)
row (mapcar
'(lambda (x)
(* x piv)
)
(car mat)
)
mat (mapcar
'(lambda (r / e)
(setq e (car r))
(cdr (mapcar
'(lambda (x n)
(- x (* n e))
)
r
row
)
)
)
(cdr mat)
)
res (cons (cdr row) (mapcar
'(lambda (r / e)
(setq e (car r))
(cdr (mapcar
'(lambda (x n)
(- x (* n e))
)
r
row
)
)
)
res
)
)
)
)
)
(reverse res)
)
;;; gile-imat (gile)
;;; returns the specified dimension identity matrix
;;;
;;; argument
;;; d : the matrix dimension (positive integer)
(defun gile-imat (d / i n r m)
(setq i d)
(while (<= 0 (setq i (1- i)))
(setq n d
r nil
)
(while (<= 0 (setq n (1- n)))
(setq r (cons (if (= i n)
1.0
0.0
) r
)
)
)
(setq m (cons r m))
)
)

;;; gile-trp transpose a matrix -doug wilson-
(defun gile-trp (m)
  (apply
    'mapcar
    (cons 'list m)
  )
)
;;; gile-cofact (gile)
;;; returns the gile-cofactor associated to ij item of a matrix
;;;
;;; arguments
;;; i = row index (first row = 1)
;;; j = column index (first column = 1)
;;; m = a matrix
(defun gile-cofact (i j m)
  (* (gile-determ (th-remove-nth (1- i) (mapcar
       (function (lambda (x)
            (th-remove-nth
             (1- j)
             x
            )
          )
       )
       m
     )
    )
     ) (expt -1 (+ i j))
  )
)
;;; gile-determ (gile)
;;; returns the déterminant of a matrix
;;;
;;; argument : a matrix
(defun gile-determ (m)
  (if (= 2 (length m))
    (- (* (caar m) (cadadr m)) (* (caadr m) (cadar m)))
    ((lambda (r n)
       (apply
  '+
  (mapcar
    (function (lambda (x)
         (* x (gile-cofact 1 (setq n (1+ n))
      m
       )
         )
       )
    )
    r
  )
       )
     )
     (car m)
     0
    )
  )
)
;;; gile-adj-mat (gile)
;;; returns the adjugate matrix
;;;
;;; argument : a matrix
(defun gile-adj-mat (m / i)
  (setq i 0)
  (gile-trp (mapcar
       (function (lambda (v / j)
     (setq i (1+ i)
    j 0
     )
     (mapcar
       (function (lambda (x)
     (gile-cofact i (setq j (1+ j))
           m
     )
          )
       )
       v
     )
   )
       )
       m
     )
  )
)
;;; gile-inv-mat (gile)
;;; inverse a matrix
;;;
;;; argument : a matrix
(defun gile-inv-mat (m / d)
  (if (/= 0 (setq d (gile-determ m)))
    (mapcar
      (function (lambda (v)
    (mapcar
      (function (lambda (x)
    (* (/ 1 d) x)
         )
      )
      v
    )
  )
      )
      (gile-adj-mat m)
    )
  )
)
;;; gile-vxv returns the dot product of 2 vectors
(defun gile-vxv (v1 v2)
  (apply
    '+
    (mapcar
      '*
      v1
      v2
    )
  )
)
;;; gile-trp transpose a matrix -doug wilson-
(defun gile-trp (m)
  (apply
    'mapcar
    (cons 'list m)
  )
)
;;; gile-mxv apply a transformation matrix to a vector -vladimir
;;; nesterovsky-
(defun gile-mxv (m v)
  (mapcar
    '(lambda (r)
       (gile-vxv r v)
     )
    m
  )
)
;;; gile-mxm multiply two matrices -vladimir nesterovsky-
(defun gile-mxm (m q)
  (mapcar
    '(lambda (r)
       (gile-mxv (gile-trp q) r)
     )
    m
  )
)
;;; gile-wcs2rcs (gile)
;;; translates coordinates from wcs to reference (block or xref) coordinate
;;; system
;;; pt : a point in wcs
;;; mat : a transformation matrix as those returned either by (nentsel) or
;;; (nentselp)
(defun gile-wcs2rcs (pt mat)
  (setq pt (trans pt 0 0))
  (if (= 3 (length (car mat)))
    (setq mat (append
  (gile-trp mat)
  (list '(0.0 0.0 0.0 1.0))
       )
    )
  )
  (setq mat (gile-inv-mat mat))
  (mapcar
    '+
    (gile-mxv mat pt)
    (th-butlast (mapcar
    'last
    mat
  )
    )
  )
)
;;; gile-rcs2wcs (gile)
;;; translates coordinates from reference (block or xref) coordinate system
;;; to wcs
;;; arguments :
;;; pt : a point in rcs, got by (cdr (assoc 10 (entget (car (nentsel)))))
;;; i.e.
;;; mat : a transformation matrix as those returned either by (nentsel) or
;;; (nentselp)
(defun gile-rcs2wcs (pt mat)
  (if (= 3 (length (car mat)))
    (mapcar
      '+
      (gile-mxv (gile-trp (th-butlast mat)) pt)
      (last mat)
    )
    (mapcar
      '+
      (gile-mxv (mapcar
    'th-butlast
    (th-butlast mat)
  ) pt
      )
      (th-butlast (mapcar
      'last
      mat
    )
      )
    )
  )
)
;;; gile-inverse-matrix (gile) 2009/03/17
;;; uses the gauss-jordan elimination method to calculate the inverse
;;; matrix of any dimension square matrix
;;;
;;; argument : a square matrix
;;; return : the inverse matrix (or nil if singular)
(defun gile-inverse-matrix (mat / col piv row res)
  (setq mat (mapcar
       '(lambda (x1 x2)
   (append
     x1
     x2
   )
        )
       mat
       (gile-imat (length mat))
     )
  )
  (while mat
    (setq col (mapcar
  '(lambda (x)
     (abs (car x))
   )
  mat
       )
    )
    (repeat (vl-position (apply
      'max
      col
    ) col
     )
      (setq mat (append
    (cdr mat)
    (list (car mat))
  )
      )
    )
    (if (equal (setq piv (caar mat))
        0.0 1e-14
 )
      (setq mat nil
     res nil
      )
      (setq piv (/ 1.0 piv)
     row (mapcar
    '(lambda (x)
       (* x piv)
     )
    (car mat)
  )
     mat (mapcar
    '(lambda (r / e)
       (setq e (car r))
       (cdr (mapcar
       '(lambda (x n)
          (- x (* n e))
        )
       r
       row
     )
       )
     )
    (cdr mat)
  )
     res (cons (cdr row) (mapcar
      '(lambda (r / e)
         (setq e (car r))
         (cdr (mapcar
         '(lambda (x n)
            (- x (* n e))
          )
         r
         row
       )
         )
       )
      res
    )
  )
      )
    )
  )
  (reverse res)
)
;;; gile-imat (gile)
;;; returns the specified dimension identity matrix
;;;
;;; argument
;;; d : the matrix dimension (positive integer)
(defun gile-imat (d / i n r m)
  (setq i d)
  (while (<= 0 (setq i (1- i)))
    (setq n d
   r nil
    )
    (while (<= 0 (setq n (1- n)))
      (setq r (cons (if (= i n)
        1.0
        0.0
      ) r
       )
      )
    )
    (setq m (cons r m))
  )
)

yifeng520131 · 发表于 2009-8-13 22:07:00

新手菜鸟来着先学习下哈~!

5061220 · 发表于 2009-8-14 08:09:00

共同学习！

wanghangshun · 发表于 2009-8-20 13:43:00

研究过了，非常感谢各位

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