mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-29 07:58:28 +00:00
Code Issues Releases Activity
1c4900d953
emacs/lisp/calc/calc-mtx.el

382 lines
11 KiB
EmacsLisp
Raw Normal View History

Change all toplevel `setq' forms to `defvar' forms, and move them before their first use. Use `when', `unless'. Remove trailing periods from error forms. Add description and headers suggested by Emacs Lisp coding conventions.
2001-11-19 07:44:56 +00:00
;;; calc-mtx.el --- matrix functions for Calc
Update copyright year to 2015 Run admin/update-copyright.
2015-01-01 17:18:06 +00:00
;; Copyright (C) 1990-1993, 2001-2015 Free Software Foundation, Inc.
Change all toplevel `setq' forms to `defvar' forms, and move them before their first use. Use `when', `unless'. Remove trailing periods from error forms. Add description and headers suggested by Emacs Lisp coding conventions.
2001-11-19 07:44:56 +00:00
;; Author: David Gillespie <daveg@synaptics.com>
Update maintainer's address.
2007-04-23 21:30:42 +00:00
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;; This file is part of GNU Emacs.
Switch to recommended form of GPLv3 permissions notice.
2008-05-06 03:16:00 +00:00
;; GNU Emacs is free software: you can redistribute it and/or modify
Change form of license text to match rest of Emacs.
2007-03-19 20:59:53 +00:00
;; it under the terms of the GNU General Public License as published by
Switch to recommended form of GPLv3 permissions notice.
2008-05-06 03:16:00 +00:00
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Change form of license text to match rest of Emacs.
2007-03-19 20:59:53 +00:00
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;; GNU Emacs is distributed in the hope that it will be useful,
Change form of license text to match rest of Emacs.
2007-03-19 20:59:53 +00:00
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
Switch to recommended form of GPLv3 permissions notice.
2008-05-06 03:16:00 +00:00
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
Change all toplevel `setq' forms to `defvar' forms, and move them before their first use. Use `when', `unless'. Remove trailing periods from error forms. Add description and headers suggested by Emacs Lisp coding conventions.
2001-11-19 07:44:56 +00:00
;;; Commentary:
;;; Code:
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;; This file is autoloaded from calc-ext.el.
Add a provide statement. (calc-Need-calc-mat): Remove it.
2004-11-30 17:19:02 +00:00
(require 'calc-ext)
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(require 'calc-macs)
(defun calc-mdet (arg)
(interactive "P")
(calc-slow-wrapper
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(calc-unary-op "mdet" 'calcFunc-det arg)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun calc-mtrace (arg)
(interactive "P")
(calc-slow-wrapper
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(calc-unary-op "mtr" 'calcFunc-tr arg)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun calc-mlud (arg)
(interactive "P")
(calc-slow-wrapper
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(calc-unary-op "mlud" 'calcFunc-lud arg)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;;; Coerce row vector A to be a matrix. [V V]
(defun math-row-matrix (a)
(if (and (Math-vectorp a)
(not (math-matrixp a)))
(list 'vec a)
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
a))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;;; Coerce column vector A to be a matrix. [V V]
(defun math-col-matrix (a)
(if (and (Math-vectorp a)
(not (math-matrixp a)))
(cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
a))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;;; Multiply matrices A and B. [V V V]
(defun math-mul-mats (a b)
(let ((mat nil)
(cols (length (nth 1 b)))
row col ap bp accum)
(while (setq a (cdr a))
(setq col cols
row nil)
(while (> (setq col (1- col)) 0)
(setq ap (cdr (car a))
bp (cdr b)
accum (math-mul (car ap) (nth col (car bp))))
(while (setq ap (cdr ap) bp (cdr bp))
(setq accum (math-add accum (math-mul (car ap) (nth col (car bp))))))
(setq row (cons accum row)))
(setq mat (cons (cons 'vec row) mat)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(cons 'vec (nreverse mat))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-mul-mat-vec (a b)
(cons 'vec (mapcar (function (lambda (row)
(math-dot-product row b)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(cdr a))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun calcFunc-tr (mat) ; [Public]
(if (math-square-matrixp mat)
(math-matrix-trace-step 2 (1- (length mat)) mat (nth 1 (nth 1 mat)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(math-reject-arg mat 'square-matrixp)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-matrix-trace-step (n size mat sum)
(if (<= n size)
(math-matrix-trace-step (1+ n) size mat
(math-add sum (nth n (nth n mat))))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
sum))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;;; Matrix inverse and determinant.
(defun math-matrix-inv-raw (m)
(let ((n (1- (length m))))
(if (<= n 3)
(let ((det (math-det-raw m)))
(and (not (math-zerop det))
(math-div
(cond ((= n 1) 1)
((= n 2)
(list 'vec
(list 'vec
(nth 2 (nth 2 m))
(math-neg (nth 2 (nth 1 m))))
(list 'vec
(math-neg (nth 1 (nth 2 m)))
(nth 1 (nth 1 m)))))
((= n 3)
(list 'vec
(list 'vec
(math-sub (math-mul (nth 3 (nth 3 m))
(nth 2 (nth 2 m)))
(math-mul (nth 3 (nth 2 m))
(nth 2 (nth 3 m))))
(math-sub (math-mul (nth 3 (nth 1 m))
(nth 2 (nth 3 m)))
(math-mul (nth 3 (nth 3 m))
(nth 2 (nth 1 m))))
(math-sub (math-mul (nth 3 (nth 2 m))
(nth 2 (nth 1 m)))
(math-mul (nth 3 (nth 1 m))
(nth 2 (nth 2 m)))))
(list 'vec
(math-sub (math-mul (nth 3 (nth 2 m))
(nth 1 (nth 3 m)))
(math-mul (nth 3 (nth 3 m))
(nth 1 (nth 2 m))))
(math-sub (math-mul (nth 3 (nth 3 m))
(nth 1 (nth 1 m)))
(math-mul (nth 3 (nth 1 m))
(nth 1 (nth 3 m))))
(math-sub (math-mul (nth 3 (nth 1 m))
(nth 1 (nth 2 m)))
(math-mul (nth 3 (nth 2 m))
(nth 1 (nth 1 m)))))
(list 'vec
(math-sub (math-mul (nth 2 (nth 3 m))
(nth 1 (nth 2 m)))
(math-mul (nth 2 (nth 2 m))
(nth 1 (nth 3 m))))
(math-sub (math-mul (nth 2 (nth 1 m))
(nth 1 (nth 3 m)))
(math-mul (nth 2 (nth 3 m))
(nth 1 (nth 1 m))))
(math-sub (math-mul (nth 2 (nth 2 m))
(nth 1 (nth 1 m)))
(math-mul (nth 2 (nth 1 m))
(nth 1 (nth 2 m))))))))
det)))
(let ((lud (math-matrix-lud m)))
(and lud
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(math-lud-solve lud (calcFunc-idn 1 n)))))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun calcFunc-det (m)
(if (math-square-matrixp m)
(math-with-extra-prec 2 (math-det-raw m))
(if (and (eq (car-safe m) 'calcFunc-idn)
(or (math-zerop (nth 1 m))
(math-equal-int (nth 1 m) 1)))
(nth 1 m)
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(math-reject-arg m 'square-matrixp))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(calc-det-lu): New variable. (math-det-raw, math-det-step): Replace variable lu by declared variable.
2004-11-26 22:36:10 +00:00
;; The variable math-det-lu is local to math-det-raw, but is
;; used by math-det-step, which is called by math-det-raw.
(defvar math-det-lu)
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-det-raw (m)
(let ((n (1- (length m))))
(cond ((= n 1)
(nth 1 (nth 1 m)))
((= n 2)
(math-sub (math-mul (nth 1 (nth 1 m))
(nth 2 (nth 2 m)))
(math-mul (nth 2 (nth 1 m))
(nth 1 (nth 2 m)))))
((= n 3)
(math-sub
(math-sub
(math-sub
(math-add
(math-add
(math-mul (nth 1 (nth 1 m))
(math-mul (nth 2 (nth 2 m))
(nth 3 (nth 3 m))))
(math-mul (nth 2 (nth 1 m))
(math-mul (nth 3 (nth 2 m))
(nth 1 (nth 3 m)))))
(math-mul (nth 3 (nth 1 m))
(math-mul (nth 1 (nth 2 m))
(nth 2 (nth 3 m)))))
(math-mul (nth 3 (nth 1 m))
(math-mul (nth 2 (nth 2 m))
(nth 1 (nth 3 m)))))
(math-mul (nth 1 (nth 1 m))
(math-mul (nth 3 (nth 2 m))
(nth 2 (nth 3 m)))))
(math-mul (nth 2 (nth 1 m))
(math-mul (nth 1 (nth 2 m))
(nth 3 (nth 3 m))))))
(t (let ((lud (math-matrix-lud m)))
(if lud
(calc-det-lu): New variable. (math-det-raw, math-det-step): Replace variable lu by declared variable.
2004-11-26 22:36:10 +00:00
(let ((math-det-lu (car lud)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(math-det-step n (nth 2 lud)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
0))))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-det-step (n prod)
(if (> n 0)
(calc-det-lu): New variable. (math-det-raw, math-det-step): Replace variable lu by declared variable.
2004-11-26 22:36:10 +00:00
(math-det-step (1- n) (math-mul prod (nth n (nth n math-det-lu))))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
prod))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
Doc fix.
2001-12-20 19:01:00 +00:00
;;; This returns a list (LU index d), or nil if not possible.
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;;; Argument M must be a square matrix.
Change all toplevel `setq' forms to `defvar' forms, and move them before their first use. Use `when', `unless'. Remove trailing periods from error forms. Add description and headers suggested by Emacs Lisp coding conventions.
2001-11-19 07:44:56 +00:00
(defvar math-lud-cache nil)
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-matrix-lud (m)
(let ((old (assoc m math-lud-cache))
(context (list calc-internal-prec calc-prefer-frac)))
(if (and old (equal (nth 1 old) context))
(cdr (cdr old))
(let* ((lud (catch 'singular (math-do-matrix-lud m)))
(entry (cons context lud)))
(if old
(setcdr old entry)
(setq math-lud-cache (cons (cons m entry) math-lud-cache)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
lud))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
* calc/calc-mtx.el (math-lud-pivot-check): New function. (math-do-matrix-lud): Use `math-lud-pivot-check' to check the size of potential pivots.
2011-02-01 02:15:52 +00:00
(defun math-lud-pivot-check (a)
"Determine a useful value for checking the size of potential pivots
in LUD decomposition."
(cond ((eq (car-safe a) 'mod)
(if (and (math-integerp (nth 1 a))
(math-integerp (nth 2 a))
(eq (math-gcd (nth 1 a) (nth 2 a)) 1))
1
0))
(t
(math-abs-approx a))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
;;; Numerical Recipes section 2.3; implicit pivoting omitted.
(defun math-do-matrix-lud (m)
(let* ((lu (math-copy-matrix m))
(n (1- (length lu)))
i (j 1) k imax sum big
(d 1) (index nil))
(while (<= j n)
(setq i 1
big 0
imax j)
(while (< i j)
(math-working "LUD step" (format "%d/%d" j i))
(setq sum (nth j (nth i lu))
k 1)
(while (< k i)
(setq sum (math-sub sum (math-mul (nth k (nth i lu))
(nth j (nth k lu))))
k (1+ k)))
(setcar (nthcdr j (nth i lu)) sum)
(setq i (1+ i)))
(while (<= i n)
(math-working "LUD step" (format "%d/%d" j i))
(setq sum (nth j (nth i lu))
k 1)
(while (< k j)
(setq sum (math-sub sum (math-mul (nth k (nth i lu))
(nth j (nth k lu))))
k (1+ k)))
(setcar (nthcdr j (nth i lu)) sum)
* calc/calc-mtx.el (math-lud-pivot-check): New function. (math-do-matrix-lud): Use `math-lud-pivot-check' to check the size of potential pivots.
2011-02-01 02:15:52 +00:00
(let ((dum (math-lud-pivot-check sum)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(if (Math-lessp big dum)
(setq big dum
imax i)))
(setq i (1+ i)))
(if (> imax j)
(setq lu (math-swap-rows lu j imax)
d (- d)))
(setq index (cons imax index))
(let ((pivot (nth j (nth j lu))))
(if (math-zerop pivot)
(throw 'singular nil)
(setq i j)
(while (<= (setq i (1+ i)) n)
(setcar (nthcdr j (nth i lu))
(math-div (nth j (nth i lu)) pivot)))))
(setq j (1+ j)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(list lu (nreverse index) d)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-swap-rows (m r1 r2)
(or (= r1 r2)
(let* ((r1prev (nthcdr (1- r1) m))
(row1 (cdr r1prev))
(r2prev (nthcdr (1- r2) m))
(row2 (cdr r2prev))
(r2next (cdr row2)))
(setcdr r2prev row1)
(setcdr r1prev row2)
(setcdr row2 (cdr row1))
(setcdr row1 r2next)))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
m)
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun math-lud-solve (lud b &optional need)
(if lud
(let* ((x (math-copy-matrix b))
(n (1- (length x)))
(m (1- (length (nth 1 x))))
(lu (car lud))
(col 1)
i j ip ii index sum)
(while (<= col m)
(math-working "LUD solver step" col)
(setq i 1
ii nil
index (nth 1 lud))
(while (<= i n)
(setq ip (car index)
index (cdr index)
sum (nth col (nth ip x)))
(setcar (nthcdr col (nth ip x)) (nth col (nth i x)))
(if (null ii)
(or (math-zerop sum)
(setq ii i))
(setq j ii)
(while (< j i)
(setq sum (math-sub sum (math-mul (nth j (nth i lu))
(nth col (nth j x))))
j (1+ j))))
(setcar (nthcdr col (nth i x)) sum)
(setq i (1+ i)))
(while (>= (setq i (1- i)) 1)
(setq sum (nth col (nth i x))
j i)
(while (<= (setq j (1+ j)) n)
(setq sum (math-sub sum (math-mul (nth j (nth i lu))
(nth col (nth j x))))))
(setcar (nthcdr col (nth i x))
(math-div sum (nth i (nth i lu)))))
(setq col (1+ col)))
x)
(and need
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(math-reject-arg need "*Singular matrix"))))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
(defun calcFunc-lud (m)
(if (math-square-matrixp m)
(or (math-with-extra-prec 2
(let ((lud (math-matrix-lud m)))
(and lud
(let* ((lmat (math-copy-matrix (car lud)))
(umat (math-copy-matrix (car lud)))
(n (1- (length (car lud))))
(perm (calcFunc-idn 1 n))
i (j 1))
(while (<= j n)
(setq i 1)
(while (< i j)
(setcar (nthcdr j (nth i lmat)) 0)
(setq i (1+ i)))
(setcar (nthcdr j (nth j lmat)) 1)
(while (<= (setq i (1+ i)) n)
(setcar (nthcdr j (nth i umat)) 0))
(setq j (1+ j)))
(while (>= (setq j (1- j)) 1)
(let ((pos (nth (1- j) (nth 1 lud))))
(or (= pos j)
(setq perm (math-swap-rows perm j pos)))))
(list 'vec perm lmat umat)))))
(math-reject-arg m "*Singular matrix"))
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
(math-reject-arg m 'square-matrixp)))
Initial import of Calc 2.02f.
2001-11-06 18:59:06 +00:00
Add a provide statement. (calc-Need-calc-mat): Remove it.
2004-11-30 17:19:02 +00:00
(provide 'calc-mtx)
Style cleanup; don't put closing parens on their own line, add "foo.el ends here" to each file, and update copyright date.
2001-11-14 09:09:09 +00:00
;;; calc-mtx.el ends here
Reference in New Issue Copy Permalink