lisp中有没有矩阵运算函数
<p>请哪位大侠指点，lisp中有没有有关矩阵运算的函数?</p> <p>2000以后版的VLISP有此功能。看vlax-make-safearray函数。</p> 可是没有找到像两个矩阵相加或相乘的函数 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))
)
) 新手菜鸟来着先学习下哈~! <p>共同学习！</p> 研究过了，非常感谢各位
页:
[1]