1 |
;; Calculator for GNU Emacs, part II [calc-alg-3.el] |
;; Calculator for GNU Emacs, part II [calc-alg-3.el] |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
47 |
(calc-enter-result 1 "root" (list func |
(calc-enter-result 1 "root" (list func |
48 |
(calc-top-n 2) |
(calc-top-n 2) |
49 |
var |
var |
50 |
(calc-top-n 1))))))) |
(calc-top-n 1)))))))) |
|
) |
|
51 |
|
|
52 |
(defun calc-find-minimum (var) |
(defun calc-find-minimum (var) |
53 |
(interactive "sVariable(s) to minimize over: ") |
(interactive "sVariable(s) to minimize over: ") |
72 |
(calc-enter-result 1 tag (list func |
(calc-enter-result 1 tag (list func |
73 |
(calc-top-n 2) |
(calc-top-n 2) |
74 |
var |
var |
75 |
(calc-top-n 1))))))) |
(calc-top-n 1)))))))) |
|
) |
|
76 |
|
|
77 |
(defun calc-find-maximum (var) |
(defun calc-find-maximum (var) |
78 |
(interactive "sVariable to maximize over: ") |
(interactive "sVariable to maximize over: ") |
79 |
(calc-invert-func) |
(calc-invert-func) |
80 |
(calc-find-minimum var) |
(calc-find-minimum var)) |
|
) |
|
81 |
|
|
82 |
|
|
83 |
(defun calc-poly-interp (arg) |
(defun calc-poly-interp (arg) |
91 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
92 |
(calc-enter-result 1 "rati" (list 'calcFunc-ratint data (calc-top 1))) |
(calc-enter-result 1 "rati" (list 'calcFunc-ratint data (calc-top 1))) |
93 |
(calc-enter-result 1 "poli" (list 'calcFunc-polint data |
(calc-enter-result 1 "poli" (list 'calcFunc-polint data |
94 |
(calc-top 1)))))) |
(calc-top 1))))))) |
|
) |
|
95 |
|
|
96 |
|
|
97 |
(defun calc-curve-fit (arg &optional model coefnames varnames) |
(defun calc-curve-fit (arg &optional model coefnames varnames) |
308 |
coefnames) |
coefnames) |
309 |
data)) |
data)) |
310 |
(if (consp calc-fit-to-trail) |
(if (consp calc-fit-to-trail) |
311 |
(calc-record (calc-normalize calc-fit-to-trail) "parm"))))) |
(calc-record (calc-normalize calc-fit-to-trail) "parm")))))) |
|
) |
|
312 |
|
|
313 |
(defun calc-invent-independent-variables (n &optional but) |
(defun calc-invent-independent-variables (n &optional but) |
314 |
(calc-invent-variables n but '(x y z t) "x") |
(calc-invent-variables n but '(x y z t) "x")) |
|
) |
|
315 |
|
|
316 |
(defun calc-invent-parameter-variables (n &optional but) |
(defun calc-invent-parameter-variables (n &optional but) |
317 |
(calc-invent-variables n but '(a b c d) "a") |
(calc-invent-variables n but '(a b c d) "a")) |
|
) |
|
318 |
|
|
319 |
(defun calc-invent-variables (num but names base) |
(defun calc-invent-variables (num but names base) |
320 |
(let ((vars nil) |
(let ((vars nil) |
330 |
(or (symbolp names) (setq names (cdr names)))) |
(or (symbolp names) (setq names (cdr names)))) |
331 |
(if (= n 0) |
(if (= n 0) |
332 |
(nreverse vars) |
(nreverse vars) |
333 |
(calc-invent-variables num but t base))) |
(calc-invent-variables num but t base)))) |
|
) |
|
334 |
|
|
335 |
(defun calc-get-fit-variables (nv nc &optional defv defc with-y homog) |
(defun calc-get-fit-variables (nv nc &optional defv defc with-y homog) |
336 |
(or (= nv (if with-y (1+ nvars) nvars)) |
(or (= nv (if with-y (1+ nvars) nvars)) |
386 |
(if coefnames |
(if coefnames |
387 |
(setq model (math-multi-subst model (cdr coefnames) (cdr coefs)))) |
(setq model (math-multi-subst model (cdr coefnames) (cdr coefs)))) |
388 |
(setq varnames vars |
(setq varnames vars |
389 |
coefnames coefs)) |
coefnames coefs))) |
|
) |
|
390 |
|
|
391 |
|
|
392 |
|
|
413 |
limit) |
limit) |
414 |
(math-newton-root expr deriv next orig-guess limit) |
(math-newton-root expr deriv next orig-guess limit) |
415 |
(math-reject-arg next "*Newton's method failed to converge")))) |
(math-reject-arg next "*Newton's method failed to converge")))) |
416 |
(math-reject-arg next "*Newton's method encountered a singularity"))) |
(math-reject-arg next "*Newton's method encountered a singularity")))) |
|
) |
|
417 |
|
|
418 |
;;; Inspired by "rtsafe" |
;;; Inspired by "rtsafe" |
419 |
(defun math-newton-search-root (expr deriv guess vguess ostep oostep |
(defun math-newton-search-root (expr deriv guess vguess ostep oostep |
484 |
(and (Math-negp vlow) (Math-negp vhigh))) |
(and (Math-negp vlow) (Math-negp vhigh))) |
485 |
(math-search-root expr deriv low vlow high vhigh) |
(math-search-root expr deriv low vlow high vhigh) |
486 |
(math-newton-search-root expr deriv nil nil nil ostep |
(math-newton-search-root expr deriv nil nil nil ostep |
487 |
low vlow high vhigh))))) |
low vlow high vhigh)))))) |
|
) |
|
488 |
|
|
489 |
;;; Search for a root in an interval with no overt zero crossing. |
;;; Search for a root in an interval with no overt zero crossing. |
490 |
(defun math-search-root (expr deriv low vlow high vhigh) |
(defun math-search-root (expr deriv low vlow high vhigh) |
568 |
low vlow high vhigh) |
low vlow high vhigh) |
569 |
(math-bisect-root expr low vlow high vhigh)))) |
(math-bisect-root expr low vlow high vhigh)))) |
570 |
(math-reject-arg (list 'intv 3 low high) |
(math-reject-arg (list 'intv 3 low high) |
571 |
"*Unable to find a sign change in this interval"))) |
"*Unable to find a sign change in this interval")))) |
|
) |
|
572 |
|
|
573 |
;;; "rtbis" (but we should be using Brent's method) |
;;; "rtbis" (but we should be using Brent's method) |
574 |
(defun math-bisect-root (expr low vlow high vhigh) |
(defun math-bisect-root (expr low vlow high vhigh) |
590 |
vhigh vmid) |
vhigh vmid) |
591 |
(setq low mid |
(setq low mid |
592 |
vlow vmid))) |
vlow vmid))) |
593 |
(list 'vec mid vmid)) |
(list 'vec mid vmid))) |
|
) |
|
594 |
|
|
595 |
;;; "mnewt" |
;;; "mnewt" |
596 |
(defun math-newton-multi (expr jacob n guess orig-guess limit) |
(defun math-newton-multi (expr jacob n guess orig-guess limit) |
615 |
limit) |
limit) |
616 |
(math-newton-multi expr jacob n next orig-guess limit) |
(math-newton-multi expr jacob n next orig-guess limit) |
617 |
(math-reject-arg nil "*Newton's method failed to converge")) |
(math-reject-arg nil "*Newton's method failed to converge")) |
618 |
(list 'vec next expr-val))) |
(list 'vec next expr-val)))) |
|
) |
|
619 |
|
|
620 |
(defvar math-root-vars [(var DUMMY var-DUMMY)]) |
(defvar math-root-vars [(var DUMMY var-DUMMY)]) |
621 |
|
|
732 |
(not (Math-numberp vlow)) |
(not (Math-numberp vlow)) |
733 |
(not (Math-numberp vhigh))) |
(not (Math-numberp vhigh))) |
734 |
(math-search-root expr deriv low vlow high vhigh) |
(math-search-root expr deriv low vlow high vhigh) |
735 |
(math-bisect-root expr low vlow high vhigh))))))))) |
(math-bisect-root expr low vlow high vhigh)))))))))) |
|
) |
|
736 |
|
|
737 |
(defun calcFunc-root (expr var guess) |
(defun calcFunc-root (expr var guess) |
738 |
(math-find-root expr var guess nil) |
(math-find-root expr var guess nil)) |
|
) |
|
739 |
|
|
740 |
(defun calcFunc-wroot (expr var guess) |
(defun calcFunc-wroot (expr var guess) |
741 |
(math-find-root expr var guess t) |
(math-find-root expr var guess t)) |
|
) |
|
742 |
|
|
743 |
|
|
744 |
|
|
756 |
(math-float a) |
(math-float a) |
757 |
(if (eq (car a) 'float) |
(if (eq (car a) 'float) |
758 |
a |
a |
759 |
(math-reject-arg a 'realp))) |
(math-reject-arg a 'realp)))) |
|
) |
|
760 |
|
|
761 |
|
|
762 |
;;; A bracket for a minimum is a < b < c where f(b) < f(a) and f(b) < f(c). |
;;; A bracket for a minimum is a < b < c where f(b) < f(a) and f(b) < f(c). |
824 |
c u vc vu)) |
c u vc vu)) |
825 |
(if (math-lessp-float a c) |
(if (math-lessp-float a c) |
826 |
(list a va b vb c vc) |
(list a va b vb c vc) |
827 |
(list c vc b vb a va))) |
(list c vc b vb a va)))) |
|
) |
|
828 |
|
|
829 |
(defun math-narrow-min (expr a c intv) |
(defun math-narrow-min (expr a c intv) |
830 |
(let ((xvals (list a c)) |
(let ((xvals (list a c)) |
874 |
(and (not yvals) |
(and (not yvals) |
875 |
(list (nth 3 intv) min))))) |
(list (nth 3 intv) min))))) |
876 |
(math-reject-arg nil (format "*Unable to find a %s in the interval" |
(math-reject-arg nil (format "*Unable to find a %s in the interval" |
877 |
math-min-or-max))))) |
math-min-or-max)))))) |
|
) |
|
878 |
|
|
879 |
;;; "brent" |
;;; "brent" |
880 |
(defun math-brent-min (expr prec a va x vx b vb) |
(defun math-brent-min (expr prec a va x vx b vb) |
966 |
(setq v w vv vw |
(setq v w vv vw |
967 |
w x vw vx |
w x vw vx |
968 |
x u vx vu))) |
x u vx vu))) |
969 |
(list 'vec x vx)) |
(list 'vec x vx))) |
|
) |
|
970 |
|
|
971 |
;;; "powell" |
;;; "powell" |
972 |
(defun math-powell-min (expr n guesses prec) |
(defun math-powell-min (expr n guesses prec) |
1026 |
(while (<= (setq i (1+ i)) n) |
(while (<= (setq i (1+ i)) n) |
1027 |
(setcar (nthcdr ibig (nth i xi)) |
(setcar (nthcdr ibig (nth i xi)) |
1028 |
(nth i (nth 1 res))))))) |
(nth i (nth 1 res))))))) |
1029 |
(list 'vec p fret)) |
(list 'vec p fret))) |
|
) |
|
1030 |
|
|
1031 |
(defun math-line-min-func (expr n) |
(defun math-line-min-func (expr n) |
1032 |
(let ((m -1)) |
(let ((m -1)) |
1037 |
'(var DUMMY var-DUMMY) |
'(var DUMMY var-DUMMY) |
1038 |
(list 'calcFunc-mrow '(var line-xi line-xi) (1+ m))) |
(list 'calcFunc-mrow '(var line-xi line-xi) (1+ m))) |
1039 |
(list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) |
(list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) |
1040 |
(math-evaluate-expr expr)) |
(math-evaluate-expr expr))) |
|
) |
|
1041 |
|
|
1042 |
(defun math-line-min (f1dim line-p line-xi n prec) |
(defun math-line-min (f1dim line-p line-xi n prec) |
1043 |
(let* ((var-DUMMY nil) |
(let* ((var-DUMMY nil) |
1045 |
(params (math-widen-min expr '(float 0 0) '(float 1 0))) |
(params (math-widen-min expr '(float 0 0) '(float 1 0))) |
1046 |
(res (apply 'math-brent-min expr prec params)) |
(res (apply 'math-brent-min expr prec params)) |
1047 |
(xi (math-mul (nth 1 res) line-xi))) |
(xi (math-mul (nth 1 res) line-xi))) |
1048 |
(list (math-add line-p xi) xi (nth 2 res))) |
(list (math-add line-p xi) xi (nth 2 res)))) |
|
) |
|
1049 |
|
|
1050 |
|
|
1051 |
(defvar math-min-vars [(var DUMMY var-DUMMY)]) |
(defvar math-min-vars [(var DUMMY var-DUMMY)]) |
1144 |
(setq guesses (cdr guesses))) |
(setq guesses (cdr guesses))) |
1145 |
(if isvec |
(if isvec |
1146 |
(list 'vec vec (nth 2 res)) |
(list 'vec vec (nth 2 res)) |
1147 |
(list 'vec (nth 1 vec) (nth 2 res)))))) |
(list 'vec (nth 1 vec) (nth 2 res))))))) |
|
) |
|
1148 |
(setq math-min-or-max "minimum") |
(setq math-min-or-max "minimum") |
1149 |
|
|
1150 |
(defun calcFunc-minimize (expr var guess) |
(defun calcFunc-minimize (expr var guess) |
1152 |
(math-min-or-max "minimum")) |
(math-min-or-max "minimum")) |
1153 |
(math-find-minimum (math-normalize expr) |
(math-find-minimum (math-normalize expr) |
1154 |
(math-normalize var) |
(math-normalize var) |
1155 |
(math-normalize guess) nil)) |
(math-normalize guess) nil))) |
|
) |
|
1156 |
|
|
1157 |
(defun calcFunc-wminimize (expr var guess) |
(defun calcFunc-wminimize (expr var guess) |
1158 |
(let ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) |
(let ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) |
1159 |
(math-min-or-max "minimum")) |
(math-min-or-max "minimum")) |
1160 |
(math-find-minimum (math-normalize expr) |
(math-find-minimum (math-normalize expr) |
1161 |
(math-normalize var) |
(math-normalize var) |
1162 |
(math-normalize guess) t)) |
(math-normalize guess) t))) |
|
) |
|
1163 |
|
|
1164 |
(defun calcFunc-maximize (expr var guess) |
(defun calcFunc-maximize (expr var guess) |
1165 |
(let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) |
(let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) |
1167 |
(res (math-find-minimum (math-normalize (math-neg expr)) |
(res (math-find-minimum (math-normalize (math-neg expr)) |
1168 |
(math-normalize var) |
(math-normalize var) |
1169 |
(math-normalize guess) nil))) |
(math-normalize guess) nil))) |
1170 |
(list 'vec (nth 1 res) (math-neg (nth 2 res)))) |
(list 'vec (nth 1 res) (math-neg (nth 2 res))))) |
|
) |
|
1171 |
|
|
1172 |
(defun calcFunc-wmaximize (expr var guess) |
(defun calcFunc-wmaximize (expr var guess) |
1173 |
(let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) |
(let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) |
1175 |
(res (math-find-minimum (math-normalize (math-neg expr)) |
(res (math-find-minimum (math-normalize (math-neg expr)) |
1176 |
(math-normalize var) |
(math-normalize var) |
1177 |
(math-normalize guess) t))) |
(math-normalize guess) t))) |
1178 |
(list 'vec (nth 1 res) (math-neg (nth 2 res)))) |
(list 'vec (nth 1 res) (math-neg (nth 2 res))))) |
|
) |
|
1179 |
|
|
1180 |
|
|
1181 |
|
|
1194 |
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) |
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) |
1195 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
1196 |
(cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x |
(cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x |
1197 |
nil)))) |
nil))))) |
|
) |
|
1198 |
(put 'calcFunc-polint 'math-expandable t) |
(put 'calcFunc-polint 'math-expandable t) |
1199 |
|
|
1200 |
|
|
1210 |
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) |
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) |
1211 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
1212 |
(cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x |
(cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x |
1213 |
(cdr (cdr (cdr (nth 1 data)))))))) |
(cdr (cdr (cdr (nth 1 data))))))))) |
|
) |
|
1214 |
(put 'calcFunc-ratint 'math-expandable t) |
(put 'calcFunc-ratint 'math-expandable t) |
1215 |
|
|
1216 |
|
|
1264 |
(setq ns (1- ns) |
(setq ns (1- ns) |
1265 |
dy (nth ns d))) |
dy (nth ns d))) |
1266 |
(setq y (math-add y dy))) |
(setq y (math-add y dy))) |
1267 |
(list y dy))) |
(list y dy)))) |
|
) |
|
1268 |
|
|
1269 |
|
|
1270 |
|
|
1303 |
(math-ninteg-romberg |
(math-ninteg-romberg |
1304 |
'math-ninteg-midpoint expr |
'math-ninteg-midpoint expr |
1305 |
(math-float lo) (math-float hi) nil)))) |
(math-float lo) (math-float hi) nil)))) |
1306 |
sum)) |
sum))) |
|
) |
|
1307 |
|
|
1308 |
|
|
1309 |
;;; Open Romberg method; "qromo" in section 4.4. |
;;; Open Romberg method; "qromo" in section 4.4. |
1332 |
h (cdr h))) |
h (cdr h))) |
1333 |
(setq curh (math-div-float curh '(float 9 0)))) |
(setq curh (math-div-float curh '(float 9 0)))) |
1334 |
ss |
ss |
1335 |
(math-reject-arg nil (format "*Integral failed to converge"))))) |
(math-reject-arg nil (format "*Integral failed to converge")))))) |
|
) |
|
1336 |
|
|
1337 |
|
|
1338 |
(defun math-ninteg-evaluate (expr x mode) |
(defun math-ninteg-evaluate (expr x mode) |
1344 |
(math-reject-arg res "*Integrand does not evaluate to a number")) |
(math-reject-arg res "*Integrand does not evaluate to a number")) |
1345 |
(if (eq mode 'inf) |
(if (eq mode 'inf) |
1346 |
(setq res (math-mul res (math-sqr x)))) |
(setq res (math-mul res (math-sqr x)))) |
1347 |
res) |
res)) |
|
) |
|
1348 |
|
|
1349 |
|
|
1350 |
(defun math-ninteg-midpoint (expr lo hi mode) ; uses "integ-temp" |
(defun math-ninteg-midpoint (expr lo hi mode) ; uses "integ-temp" |
1382 |
expr |
expr |
1383 |
(math-mul (math-add lo hi) '(float 5 -1)) |
(math-mul (math-add lo hi) '(float 5 -1)) |
1384 |
mode))))) |
mode))))) |
1385 |
(nth 1 integ-temp) |
(nth 1 integ-temp)) |
|
) |
|
1386 |
|
|
1387 |
|
|
1388 |
|
|
1401 |
(set (nth 2 (aref math-dummy-vars math-dummy-counter)) nil) |
(set (nth 2 (aref math-dummy-vars math-dummy-counter)) nil) |
1402 |
(prog1 |
(prog1 |
1403 |
(aref math-dummy-vars math-dummy-counter) |
(aref math-dummy-vars math-dummy-counter) |
1404 |
(setq math-dummy-counter (1+ math-dummy-counter))) |
(setq math-dummy-counter (1+ math-dummy-counter)))) |
|
) |
|
1405 |
|
|
1406 |
|
|
1407 |
|
|
1408 |
(defun calcFunc-fit (expr vars &optional coefs data) |
(defun calcFunc-fit (expr vars &optional coefs data) |
1409 |
(let ((math-in-fit 10)) |
(let ((math-in-fit 10)) |
1410 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
1411 |
(math-general-fit expr vars coefs data nil))) |
(math-general-fit expr vars coefs data nil)))) |
|
) |
|
1412 |
|
|
1413 |
(defun calcFunc-efit (expr vars &optional coefs data) |
(defun calcFunc-efit (expr vars &optional coefs data) |
1414 |
(let ((math-in-fit 10)) |
(let ((math-in-fit 10)) |
1415 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
1416 |
(math-general-fit expr vars coefs data 'sdev))) |
(math-general-fit expr vars coefs data 'sdev)))) |
|
) |
|
1417 |
|
|
1418 |
(defun calcFunc-xfit (expr vars &optional coefs data) |
(defun calcFunc-xfit (expr vars &optional coefs data) |
1419 |
(let ((math-in-fit 10)) |
(let ((math-in-fit 10)) |
1420 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
1421 |
(math-general-fit expr vars coefs data 'full))) |
(math-general-fit expr vars coefs data 'full)))) |
|
) |
|
1422 |
|
|
1423 |
(defun math-general-fit (expr vars coefs data mode) |
(defun math-general-fit (expr vars coefs data mode) |
1424 |
(let ((calc-simplify-mode nil) |
(let ((calc-simplify-mode nil) |
1706 |
(if (and have-sdevs (> n mm)) |
(if (and have-sdevs (> n mm)) |
1707 |
(list 'calcFunc-utpc chisq (- n mm)) |
(list 'calcFunc-utpc chisq (- n mm)) |
1708 |
'(var nan var-nan))) |
'(var nan var-nan))) |
1709 |
expr))) |
expr)))) |
|
) |
|
1710 |
|
|
1711 |
(setq math-in-fit 0) |
(setq math-in-fit 0) |
1712 |
(setq calc-fit-to-trail nil) |
(setq calc-fit-to-trail nil) |
1716 |
(progn |
(progn |
1717 |
(setq x (aref math-dummy-vars (+ first-var x -1))) |
(setq x (aref math-dummy-vars (+ first-var x -1))) |
1718 |
(or (calc-var-value (nth 2 x)) x)) |
(or (calc-var-value (nth 2 x)) x)) |
1719 |
(math-reject-arg x)) |
(math-reject-arg x))) |
|
) |
|
1720 |
|
|
1721 |
(defun calcFunc-fitparam (x) |
(defun calcFunc-fitparam (x) |
1722 |
(if (>= math-in-fit 2) |
(if (>= math-in-fit 2) |
1723 |
(progn |
(progn |
1724 |
(setq x (aref math-dummy-vars (+ first-coef x -1))) |
(setq x (aref math-dummy-vars (+ first-coef x -1))) |
1725 |
(or (calc-var-value (nth 2 x)) x)) |
(or (calc-var-value (nth 2 x)) x)) |
1726 |
(math-reject-arg x)) |
(math-reject-arg x))) |
|
) |
|
1727 |
|
|
1728 |
(defun calcFunc-fitdummy (x) |
(defun calcFunc-fitdummy (x) |
1729 |
(if (= math-in-fit 3) |
(if (= math-in-fit 3) |
1730 |
(nth x new-coefs) |
(nth x new-coefs) |
1731 |
(math-reject-arg x)) |
(math-reject-arg x))) |
|
) |
|
1732 |
|
|
1733 |
(defun calcFunc-hasfitvars (expr) |
(defun calcFunc-hasfitvars (expr) |
1734 |
(if (Math-primp expr) |
(if (Math-primp expr) |
1735 |
0 |
0 |
1736 |
(if (eq (car expr) 'calcFunc-fitvar) |
(if (eq (car expr) 'calcFunc-fitvar) |
1737 |
(nth 1 expr) |
(nth 1 expr) |
1738 |
(apply 'max (mapcar 'calcFunc-hasfitvars (cdr expr))))) |
(apply 'max (mapcar 'calcFunc-hasfitvars (cdr expr)))))) |
|
) |
|
1739 |
|
|
1740 |
(defun calcFunc-hasfitparams (expr) |
(defun calcFunc-hasfitparams (expr) |
1741 |
(if (Math-primp expr) |
(if (Math-primp expr) |
1742 |
0 |
0 |
1743 |
(if (eq (car expr) 'calcFunc-fitparam) |
(if (eq (car expr) 'calcFunc-fitparam) |
1744 |
(nth 1 expr) |
(nth 1 expr) |
1745 |
(apply 'max (mapcar 'calcFunc-hasfitparams (cdr expr))))) |
(apply 'max (mapcar 'calcFunc-hasfitparams (cdr expr)))))) |
|
) |
|
1746 |
|
|
1747 |
|
|
1748 |
(defun math-all-vars-but (expr but) |
(defun math-all-vars-but (expr but) |
1752 |
(setq vars (delq (assoc (car-safe p) vars) vars) |
(setq vars (delq (assoc (car-safe p) vars) vars) |
1753 |
p (cdr p))) |
p (cdr p))) |
1754 |
(sort (mapcar 'car vars) |
(sort (mapcar 'car vars) |
1755 |
(function (lambda (x y) (string< (nth 1 x) (nth 1 y)))))) |
(function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))) |
|
) |
|
1756 |
|
|
1757 |
(defun math-all-vars-in (expr) |
(defun math-all-vars-in (expr) |
1758 |
(let ((vars nil) |
(let ((vars nil) |
1759 |
found) |
found) |
1760 |
(math-all-vars-rec expr) |
(math-all-vars-rec expr) |
1761 |
vars) |
vars)) |
|
) |
|
1762 |
|
|
1763 |
(defun math-all-vars-rec (expr) |
(defun math-all-vars-rec (expr) |
1764 |
(if (Math-primp expr) |
(if (Math-primp expr) |
1768 |
(setcdr found (1+ (cdr found))) |
(setcdr found (1+ (cdr found))) |
1769 |
(setq vars (cons (cons expr 1) vars))))) |
(setq vars (cons (cons expr 1) vars))))) |
1770 |
(while (setq expr (cdr expr)) |
(while (setq expr (cdr expr)) |
1771 |
(math-all-vars-rec (car expr)))) |
(math-all-vars-rec (car expr))))) |
|
) |
|
|
|
|
|
|
|
|
|
|
1772 |
|
|
1773 |
|
;;; calcalg3.el ends here |