Mercurial > emacs
annotate lisp/calc/calc-mtx.el @ 110523:a5ad4f188e19
Synch Semantic to CEDET 1.0.
Move CEDET ChangeLog entries to new file lisp/cedet/ChangeLog.
* semantic.el (semantic-version): Update to 2.0.
(semantic-mode-map): Add "," and "m" bindings.
(navigate-menu): Update.
* semantic/symref.el (semantic-symref-calculate-rootdir):
New function.
(semantic-symref-detect-symref-tool): Use it.
* semantic/symref/grep.el (semantic-symref-grep-shell): New var.
(semantic-symref-perform-search): Use it. Calculate root dir with
semantic-symref-calculate-rootdir.
(semantic-symref-derive-find-filepatterns): Improve error message.
* semantic/symref/list.el
(semantic-symref-results-mode-map): New bindings.
(semantic-symref-auto-expand-results): New option.
(semantic-symref-results-dump): Obey auto-expand.
(semantic-symref-list-expand-all, semantic-symref-regexp)
(semantic-symref-list-contract-all)
(semantic-symref-list-map-open-hits)
(semantic-symref-list-update-open-hits)
(semantic-symref-list-create-macro-on-open-hit)
(semantic-symref-list-call-macro-on-open-hits): New functions.
(semantic-symref-list-menu-entries)
(semantic-symref-list-menu): New vars.
(semantic-symref-list-map-open-hits): Move cursor to beginning of
match before calling the mapped function.
* semantic/doc.el
(semantic-documentation-comment-preceeding-tag): Do nothing if the
mode doesn't provide comment-start-skip.
* semantic/scope.el
(semantic-analyze-scope-nested-tags-default): Strip duplicates.
(semantic-analyze-scoped-inherited-tag-map): Take the tag we are
looking for as part of the scoped tags list.
* semantic/html.el (semantic-default-html-setup): Add
senator-step-at-tag-classes.
* semantic/decorate/include.el
(semantic-decoration-on-unknown-includes): Change light bgcolor.
(semantic-decoration-on-includes-highlight-default): Check that
the include tag has a postion.
* semantic/complete.el (semantic-collector-local-members):
(semantic-complete-read-tag-local-members)
(semantic-complete-jump-local-members): New class and functions.
(semantic-complete-self-insert): Save excursion before completing.
* semantic/analyze/complete.el
(semantic-analyze-possible-completions-default): If no completions
are found, return the raw by-name-only completion list. Add FLAGS
arguments. Add support for 'no-tc (type constraint) and
'no-unique, or no stripping duplicates.
(semantic-analyze-possible-completions-default): Add FLAGS arg.
* semantic/util-modes.el
(semantic-stickyfunc-show-only-functions-p): New option.
(semantic-stickyfunc-fetch-stickyline): Don't show stickytext for
the very first line in a buffer.
* semantic/util.el (semantic-hack-search)
(semantic-recursive-find-nonterminal-by-name)
(semantic-current-tag-interactive): Deleted.
(semantic-describe-buffer): Fix expand-nonterminal. Add
lex-syntax-mods, type relation separator char, and command
separation char.
(semantic-sanity-check): Only message if called interactively.
* semantic/tag.el (semantic-tag-deep-copy-one-tag): Copy the
:filename property and the tag position.
* semantic/lex-spp.el (semantic-lex-spp-lex-text-string):
Add recursion limit.
* semantic/imenu.el (semantic-imenu-bucketize-type-members):
Make this buffer local, not the obsoleted variable.
* semantic/idle.el: Add breadcrumbs support.
(semantic-idle-summary-current-symbol-info-default)
(semantic-idle-tag-highlight)
(semantic-idle-completion-list-default): Use
semanticdb-without-unloaded-file-searches for speed, and to
conform to the controls that specify if the idle timer is supposed
to be parsing unparsed includes.
(semantic-idle-symbol-highlight-face)
(semantic-idle-symbol-maybe-highlight): Rename from *-summary-*.
Callers changed.
(semantic-idle-work-parse-neighboring-files-flag): Default to nil.
(semantic-idle-work-update-headers-flag): New var.
(semantic-idle-work-for-one-buffer): Use it.
(semantic-idle-local-symbol-highlight): Rename from
semantic-idle-tag-highlight.
(semantic-idle-truncate-long-summaries): New option.
* semantic/ia.el (semantic-ia-cache)
(semantic-ia-get-completions): Deleted. Callers changed.
(semantic-ia-show-variants): New command.
(semantic-ia-show-doc): If doc is empty, don't make a temp buffer.
(semantic-ia-show-summary): If there isn't anything to show, say so.
* semantic/grammar.el (semantic-grammar-create-package):
Save the buffer even in batch mode.
* semantic/fw.el
(semanticdb-without-unloaded-file-searches): New macro.
* semantic/dep.el (semantic-dependency-find-file-on-path):
Fix case dereferencing ede-object when it is a list.
* semantic/db-typecache.el (semanticdb-expand-nested-tag)
(semanticdb-typecache-faux-namespace): New functions.
(semanticdb-typecache-file-tags)
(semanticdb-typecache-merge-streams): Use them.
(semanticdb-typecache-file-tags): When deriving tags from a file,
give the mode a chance to monkey with the tag copy.
(semanticdb-typecache-find-default): Wrap find in save-excursion.
(semanticdb-typecache-find-by-name-helper): Merge found names down.
* semantic/db-global.el
(semanticdb-enable-gnu-global-in-buffer): Don't show messages if
GNU Global is not available and we don't want to throw an error.
* semantic/db-find.el (semanticdb-find-result-nth-in-buffer):
When trying to normalize the tag to a buffer, don't error if
set-buffer method doesn't exist.
* semantic/db-file.el (semanticdb-save-db): Simplify msg.
* semantic/db.el (semanticdb-refresh-table): If forcing a
refresh on a file not in a buffer, use semantic-find-file-noselect
and delete the buffer after use.
(semanticdb-current-database-list): When calculating root via
hooks, force it through true-filename and skip the list of
possible roots.
* semantic/ctxt.el (semantic-ctxt-imported-packages): New.
* semantic/analyze/debug.el
(semantic-analyzer-debug-insert-tag): Reset standard output to
current buffer.
(semantic-analyzer-debug-global-symbol)
(semantic-analyzer-debug-missing-innertype): Change "prefix" to
"symbol" in messages.
* semantic/analyze/refs.el: (semantic-analyze-refs-impl)
(semantic-analyze-refs-proto): When calculating value, make sure
the found tag is 'similar' to the originating tag.
(semantic--analyze-refs-find-tags-with-parent): Attempt to
identify matches via imported symbols of parents.
(semantic--analyze-refs-full-lookup-with-parents): Do a deep
search during the brute search.
* semantic/analyze.el
(semantic-analyze-find-tag-sequence-default): Be robust to
calculated scopes being nil.
* semantic/bovine/c.el (semantic-c-describe-environment): Add
project macro symbol array.
(semantic-c-parse-lexical-token): Add recursion limit.
(semantic-ctxt-imported-packages, semanticdb-expand-nested-tag):
New overrides.
(semantic-expand-c-tag-namelist): Split a full type from a typedef
out to its own tag.
(semantic-expand-c-tag-namelist): Do not split out a typedef'd
inline type if it is an anonymous type.
(semantic-c-reconstitute-token): Use the optional initializers as
a clue that some function is probably a constructor. When
defining the type of these constructors, split the parent name,
and use only the class part, if applicable.
* semantic/bovine/c-by.el:
* semantic/wisent/python-wy.el: Regenerate.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sat, 18 Sep 2010 22:49:54 -0400 |
parents | 1d1d5d9bd884 |
children | 376148b31b5e |
rev | line source |
---|---|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
1 ;;; calc-mtx.el --- matrix functions for Calc |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
2 |
64325
1db49616ce05
Update copyright information.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
62442
diff
changeset
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, |
106815 | 4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
5 |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
6 ;; Author: David Gillespie <daveg@synaptics.com> |
77465
1154f082efd9
Update maintainer's address.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
76595
diff
changeset
|
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> |
40785 | 8 |
9 ;; This file is part of GNU Emacs. | |
10 | |
94654
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
11 ;; GNU Emacs is free software: you can redistribute it and/or modify |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
12 ;; it under the terms of the GNU General Public License as published by |
94654
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
13 ;; the Free Software Foundation, either version 3 of the License, or |
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
14 ;; (at your option) any later version. |
40785 | 15 |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
16 ;; GNU Emacs is distributed in the hope that it will be useful, |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
19 ;; GNU General Public License for more details. |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
20 |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
21 ;; You should have received a copy of the GNU General Public License |
94654
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
40785 | 23 |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
24 ;;; Commentary: |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
25 |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
26 ;;; Code: |
40785 | 27 |
28 ;; This file is autoloaded from calc-ext.el. | |
29 | |
58666
b21f320635a7
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58548
diff
changeset
|
30 (require 'calc-ext) |
40785 | 31 (require 'calc-macs) |
32 | |
33 (defun calc-mdet (arg) | |
34 (interactive "P") | |
35 (calc-slow-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
36 (calc-unary-op "mdet" 'calcFunc-det arg))) |
40785 | 37 |
38 (defun calc-mtrace (arg) | |
39 (interactive "P") | |
40 (calc-slow-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
41 (calc-unary-op "mtr" 'calcFunc-tr arg))) |
40785 | 42 |
43 (defun calc-mlud (arg) | |
44 (interactive "P") | |
45 (calc-slow-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
46 (calc-unary-op "mlud" 'calcFunc-lud arg))) |
40785 | 47 |
48 | |
49 ;;; Coerce row vector A to be a matrix. [V V] | |
50 (defun math-row-matrix (a) | |
51 (if (and (Math-vectorp a) | |
52 (not (math-matrixp a))) | |
53 (list 'vec a) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
54 a)) |
40785 | 55 |
56 ;;; Coerce column vector A to be a matrix. [V V] | |
57 (defun math-col-matrix (a) | |
58 (if (and (Math-vectorp a) | |
59 (not (math-matrixp a))) | |
60 (cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
61 a)) |
40785 | 62 |
63 | |
64 | |
65 ;;; Multiply matrices A and B. [V V V] | |
66 (defun math-mul-mats (a b) | |
67 (let ((mat nil) | |
68 (cols (length (nth 1 b))) | |
69 row col ap bp accum) | |
70 (while (setq a (cdr a)) | |
71 (setq col cols | |
72 row nil) | |
73 (while (> (setq col (1- col)) 0) | |
74 (setq ap (cdr (car a)) | |
75 bp (cdr b) | |
76 accum (math-mul (car ap) (nth col (car bp)))) | |
77 (while (setq ap (cdr ap) bp (cdr bp)) | |
78 (setq accum (math-add accum (math-mul (car ap) (nth col (car bp)))))) | |
79 (setq row (cons accum row))) | |
80 (setq mat (cons (cons 'vec row) mat))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
81 (cons 'vec (nreverse mat)))) |
40785 | 82 |
83 (defun math-mul-mat-vec (a b) | |
84 (cons 'vec (mapcar (function (lambda (row) | |
85 (math-dot-product row b))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
86 (cdr a)))) |
40785 | 87 |
88 | |
89 | |
90 (defun calcFunc-tr (mat) ; [Public] | |
91 (if (math-square-matrixp mat) | |
92 (math-matrix-trace-step 2 (1- (length mat)) mat (nth 1 (nth 1 mat))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
93 (math-reject-arg mat 'square-matrixp))) |
40785 | 94 |
95 (defun math-matrix-trace-step (n size mat sum) | |
96 (if (<= n size) | |
97 (math-matrix-trace-step (1+ n) size mat | |
98 (math-add sum (nth n (nth n mat)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
99 sum)) |
40785 | 100 |
101 | |
102 ;;; Matrix inverse and determinant. | |
103 (defun math-matrix-inv-raw (m) | |
104 (let ((n (1- (length m)))) | |
105 (if (<= n 3) | |
106 (let ((det (math-det-raw m))) | |
107 (and (not (math-zerop det)) | |
108 (math-div | |
109 (cond ((= n 1) 1) | |
110 ((= n 2) | |
111 (list 'vec | |
112 (list 'vec | |
113 (nth 2 (nth 2 m)) | |
114 (math-neg (nth 2 (nth 1 m)))) | |
115 (list 'vec | |
116 (math-neg (nth 1 (nth 2 m))) | |
117 (nth 1 (nth 1 m))))) | |
118 ((= n 3) | |
119 (list 'vec | |
120 (list 'vec | |
121 (math-sub (math-mul (nth 3 (nth 3 m)) | |
122 (nth 2 (nth 2 m))) | |
123 (math-mul (nth 3 (nth 2 m)) | |
124 (nth 2 (nth 3 m)))) | |
125 (math-sub (math-mul (nth 3 (nth 1 m)) | |
126 (nth 2 (nth 3 m))) | |
127 (math-mul (nth 3 (nth 3 m)) | |
128 (nth 2 (nth 1 m)))) | |
129 (math-sub (math-mul (nth 3 (nth 2 m)) | |
130 (nth 2 (nth 1 m))) | |
131 (math-mul (nth 3 (nth 1 m)) | |
132 (nth 2 (nth 2 m))))) | |
133 (list 'vec | |
134 (math-sub (math-mul (nth 3 (nth 2 m)) | |
135 (nth 1 (nth 3 m))) | |
136 (math-mul (nth 3 (nth 3 m)) | |
137 (nth 1 (nth 2 m)))) | |
138 (math-sub (math-mul (nth 3 (nth 3 m)) | |
139 (nth 1 (nth 1 m))) | |
140 (math-mul (nth 3 (nth 1 m)) | |
141 (nth 1 (nth 3 m)))) | |
142 (math-sub (math-mul (nth 3 (nth 1 m)) | |
143 (nth 1 (nth 2 m))) | |
144 (math-mul (nth 3 (nth 2 m)) | |
145 (nth 1 (nth 1 m))))) | |
146 (list 'vec | |
147 (math-sub (math-mul (nth 2 (nth 3 m)) | |
148 (nth 1 (nth 2 m))) | |
149 (math-mul (nth 2 (nth 2 m)) | |
150 (nth 1 (nth 3 m)))) | |
151 (math-sub (math-mul (nth 2 (nth 1 m)) | |
152 (nth 1 (nth 3 m))) | |
153 (math-mul (nth 2 (nth 3 m)) | |
154 (nth 1 (nth 1 m)))) | |
155 (math-sub (math-mul (nth 2 (nth 2 m)) | |
156 (nth 1 (nth 1 m))) | |
157 (math-mul (nth 2 (nth 1 m)) | |
158 (nth 1 (nth 2 m)))))))) | |
159 det))) | |
160 (let ((lud (math-matrix-lud m))) | |
161 (and lud | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
162 (math-lud-solve lud (calcFunc-idn 1 n))))))) |
40785 | 163 |
164 (defun calcFunc-det (m) | |
165 (if (math-square-matrixp m) | |
166 (math-with-extra-prec 2 (math-det-raw m)) | |
167 (if (and (eq (car-safe m) 'calcFunc-idn) | |
168 (or (math-zerop (nth 1 m)) | |
169 (math-equal-int (nth 1 m) 1))) | |
170 (nth 1 m) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
171 (math-reject-arg m 'square-matrixp)))) |
40785 | 172 |
58548
f2bcc073e61e
(calc-det-lu): New variable.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
173 ;; The variable math-det-lu is local to math-det-raw, but is |
f2bcc073e61e
(calc-det-lu): New variable.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
174 ;; used by math-det-step, which is called by math-det-raw. |
f2bcc073e61e
(calc-det-lu): New variable.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
175 (defvar math-det-lu) |
f2bcc073e61e
(calc-det-lu): New variable.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
176 |
40785 | 177 (defun math-det-raw (m) |
178 (let ((n (1- (length m)))) | |
179 (cond ((= n 1) | |
180 (nth 1 (nth 1 m))) | |
181 ((= n 2) | |
182 (math-sub (math-mul (nth 1 (nth 1 m)) | |
183 (nth 2 (nth 2 m))) | |
184 (math-mul (nth 2 (nth 1 m)) | |
185 (nth 1 (nth 2 m))))) | |
186 ((= n 3) | |
187 (math-sub | |
188 (math-sub | |
189 (math-sub | |
190 (math-add | |
191 (math-add | |
192 (math-mul (nth 1 (nth 1 m)) | |
193 (math-mul (nth 2 (nth 2 m)) | |
194 (nth 3 (nth 3 m)))) | |
195 (math-mul (nth 2 (nth 1 m)) | |
196 (math-mul (nth 3 (nth 2 m)) | |
197 (nth 1 (nth 3 m))))) | |
198 (math-mul (nth 3 (nth 1 m)) | |
199 (math-mul (nth 1 (nth 2 m)) | |
200 (nth 2 (nth 3 m))))) | |
201 (math-mul (nth 3 (nth 1 m)) | |
202 (math-mul (nth 2 (nth 2 m)) | |
203 (nth 1 (nth 3 m))))) | |
204 (math-mul (nth 1 (nth 1 m)) | |
205 (math-mul (nth 3 (nth 2 m)) | |
206 (nth 2 (nth 3 m))))) | |
207 (math-mul (nth 2 (nth 1 m)) | |
208 (math-mul (nth 1 (nth 2 m)) | |
209 (nth 3 (nth 3 m)))))) | |
210 (t (let ((lud (math-matrix-lud m))) | |
211 (if lud | |
58548
f2bcc073e61e
(calc-det-lu): New variable.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
212 (let ((math-det-lu (car lud))) |
40785 | 213 (math-det-step n (nth 2 lud))) |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
214 0)))))) |
40785 | 215 |
216 (defun math-det-step (n prod) | |
217 (if (> n 0) | |
58548
f2bcc073e61e
(calc-det-lu): New variable.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
218 (math-det-step (1- n) (math-mul prod (nth n (nth n math-det-lu)))) |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
219 prod)) |
40785 | 220 |
42206 | 221 ;;; This returns a list (LU index d), or nil if not possible. |
40785 | 222 ;;; Argument M must be a square matrix. |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
223 (defvar math-lud-cache nil) |
40785 | 224 (defun math-matrix-lud (m) |
225 (let ((old (assoc m math-lud-cache)) | |
226 (context (list calc-internal-prec calc-prefer-frac))) | |
227 (if (and old (equal (nth 1 old) context)) | |
228 (cdr (cdr old)) | |
229 (let* ((lud (catch 'singular (math-do-matrix-lud m))) | |
230 (entry (cons context lud))) | |
231 (if old | |
232 (setcdr old entry) | |
233 (setq math-lud-cache (cons (cons m entry) math-lud-cache))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
234 lud)))) |
40785 | 235 |
236 ;;; Numerical Recipes section 2.3; implicit pivoting omitted. | |
237 (defun math-do-matrix-lud (m) | |
238 (let* ((lu (math-copy-matrix m)) | |
239 (n (1- (length lu))) | |
240 i (j 1) k imax sum big | |
241 (d 1) (index nil)) | |
242 (while (<= j n) | |
243 (setq i 1 | |
244 big 0 | |
245 imax j) | |
246 (while (< i j) | |
247 (math-working "LUD step" (format "%d/%d" j i)) | |
248 (setq sum (nth j (nth i lu)) | |
249 k 1) | |
250 (while (< k i) | |
251 (setq sum (math-sub sum (math-mul (nth k (nth i lu)) | |
252 (nth j (nth k lu)))) | |
253 k (1+ k))) | |
254 (setcar (nthcdr j (nth i lu)) sum) | |
255 (setq i (1+ i))) | |
256 (while (<= i n) | |
257 (math-working "LUD step" (format "%d/%d" j i)) | |
258 (setq sum (nth j (nth i lu)) | |
259 k 1) | |
260 (while (< k j) | |
261 (setq sum (math-sub sum (math-mul (nth k (nth i lu)) | |
262 (nth j (nth k lu)))) | |
263 k (1+ k))) | |
264 (setcar (nthcdr j (nth i lu)) sum) | |
265 (let ((dum (math-abs-approx sum))) | |
266 (if (Math-lessp big dum) | |
267 (setq big dum | |
268 imax i))) | |
269 (setq i (1+ i))) | |
270 (if (> imax j) | |
271 (setq lu (math-swap-rows lu j imax) | |
272 d (- d))) | |
273 (setq index (cons imax index)) | |
274 (let ((pivot (nth j (nth j lu)))) | |
275 (if (math-zerop pivot) | |
276 (throw 'singular nil) | |
277 (setq i j) | |
278 (while (<= (setq i (1+ i)) n) | |
279 (setcar (nthcdr j (nth i lu)) | |
280 (math-div (nth j (nth i lu)) pivot))))) | |
281 (setq j (1+ j))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
282 (list lu (nreverse index) d))) |
40785 | 283 |
284 (defun math-swap-rows (m r1 r2) | |
285 (or (= r1 r2) | |
286 (let* ((r1prev (nthcdr (1- r1) m)) | |
287 (row1 (cdr r1prev)) | |
288 (r2prev (nthcdr (1- r2) m)) | |
289 (row2 (cdr r2prev)) | |
290 (r2next (cdr row2))) | |
291 (setcdr r2prev row1) | |
292 (setcdr r1prev row2) | |
293 (setcdr row2 (cdr row1)) | |
294 (setcdr row1 r2next))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
295 m) |
40785 | 296 |
297 | |
298 (defun math-lud-solve (lud b &optional need) | |
299 (if lud | |
300 (let* ((x (math-copy-matrix b)) | |
301 (n (1- (length x))) | |
302 (m (1- (length (nth 1 x)))) | |
303 (lu (car lud)) | |
304 (col 1) | |
305 i j ip ii index sum) | |
306 (while (<= col m) | |
307 (math-working "LUD solver step" col) | |
308 (setq i 1 | |
309 ii nil | |
310 index (nth 1 lud)) | |
311 (while (<= i n) | |
312 (setq ip (car index) | |
313 index (cdr index) | |
314 sum (nth col (nth ip x))) | |
315 (setcar (nthcdr col (nth ip x)) (nth col (nth i x))) | |
316 (if (null ii) | |
317 (or (math-zerop sum) | |
318 (setq ii i)) | |
319 (setq j ii) | |
320 (while (< j i) | |
321 (setq sum (math-sub sum (math-mul (nth j (nth i lu)) | |
322 (nth col (nth j x)))) | |
323 j (1+ j)))) | |
324 (setcar (nthcdr col (nth i x)) sum) | |
325 (setq i (1+ i))) | |
326 (while (>= (setq i (1- i)) 1) | |
327 (setq sum (nth col (nth i x)) | |
328 j i) | |
329 (while (<= (setq j (1+ j)) n) | |
330 (setq sum (math-sub sum (math-mul (nth j (nth i lu)) | |
331 (nth col (nth j x)))))) | |
332 (setcar (nthcdr col (nth i x)) | |
333 (math-div sum (nth i (nth i lu))))) | |
334 (setq col (1+ col))) | |
335 x) | |
336 (and need | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
337 (math-reject-arg need "*Singular matrix")))) |
40785 | 338 |
339 (defun calcFunc-lud (m) | |
340 (if (math-square-matrixp m) | |
341 (or (math-with-extra-prec 2 | |
342 (let ((lud (math-matrix-lud m))) | |
343 (and lud | |
344 (let* ((lmat (math-copy-matrix (car lud))) | |
345 (umat (math-copy-matrix (car lud))) | |
346 (n (1- (length (car lud)))) | |
347 (perm (calcFunc-idn 1 n)) | |
348 i (j 1)) | |
349 (while (<= j n) | |
350 (setq i 1) | |
351 (while (< i j) | |
352 (setcar (nthcdr j (nth i lmat)) 0) | |
353 (setq i (1+ i))) | |
354 (setcar (nthcdr j (nth j lmat)) 1) | |
355 (while (<= (setq i (1+ i)) n) | |
356 (setcar (nthcdr j (nth i umat)) 0)) | |
357 (setq j (1+ j))) | |
358 (while (>= (setq j (1- j)) 1) | |
359 (let ((pos (nth (1- j) (nth 1 lud)))) | |
360 (or (= pos j) | |
361 (setq perm (math-swap-rows perm j pos))))) | |
362 (list 'vec perm lmat umat))))) | |
363 (math-reject-arg m "*Singular matrix")) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
364 (math-reject-arg m 'square-matrixp))) |
40785 | 365 |
58666
b21f320635a7
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58548
diff
changeset
|
366 (provide 'calc-mtx) |
b21f320635a7
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58548
diff
changeset
|
367 |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
79702
diff
changeset
|
368 ;; arch-tag: fc0947b1-90e1-4a23-8950-d8ead9c3a306 |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
369 ;;; calc-mtx.el ends here |