diff options
Diffstat (limited to 'lisp/calc')
| -rw-r--r-- | lisp/calc/README | 11 | ||||
| -rw-r--r-- | lisp/calc/calc-aent.el | 293 | ||||
| -rw-r--r-- | lisp/calc/calc-bin.el | 58 | ||||
| -rw-r--r-- | lisp/calc/calc-comb.el | 74 | ||||
| -rw-r--r-- | lisp/calc/calc-embed.el | 6 | ||||
| -rw-r--r-- | lisp/calc/calc-ext.el | 170 | ||||
| -rw-r--r-- | lisp/calc/calc-forms.el | 169 | ||||
| -rw-r--r-- | lisp/calc/calc-funcs.el | 228 | ||||
| -rw-r--r-- | lisp/calc/calc-graph.el | 74 | ||||
| -rw-r--r-- | lisp/calc/calc-help.el | 98 | ||||
| -rw-r--r-- | lisp/calc/calc-lang.el | 1191 | ||||
| -rw-r--r-- | lisp/calc/calc-macs.el | 10 | ||||
| -rw-r--r-- | lisp/calc/calc-math.el | 133 | ||||
| -rw-r--r-- | lisp/calc/calc-menu.el | 1429 | ||||
| -rw-r--r-- | lisp/calc/calc-misc.el | 37 | ||||
| -rw-r--r-- | lisp/calc/calc-mode.el | 6 | ||||
| -rw-r--r-- | lisp/calc/calc-nlfit.el | 823 | ||||
| -rw-r--r-- | lisp/calc/calc-poly.el | 6 | ||||
| -rw-r--r-- | lisp/calc/calc-prog.el | 7 | ||||
| -rw-r--r-- | lisp/calc/calc-store.el | 32 | ||||
| -rw-r--r-- | lisp/calc/calc-stuff.el | 2 | ||||
| -rw-r--r-- | lisp/calc/calc-units.el | 349 | ||||
| -rw-r--r-- | lisp/calc/calc-vec.el | 4 | ||||
| -rw-r--r-- | lisp/calc/calc-yank.el | 2 | ||||
| -rw-r--r-- | lisp/calc/calc.el | 636 | ||||
| -rw-r--r-- | lisp/calc/calcalg2.el | 4 | ||||
| -rw-r--r-- | lisp/calc/calcalg3.el | 230 | ||||
| -rw-r--r-- | lisp/calc/calccomp.el | 304 |
28 files changed, 5170 insertions, 1216 deletions
diff --git a/lisp/calc/README b/lisp/calc/README index 5d250387a00..3366a0b6b3c 100644 --- a/lisp/calc/README +++ b/lisp/calc/README @@ -72,6 +72,17 @@ opinions. Summary of changes to "Calc" ------- -- ------- -- ---- +* Added support for Yacas, Maxima and Giac languages. + +* Added a menu. + +* Added logistic non-linear curves to curve-fitting. + +* Added option of plotting data points and curve when curve-fitting. + +* Made unit conversions exact when possible. + +* Lower the precedence of negation. Version 2.1: diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index af57453816a..fefe99c987b 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -32,6 +32,25 @@ (require 'calc) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-refresh-evaltos "calc-ext" (&optional which-var)) +(declare-function calc-execute-kbd-macro "calc-prog" (mac arg &rest prefix)) +(declare-function math-is-true "calc-ext" (expr)) +(declare-function calc-explain-why "calc-stuff" (why &optional more)) +(declare-function calc-alg-edit "calc-yank" (str)) +(declare-function math-composite-inequalities "calc-prog" (x op)) +(declare-function math-flatten-lands "calc-rewr" (expr)) +(declare-function math-multi-subst "calc-map" (expr olds news)) +(declare-function calcFunc-vmatches "calc-rewr" (expr pat)) +(declare-function math-simplify "calc-alg" (top-expr)) +(declare-function math-known-matrixp "calc-arith" (a)) +(declare-function math-parse-fortran-subscr "calc-lang" (sym args)) +(declare-function math-to-radians-2 "calc-math" (a)) +(declare-function math-read-string "calc-ext" ()) +(declare-function math-read-brackets "calc-vec" (space-sep math-rb-close)) +(declare-function math-read-angle-brackets "calc-forms" ()) +(declare-function math-to-percentsigns "calccomp" (x)) + (defvar calc-quick-calc-history nil "The history list for quick-calc.") @@ -74,6 +93,9 @@ ", " (let ((calc-number-radix 8)) (math-format-value (car alg-exp) 1000)) + ", " + (let ((calc-number-radix 2)) + (math-format-value (car alg-exp) 1000)) (if (and (integerp (car alg-exp)) (> (car alg-exp) 0) (< (car alg-exp) 127)) @@ -100,7 +122,7 @@ (cond ((and (consp str) (not (symbolp (car str)))) (let ((calc-language nil) - (math-expr-opers math-standard-opers) + (math-expr-opers (math-standard-ops)) (calc-internal-prec 12) (calc-word-size 32) (calc-symbolic-mode nil) @@ -254,7 +276,7 @@ The value t means abort and give an error message.") (interactive "P") (calc-wrapper (let ((calc-language (if prefix nil calc-language)) - (math-expr-opers (if prefix math-standard-opers math-expr-opers))) + (math-expr-opers (if prefix (math-standard-ops) (math-expr-ops)))) (calc-alg-entry (and auto (char-to-string last-command-char)))))) (defvar calc-alg-entry-history nil @@ -573,10 +595,14 @@ in Calc algebraic input.") (math-exp-keep-spaces nil) math-exp-token math-expr-data) (setq math-exp-str (math-read-preprocess-string math-exp-str)) + (if (memq calc-language calc-lang-allow-percentsigns) + (setq math-exp-str (math-remove-percentsigns math-exp-str))) (if calc-language-input-filter (setq math-exp-str (funcall calc-language-input-filter math-exp-str))) - (while (setq math-exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" math-exp-str)) - (setq math-exp-str (concat (substring math-exp-str 0 math-exp-token) "\\dots" + (while (setq math-exp-token + (string-match "\\.\\.\\([^.]\\|.[^.]\\)" math-exp-str)) + (setq math-exp-str + (concat (substring math-exp-str 0 math-exp-token) "\\dots" (substring math-exp-str (+ math-exp-token 2))))) (math-build-parse-table) (math-read-token) @@ -600,6 +626,7 @@ in Calc algebraic input.") (defvar calc-user-parse-table nil) (defvar calc-last-main-parse-table nil) +(defvar calc-last-user-lang-parse-table nil) (defvar calc-last-lang-parse-table nil) (defvar calc-user-tokens nil) (defvar calc-user-token-chars nil) @@ -609,10 +636,12 @@ in Calc algebraic input.") (defun math-build-parse-table () (let ((mtab (cdr (assq nil calc-user-parse-tables))) - (ltab (cdr (assq calc-language calc-user-parse-tables)))) + (ltab (cdr (assq calc-language calc-user-parse-tables))) + (lltab (get calc-language 'math-parse-table))) (or (and (eq mtab calc-last-main-parse-table) - (eq ltab calc-last-lang-parse-table)) - (let ((p (append mtab ltab)) + (eq ltab calc-last-user-lang-parse-table) + (eq lltab calc-last-lang-parse-table)) + (let ((p (append mtab ltab lltab)) (math-toks nil)) (setq calc-user-parse-table p) (setq calc-user-token-chars nil) @@ -626,7 +655,8 @@ in Calc algebraic input.") (length y))))) "\\|") calc-last-main-parse-table mtab - calc-last-lang-parse-table ltab))))) + calc-last-user-lang-parse-table ltab + calc-last-lang-parse-table lltab))))) (defun math-find-user-tokens (p) (while p @@ -657,7 +687,8 @@ in Calc algebraic input.") (setq math-exp-old-pos math-exp-pos math-exp-token 'end math-expr-data "\000") - (let ((ch (aref math-exp-str math-exp-pos))) + (let (adfn + (ch (aref math-exp-str math-exp-pos))) (setq math-exp-old-pos math-exp-pos) (cond ((memq ch '(32 10 9)) (setq math-exp-pos (1+ math-exp-pos)) @@ -667,37 +698,29 @@ in Calc algebraic input.") (math-read-token))) ((and (memq ch calc-user-token-chars) (let ((case-fold-search nil)) - (eq (string-match calc-user-tokens math-exp-str math-exp-pos) + (eq (string-match + calc-user-tokens math-exp-str math-exp-pos) math-exp-pos))) (setq math-exp-token 'punc math-expr-data (math-match-substring math-exp-str 0) math-exp-pos (match-end 0))) ((or (and (>= ch ?a) (<= ch ?z)) (and (>= ch ?A) (<= ch ?Z))) - (string-match (if (memq calc-language '(c fortran pascal maple)) - "[a-zA-Z0-9_#]*" - "[a-zA-Z0-9'#]*") - math-exp-str math-exp-pos) + (string-match + (cond + ((and (memq calc-language calc-lang-allow-underscores) + (memq calc-language calc-lang-allow-percentsigns)) + "[a-zA-Z0-9_'#]*") + ((memq calc-language calc-lang-allow-underscores) + "[a-zA-Z0-9_#]*") + (t "[a-zA-Z0-9'#]*")) + math-exp-str math-exp-pos) (setq math-exp-token 'symbol math-exp-pos (match-end 0) math-expr-data (math-restore-dashes (math-match-substring math-exp-str 0))) - (if (eq calc-language 'eqn) - (let ((code (assoc math-expr-data math-eqn-ignore-words))) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((consp (nth 1 code)) - (math-read-token) - (if (assoc math-expr-data (cdr code)) - (setq math-expr-data (format "%s %s" - (car code) math-expr-data)))) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - (t - (math-read-token) - (math-read-token)))))) + (if (setq adfn (get calc-language 'math-lang-adjust-words)) + (funcall adfn))) ((or (and (>= ch ?0) (<= ch ?9)) (and (eq ch '?\.) (eq (string-match "\\.[0-9]" math-exp-str math-exp-pos) @@ -706,35 +729,31 @@ in Calc algebraic input.") (eq (string-match "_\\.?[0-9]" math-exp-str math-exp-pos) math-exp-pos) (or (eq math-exp-pos 0) - (and (memq calc-language '(nil flat big unform - tex latex eqn)) + (and (not (memq calc-language + calc-lang-allow-underscores)) (eq (string-match "[^])}\"a-zA-Z0-9'$]_" math-exp-str (1- math-exp-pos)) (1- math-exp-pos)))))) - (or (and (eq calc-language 'c) + (or (and (memq calc-language calc-lang-c-type-hex) (string-match "0[xX][0-9a-fA-F]+" math-exp-str math-exp-pos)) (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#\\|\\^\\^\\)[0-9a-zA-Z:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" math-exp-str math-exp-pos)) (setq math-exp-token 'number math-expr-data (math-match-substring math-exp-str 0) math-exp-pos (match-end 0))) + ((and (setq adfn + (assq ch (get calc-language 'math-lang-read-symbol))) + (eval (nth 1 adfn))) + (eval (nth 2 adfn))) ((eq ch ?\$) - (if (and (eq calc-language 'pascal) - (eq (string-match - "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)" - math-exp-str math-exp-pos) - math-exp-pos)) - (setq math-exp-token 'number - math-expr-data (math-match-substring math-exp-str 1) - math-exp-pos (match-end 1)) - (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) - math-exp-pos) - (setq math-expr-data (- (string-to-number (math-match-substring - math-exp-str 1)))) - (string-match "\\$+" math-exp-str math-exp-pos) - (setq math-expr-data (- (match-end 0) (match-beginning 0)))) - (setq math-exp-token 'dollar - math-exp-pos (match-end 0)))) + (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) + math-exp-pos) + (setq math-expr-data (- (string-to-number (math-match-substring + math-exp-str 1)))) + (string-match "\\$+" math-exp-str math-exp-pos) + (setq math-expr-data (- (match-end 0) (match-beginning 0)))) + (setq math-exp-token 'dollar + math-exp-pos (match-end 0))) ((eq ch ?\#) (if (eq (string-match "#\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) math-exp-pos) @@ -753,120 +772,18 @@ in Calc algebraic input.") ((and (eq ch ?\") (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" math-exp-str math-exp-pos)) - (if (eq calc-language 'eqn) - (progn - (setq math-exp-str (copy-sequence math-exp-str)) - (aset math-exp-str (match-beginning 1) ?\{) - (if (< (match-end 1) (length math-exp-str)) - (aset math-exp-str (match-end 1) ?\})) - (math-read-token)) - (setq math-exp-token 'string - math-expr-data (math-match-substring math-exp-str 1) - math-exp-pos (match-end 0)))) - ((and (= ch ?\\) (eq calc-language 'tex) - (< math-exp-pos (1- (length math-exp-str)))) - (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" - math-exp-str math-exp-pos) - (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" - math-exp-str math-exp-pos)) - (setq math-exp-token 'symbol - math-exp-pos (match-end 0) - math-expr-data (math-restore-dashes - (math-match-substring math-exp-str 1))) - (let ((code (assoc math-expr-data math-latex-ignore-words))) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - ((and (eq (nth 1 code) 'mat) - (string-match " *{" math-exp-str math-exp-pos)) - (setq math-exp-pos (match-end 0) - math-exp-token 'punc - math-expr-data "[") - (let ((right (string-match "}" math-exp-str math-exp-pos))) - (and right - (setq math-exp-str (copy-sequence math-exp-str)) - (aset math-exp-str right ?\]))))))) - ((and (= ch ?\\) (eq calc-language 'latex) - (< math-exp-pos (1- (length math-exp-str)))) - (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" - math-exp-str math-exp-pos) - (string-match "\\\\text *{\\([a-zA-Z0-9]+\\)}" - math-exp-str math-exp-pos) - (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" - math-exp-str math-exp-pos)) - (setq math-exp-token 'symbol - math-exp-pos (match-end 0) - math-expr-data (math-restore-dashes - (math-match-substring math-exp-str 1))) - (let ((code (assoc math-expr-data math-tex-ignore-words)) - envname) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - ((and (eq (nth 1 code) 'begenv) - (string-match " *{\\([^}]*\\)}" math-exp-str math-exp-pos)) - (setq math-exp-pos (match-end 0) - envname (match-string 1 math-exp-str) - math-exp-token 'punc - math-expr-data "[") - (cond ((or (string= envname "matrix") - (string= envname "bmatrix") - (string= envname "smallmatrix") - (string= envname "pmatrix")) - (if (string-match (concat "\\\\end{" envname "}") - math-exp-str math-exp-pos) - (setq math-exp-str - (replace-match "]" t t math-exp-str)) - (error "%s" (concat "No closing \\end{" envname "}")))))) - ((and (eq (nth 1 code) 'mat) - (string-match " *{" math-exp-str math-exp-pos)) - (setq math-exp-pos (match-end 0) - math-exp-token 'punc - math-expr-data "[") - (let ((right (string-match "}" math-exp-str math-exp-pos))) - (and right - (setq math-exp-str (copy-sequence math-exp-str)) - (aset math-exp-str right ?\]))))))) - ((and (= ch ?\.) (eq calc-language 'fortran) - (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\." - math-exp-str math-exp-pos) math-exp-pos)) - (setq math-exp-token 'punc - math-expr-data (upcase (math-match-substring math-exp-str 0)) - math-exp-pos (match-end 0))) - ((and (eq calc-language 'math) - (eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos) - math-exp-pos)) - (setq math-exp-token 'punc - math-expr-data (math-match-substring math-exp-str 0) - math-exp-pos (match-end 0))) - ((and (eq calc-language 'eqn) - (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^" - math-exp-str math-exp-pos) - math-exp-pos)) - (setq math-exp-token 'punc - math-expr-data (math-match-substring math-exp-str 0) - math-exp-pos (match-end 0)) - (and (eq (string-match "\\\\dots\\." math-exp-str math-exp-pos) - math-exp-pos) - (setq math-exp-pos (match-end 0))) - (if (memq (aref math-expr-data 0) '(?~ ?^)) - (math-read-token))) + (setq math-exp-token 'string + math-expr-data (math-match-substring math-exp-str 1) + math-exp-pos (match-end 0))) + ((and (setq adfn (get calc-language 'math-lang-read)) + (eval (nth 0 adfn)) + (eval (nth 1 adfn)))) ((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos) (setq math-exp-pos (match-end 0)) (math-read-token)) (t - (if (and (eq ch ?\{) (memq calc-language '(tex latex eqn))) - (setq ch ?\()) - (if (and (eq ch ?\}) (memq calc-language '(tex latex eqn))) - (setq ch ?\))) - (if (and (eq ch ?\&) (memq calc-language '(tex latex))) - (setq ch ?\,)) + (if (setq adfn (assq ch (get calc-language 'math-punc-table))) + (setq ch (cdr adfn))) (setq math-exp-token 'punc math-expr-data (char-to-string ch) math-exp-pos (1+ math-exp-pos))))))) @@ -876,7 +793,10 @@ in Calc algebraic input.") calcFunc-eq calcFunc-neq)) (defun math-read-expr-level (exp-prec &optional exp-term) - (let* ((x (math-read-factor)) (first t) op op2) + (let* ((math-expr-opers (math-expr-ops)) + (x (math-read-factor)) + (first t) + op op2) (while (and (or (and calc-user-parse-table (setq op (calc-check-user-syntax x exp-prec)) (setq x op @@ -896,7 +816,9 @@ in Calc algebraic input.") (memq math-exp-token '(symbol number dollar hash)) (equal math-expr-data "(") (and (equal math-expr-data "[") - (not (eq calc-language 'math)) + (not (equal + (get calc-language + 'math-function-open) "[")) (not (and math-exp-keep-spaces (eq (car-safe x) 'vec))))) (or (not (setq op (assoc math-expr-data math-expr-opers))) @@ -1097,12 +1019,39 @@ in Calc algebraic input.") (concat (math-match-substring x 1) "#" (math-match-substring x 2))) x)) +(defun math-remove-percentsigns (x) + (if (string-match "\\`\\(.*\\)%\\(.*\\)\\'" x) + (math-remove-percentsigns + (concat (math-match-substring x 1) "o'o" (math-match-substring x 2))) + x)) + (defun math-restore-dashes (x) (if (string-match "\\`\\(.*\\)[#_]\\(.*\\)\\'" x) (math-restore-dashes (concat (math-match-substring x 1) "-" (math-match-substring x 2))) x)) +(defun math-restore-placeholders (x) + "Replace placeholders by the proper characters in the symbol x. +This includes `#' for `_' and `'' for `%'. +If the current Calc language does not use placeholders, return nil." + (if (or (memq calc-language calc-lang-allow-underscores) + (memq calc-language calc-lang-allow-percentsigns)) + (let ((sx (symbol-name x))) + (when (memq calc-language calc-lang-allow-percentsigns) + (require 'calccomp) + (setq sx (math-to-percentsigns sx))) + (if (memq calc-language calc-lang-allow-underscores) + (setq sx (math-string-restore-underscores sx))) + (intern-soft sx)))) + +(defun math-string-restore-underscores (x) + "Replace pound signs by underscores in the string x." + (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x) + (math-string-restore-underscores + (concat (math-match-substring x 1) "_" (math-match-substring x 2))) + x)) + (defun math-read-if (cond op) (let ((then (math-read-expr-level 0))) (or (equal math-expr-data ":") @@ -1121,7 +1070,8 @@ in Calc algebraic input.") (assoc math-expr-data '(("(") ("[") ("{")))))) (defun math-read-factor () - (let (op) + (let ((math-expr-opers (math-expr-ops)) + op) (cond ((eq math-exp-token 'number) (let ((num (math-read-number math-expr-data))) (if (not num) @@ -1171,7 +1121,9 @@ in Calc algebraic input.") (eq math-exp-token 'end))) (throw 'syntax "Expected `)'")) (math-read-token) - (if (and (eq calc-language 'fortran) args + (if (and (memq calc-language + calc-lang-parens-are-subscripts) + args (require 'calc-ext) (let ((calc-matrix-mode 'scalar)) (math-known-matrixp @@ -1201,7 +1153,10 @@ in Calc algebraic input.") sym (intern (concat "var-" (symbol-name sym))))))) - (let ((v (assq (nth 1 val) math-expr-variable-mapping))) + (let ((v (or + (assq (nth 1 val) math-expr-variable-mapping) + (assq (math-restore-placeholders (nth 1 val)) + math-expr-variable-mapping)))) (and v (setq val (if (consp (cdr v)) (funcall (car (cdr v)) v val) (list 'var @@ -1209,11 +1164,15 @@ in Calc algebraic input.") (substring (symbol-name (cdr v)) 4)) (cdr v)))))) - (while (and (memq calc-language '(c pascal maple)) + (while (and (memq calc-language + calc-lang-brackets-are-subscripts) (equal math-expr-data "[")) (math-read-token) - (setq val (append (list 'calcFunc-subscr val) - (math-read-expr-list))) + (let ((el (math-read-expr-list))) + (while el + (setq val (append (list 'calcFunc-subscr val) + (list (car el)))) + (setq el (cdr el)))) (if (equal math-expr-data "]") (math-read-token) (throw 'syntax "Expected ']'"))) diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el index bf40ca6ef47..537c0e1be45 100644 --- a/lisp/calc/calc-bin.el +++ b/lisp/calc/calc-bin.el @@ -32,6 +32,17 @@ (require 'calc-ext) (require 'calc-macs) +;;; Some useful numbers +(defconst math-bignum-logb-digit-size + (logb math-bignum-digit-size) + "The logb of the size of a bignum digit. +This is the largest value of B such that 2^B is less than +the size of a Calc bignum digit.") + +(defconst math-bignum-digit-power-of-two + (expt 2 (logb math-bignum-digit-size)) + "The largest power of 2 less than the size of a Calc bignum digit.") + ;;; b-prefix binary commands. (defun calc-and (n) @@ -297,11 +308,11 @@ (defun math-and-bignum (a b) ; [l l l] (and a b - (let ((qa (math-div-bignum-digit a 512)) - (qb (math-div-bignum-digit b 512))) + (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) + (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa)) (math-norm-bignum (car qb))) - 512 + math-bignum-digit-power-of-two (logand (cdr qa) (cdr qb)))))) (defun calcFunc-or (a b &optional w) ; [I I I] [Public] @@ -324,11 +335,11 @@ (defun math-or-bignum (a b) ; [l l l] (and (or a b) - (let ((qa (math-div-bignum-digit a 512)) - (qb (math-div-bignum-digit b 512))) + (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) + (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa)) (math-norm-bignum (car qb))) - 512 + math-bignum-digit-power-of-two (logior (cdr qa) (cdr qb)))))) (defun calcFunc-xor (a b &optional w) ; [I I I] [Public] @@ -351,11 +362,11 @@ (defun math-xor-bignum (a b) ; [l l l] (and (or a b) - (let ((qa (math-div-bignum-digit a 512)) - (qb (math-div-bignum-digit b 512))) + (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) + (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa)) (math-norm-bignum (car qb))) - 512 + math-bignum-digit-power-of-two (logxor (cdr qa) (cdr qb)))))) (defun calcFunc-diff (a b &optional w) ; [I I I] [Public] @@ -378,11 +389,11 @@ (defun math-diff-bignum (a b) ; [l l l] (and a - (let ((qa (math-div-bignum-digit a 512)) - (qb (math-div-bignum-digit b 512))) + (let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two)) + (qb (math-div-bignum-digit b math-bignum-digit-power-of-two))) (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa)) (math-norm-bignum (car qb))) - 512 + math-bignum-digit-power-of-two (logand (cdr qa) (lognot (cdr qb))))))) (defun calcFunc-not (a &optional w) ; [I I] [Public] @@ -402,14 +413,15 @@ w)))))) (defun math-not-bignum (a w) ; [l l] - (let ((q (math-div-bignum-digit a 512))) - (if (<= w 9) + (let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two))) + (if (<= w math-bignum-logb-digit-size) (list (logand (lognot (cdr q)) (1- (lsh 1 w)))) (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q)) - (- w 9)) - 512 - (logxor (cdr q) 511))))) + (- w math-bignum-logb-digit-size)) + math-bignum-digit-power-of-two + (logxor (cdr q) + (1- math-bignum-digit-power-of-two)))))) (defun calcFunc-lsh (a &optional n w) ; [I I] [Public] (setq a (math-trunc a) @@ -510,8 +522,8 @@ (math-sub a (math-power-of-2 (- w))))) ((Math-negp a) (math-normalize (cons 'bigpos (math-binary-arg a w)))) - ((and (integerp a) (< a 1000000)) - (if (>= w 20) + ((and (integerp a) (< a math-small-integer-size)) + (if (> w (logb math-small-integer-size)) a (logand a (1- (lsh 1 w))))) (t @@ -523,13 +535,13 @@ (defalias 'calcFunc-clip 'math-clip) (defun math-clip-bignum (a w) ; [l l] - (let ((q (math-div-bignum-digit a 512))) - (if (<= w 9) + (let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two))) + (if (<= w math-bignum-logb-digit-size) (list (logand (cdr q) (1- (lsh 1 w)))) (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q)) - (- w 9)) - 512 + (- w math-bignum-logb-digit-size)) + math-bignum-digit-power-of-two (cdr q))))) (defvar math-max-digits-cache nil) diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index 9aefc7405ce..33880f38dd7 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -294,6 +294,18 @@ ;;; Factorial and related functions. +(defconst math-small-factorial-table + (vector 1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 + (math-read-number-simple "479001600") + (math-read-number-simple "6227020800") + (math-read-number-simple "87178291200") + (math-read-number-simple "1307674368000") + (math-read-number-simple "20922789888000") + (math-read-number-simple "355687428096000") + (math-read-number-simple "6402373705728000") + (math-read-number-simple "121645100408832000") + (math-read-number-simple "2432902008176640000"))) + (defun calcFunc-fact (n) ; [I I] [F F] [Public] (let (temp) (cond ((Math-integer-negp n) @@ -302,14 +314,7 @@ (math-reject-arg n 'range))) ((integerp n) (if (<= n 20) - (aref '[1 1 2 6 24 120 720 5040 40320 362880 - (bigpos 800 628 3) (bigpos 800 916 39) - (bigpos 600 1 479) (bigpos 800 20 227 6) - (bigpos 200 291 178 87) (bigpos 0 368 674 307 1) - (bigpos 0 888 789 922 20) (bigpos 0 96 428 687 355) - (bigpos 0 728 705 373 402 6) - (bigpos 0 832 408 100 645 121) - (bigpos 0 640 176 8 902 432 2)] n) + (aref math-small-factorial-table n) (math-factorial-iter (1- n) 2 1))) ((and (math-messy-integerp n) (Math-lessp n 100)) @@ -551,9 +556,9 @@ nil (if (Math-integerp var-RandSeed) (let* ((seed (math-sub 161803 var-RandSeed)) - (mj (1+ (math-mod seed '(bigpos 0 0 1)))) - (mk (1+ (math-mod (math-quotient seed '(bigpos 0 0 1)) - '(bigpos 0 0 1)))) + (mj (1+ (math-mod seed 1000000))) + (mk (1+ (math-mod (math-quotient seed 1000000) + 1000000))) (i 0)) (setq math-random-table (cons 'vec (make-list 55 mj))) (while (<= (setq i (1+ i)) 54) @@ -601,7 +606,8 @@ ;;; Avoid various pitfalls that may lurk in the built-in (random) function! ;;; Shuffling algorithm from Numerical Recipes, section 7.1. (defvar math-random-last) -(defun math-random-digit () +(defun math-random-three-digit-number () + "Return a random three digit number." (let (i) (or (and (boundp 'var-RandSeed) (eq var-RandSeed math-last-RandSeed)) (math-init-random-base)) @@ -621,17 +627,17 @@ ;;; Produce an N-digit random integer. (defun math-random-digits (n) - (cond ((<= n 6) - (math-scale-right (+ (* (math-random-digit) 1000) (math-random-digit)) - (- 6 n))) - (t (let* ((slop (% (- 900003 n) 3)) - (i (/ (+ n slop) 3)) - (digs nil)) - (while (> i 0) - (setq digs (cons (math-random-digit) digs) - i (1- i))) - (math-normalize (math-scale-right (cons 'bigpos digs) - slop)))))) + "Produce a random N digit integer." + (let* ((slop (% (- 3 (% n 3)) 3)) + (i (/ (+ n slop) 3)) + (rnum 0)) + (while (> i 0) + (setq rnum + (math-add + (math-random-three-digit-number) + (math-mul rnum 1000))) + (setq i (1- i))) + (math-normalize (math-scale-right rnum slop)))) ;;; Produce a uniformly-distributed random float 0 <= N < 1. (defun math-random-float () @@ -802,7 +808,7 @@ (error "Argument must be an integer")) ((Math-integer-negp n) '(nil)) - ((Math-natnum-lessp n '(bigpos 0 0 8)) + ((Math-natnum-lessp n 8000000) (setq n (math-fixnum n)) (let ((i -1) v) (while (and (> (% n (setq v (aref math-primes-table @@ -815,15 +821,17 @@ ((not (equal n (car math-prime-test-cache))) (cond ((= (% (nth 1 n) 2) 0) '(nil 2)) ((= (% (nth 1 n) 5) 0) '(nil 5)) - (t (let ((dig (cdr n)) (sum 0)) - (while dig - (if (cdr dig) - (setq sum (% (+ (+ sum (car dig)) - (* (nth 1 dig) 1000)) - 111111) - dig (cdr (cdr dig))) - (setq sum (% (+ sum (car dig)) 111111) - dig nil))) + (t (let ((q n) (sum 0)) + (while (not (eq q 0)) + (setq sum (% + (+ + sum + (calcFunc-mod + q 1000000)) + 111111)) + (setq q + (math-quotient + q 1000000))) (cond ((= (% sum 3) 0) '(nil 3)) ((= (% sum 7) 0) '(nil 7)) ((= (% sum 11) 0) '(nil 11)) diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index dc3221b5047..51cdd3f9174 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el @@ -254,7 +254,7 @@ (set-buffer-modified-p (buffer-modified-p)) (calc-embedded-restore-original-modes) (or calc-embedded-quiet - (message "Back to %s mode" mode-name)))) + (message "Back to %s mode" (format-mode-line mode-name))))) (t (if (buffer-name (aref calc-embedded-info 0)) @@ -403,7 +403,7 @@ (let ((val (save-excursion (set-buffer (aref info 1)) (let ((calc-language nil) - (math-expr-opers math-standard-opers)) + (math-expr-opers (math-standard-ops))) (math-read-expr str))))) (if (eq (car-safe val) 'error) (progn @@ -1374,5 +1374,5 @@ The command \\[yank] can retrieve it from there." (provide 'calc-embed) -;;; arch-tag: 1b8f311e-fba1-40d3-b8c3-1d6f68fd26fc +;; arch-tag: 1b8f311e-fba1-40d3-b8c3-1d6f68fd26fc ;;; calc-embed.el ends here diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 8c52305a46b..5e5ae8166db 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -30,6 +30,51 @@ (require 'calc) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function math-clip "calc-bin" (a &optional w)) +(declare-function math-round "calc-arith" (a &optional prec)) +(declare-function math-simplify "calc-alg" (top-expr)) +(declare-function math-simplify-extended "calc-alg" (a)) +(declare-function math-simplify-units "calc-units" (a)) +(declare-function calc-set-language "calc-lang" (lang &optional option no-refresh)) +(declare-function calc-flush-caches "calc-stuff" (&optional inhibit-msg)) +(declare-function calc-save-modes "calc-mode" ()) +(declare-function calc-embedded-modes-change "calc-embed" (vars)) +(declare-function calc-embedded-var-change "calc-embed" (var &optional buf)) +(declare-function math-mul-float "calc-arith" (a b)) +(declare-function math-arctan-raw "calc-math" (x)) +(declare-function math-sqrt-raw "calc-math" (a &optional guess)) +(declare-function math-sqrt-float "calc-math" (a &optional guess)) +(declare-function math-exp-minus-1-raw "calc-math" (x)) +(declare-function math-normalize-polar "calc-cplx" (a)) +(declare-function math-normalize-hms "calc-forms" (a)) +(declare-function math-normalize-mod "calc-forms" (a)) +(declare-function math-make-sdev "calc-forms" (x sigma)) +(declare-function math-make-intv "calc-forms" (mask lo hi)) +(declare-function math-normalize-logical-op "calc-prog" (a)) +(declare-function math-possible-signs "calc-arith" (a &optional origin)) +(declare-function math-infinite-dir "calc-math" (a &optional inf)) +(declare-function math-calcFunc-to-var "calc-map" (f)) +(declare-function calc-embedded-evaluate-expr "calc-embed" (x)) +(declare-function math-known-nonzerop "calc-arith" (a)) +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) +(declare-function math-read-big-rec "calc-lang" (math-rb-h1 math-rb-v1 math-rb-h2 math-rb-v2 &optional baseline prec short)) +(declare-function math-read-big-balance "calc-lang" (h v what &optional commas)) +(declare-function math-format-date "calc-forms" (math-fd-date)) +(declare-function math-vector-is-string "calccomp" (a)) +(declare-function math-vector-to-string "calccomp" (a &optional quoted)) +(declare-function math-format-radix-float "calc-bin" (a prec)) +(declare-function math-compose-expr "calccomp" (a prec)) +(declare-function math-abs "calc-arith" (a)) +(declare-function math-format-bignum-binary "calc-bin" (a)) +(declare-function math-format-bignum-octal "calc-bin" (a)) +(declare-function math-format-bignum-hex "calc-bin" (a)) +(declare-function math-format-bignum-radix "calc-bin" (a)) +(declare-function math-compute-max-digits "calc-bin" (w r)) +(declare-function math-map-vec "calc-vec" (f a)) +(declare-function math-make-frac "calc-frac" (num den)) + + (defvar math-simplifying nil) (defvar math-living-dangerously nil) ; true if unsafe simplifications are okay. (defvar math-integrating nil) @@ -211,6 +256,7 @@ (define-key calc-mode-map "dt" 'calc-truncate-stack) (define-key calc-mode-map "dw" 'calc-auto-why) (define-key calc-mode-map "dz" 'calc-leading-zeros) + (define-key calc-mode-map "dA" 'calc-giac-language) (define-key calc-mode-map "dB" 'calc-big-language) (define-key calc-mode-map "dD" 'calc-redo) (define-key calc-mode-map "dC" 'calc-c-language) @@ -224,6 +270,8 @@ (define-key calc-mode-map "dL" 'calc-latex-language) (define-key calc-mode-map "dU" 'calc-unformatted-language) (define-key calc-mode-map "dW" 'calc-maple-language) + (define-key calc-mode-map "dX" 'calc-maxima-language) + (define-key calc-mode-map "dY" 'calc-yacas-language) (define-key calc-mode-map "d[" 'calc-truncate-up) (define-key calc-mode-map "d]" 'calc-truncate-down) (define-key calc-mode-map "d." 'calc-point-char) @@ -618,15 +666,15 @@ (calc-init-prefixes) - (mapcar (function - (lambda (x) - (define-key calc-mode-map (format "c%c" x) 'calc-clean-num) - (define-key calc-mode-map (format "j%c" x) 'calc-select-part) - (define-key calc-mode-map (format "r%c" x) 'calc-recall-quick) - (define-key calc-mode-map (format "s%c" x) 'calc-store-quick) - (define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick) - (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))) - "0123456789") + (mapc (function + (lambda (x) + (define-key calc-mode-map (format "c%c" x) 'calc-clean-num) + (define-key calc-mode-map (format "j%c" x) 'calc-select-part) + (define-key calc-mode-map (format "r%c" x) 'calc-recall-quick) + (define-key calc-mode-map (format "s%c" x) 'calc-store-quick) + (define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick) + (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))) + "0123456789") (let ((i ?A)) (while (<= i ?z) @@ -635,7 +683,7 @@ (cons 'keymap (cons (cons ?\e (aref (nth 1 calc-mode-map) i)) (cdr (aref (nth 1 calc-mode-map) i)))))) (setq i (1+ i)))) - + (setq calc-alg-map (copy-keymap calc-mode-map) calc-alg-esc-map (copy-keymap esc-map)) (let ((i 32)) @@ -651,7 +699,7 @@ (define-key calc-alg-map "\e\177" 'calc-pop-above) ;;;; (Autoloads here) - (mapcar (function (lambda (x) + (mapc (function (lambda (x) (mapcar (function (lambda (func) (autoload func (car x)))) (cdr x)))) '( @@ -1008,6 +1056,7 @@ calc-keypad-press) ("calc-lang" calc-big-language calc-c-language calc-eqn-language calc-flat-language calc-fortran-language calc-maple-language +calc-yacas-language calc-maxima-language calc-giac-language calc-mathematica-language calc-normal-language calc-pascal-language calc-tex-language calc-latex-language calc-unformatted-language) @@ -1021,7 +1070,7 @@ calc-arctan calc-arctan2 calc-arctanh calc-conj calc-cos calc-cosh calc-cot calc-coth calc-csc calc-csch calc-degrees-mode calc-exp calc-expm1 calc-hypot calc-ilog calc-imaginary calc-isqrt calc-ln calc-lnp1 calc-log calc-log10 -calc-pi calc-radians-mode calc-sec calc-sech +calc-pi calc-radians-mode calc-sec calc-sech calc-sin calc-sincos calc-sinh calc-sqrt calc-tan calc-tanh calc-to-degrees calc-to-radians) @@ -1277,7 +1326,7 @@ calc-kill calc-kill-region calc-yank)))) calc-redo-list nil) (let (calc-stack calc-user-parse-tables calc-standard-date-formats calc-invocation-macro) - (mapcar (function (lambda (v) (set v nil))) calc-local-var-list) + (mapc (function (lambda (v) (set v nil))) calc-local-var-list) (if (and arg (<= arg 0)) (calc-mode-var-list-restore-default-values) (calc-mode-var-list-restore-saved-values))) @@ -1357,7 +1406,7 @@ calc-kill calc-kill-region calc-yank)))) (with-current-buffer calc-main-buffer calc-hyperbolic-flag) calc-hyperbolic-flag)) - (msg (if hyp-flag + (msg (if hyp-flag "Inverse Hyperbolic..." "Inverse..."))) (calc-fancy-prefix 'calc-inverse-flag msg n))) @@ -1389,7 +1438,7 @@ calc-kill calc-kill-region calc-yank)))) (calc-set-command-flag 'no-align) (setq prefix (set flag (not (symbol-value flag))) prefix-arg n) - (message (if prefix msg ""))) + (message "%s" (if prefix msg ""))) (and prefix (not calc-is-keypad-press) (if (boundp 'overriding-terminal-local-map) @@ -1438,7 +1487,7 @@ calc-kill calc-kill-region calc-yank)))) (with-current-buffer calc-main-buffer calc-inverse-flag) calc-inverse-flag)) - (msg (if inv-flag + (msg (if inv-flag "Inverse Hyperbolic..." "Hyperbolic..."))) (calc-fancy-prefix 'calc-hyperbolic-flag msg n))) @@ -1782,8 +1831,8 @@ calc-kill calc-kill-region calc-yank)))) ;;; User menu. (defun calc-user-key-map () - (if calc-emacs-type-lucid - (error "User-defined keys are not supported in Lucid Emacs")) + (if (featurep 'xemacs) + (error "User-defined keys are not supported in XEmacs")) (let ((res (cdr (lookup-key calc-mode-map "z")))) (if (eq (car (car res)) 27) (cdr res) @@ -1849,7 +1898,7 @@ calc-kill calc-kill-region calc-yank)))) (setq calc-z-prefix-buf (concat (if (= flags 1) "SHIFT + " "") desc)) (if (> (+ (length calc-z-prefix-buf) (length desc)) 58) - (setq calc-z-prefix-msgs + (setq calc-z-prefix-msgs (cons calc-z-prefix-buf calc-z-prefix-msgs) calc-z-prefix-buf (concat (if (= flags 1) "SHIFT + " "") desc)) @@ -1878,8 +1927,19 @@ calc-kill calc-kill-region calc-yank)))) (last-prec (intern (concat (symbol-name name) "-last-prec"))) (last-val (intern (concat (symbol-name name) "-last")))) (list 'progn - (list 'defvar cache-prec (if init (math-numdigs (nth 1 init)) -100)) - (list 'defvar cache-val (list 'quote init)) +; (list 'defvar cache-prec (if init (math-numdigs (nth 1 init)) -100)) + (list 'defvar cache-prec + `(cond + ((consp ,init) (math-numdigs (nth 1 ,init))) + (,init + (nth 1 (math-numdigs (eval ,init)))) + (t + -100))) + (list 'defvar cache-val + `(cond + ((consp ,init) ,init) + (,init (eval ,init)) + (t ,init))) (list 'defvar last-prec -100) (list 'defvar last-val nil) (list 'setq 'math-cache-list @@ -1914,7 +1974,11 @@ calc-kill calc-kill-region calc-yank)))) (put 'math-defcache 'lisp-indent-hook 2) ;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] -(math-defcache math-pi (float (bigpos 463 238 793 589 653 592 141 3) -21) +(defconst math-approx-pi + (math-read-number-simple "3.141592653589793238463") + "An approximation for pi.") + +(math-defcache math-pi math-approx-pi (math-add-float (math-mul-float '(float 16 0) (math-arctan-raw '(float 2 -1))) (math-mul-float '(float -4 0) @@ -1945,7 +2009,11 @@ calc-kill calc-kill-region calc-yank)))) (math-defcache math-sqrt-two-pi nil (math-sqrt-float (math-two-pi))) -(math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21) +(defconst math-approx-sqrt-e + (math-read-number-simple "1.648721270700128146849") + "An approximation for sqrt(3).") + +(math-defcache math-sqrt-e math-approx-sqrt-e (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1)))) (math-defcache math-e nil @@ -1955,10 +2023,13 @@ calc-kill calc-kill-region calc-yank)))) (math-mul-float (math-add-float (math-sqrt-raw '(float 5 0)) '(float 1 0)) '(float 5 -1))) +(defconst math-approx-gamma-const + (math-read-number-simple + "0.5772156649015328606065120900824024310421593359399235988057672348848677267776646709369470632917467495") + "An approximation for gamma.") + (math-defcache math-gamma-const nil - '(float (bigpos 495 467 917 632 470 369 709 646 776 267 677 848 348 672 - 057 988 235 399 359 593 421 310 024 824 900 120 065 606 - 328 015 649 156 772 5) -100)) + math-approx-gamma-const) (defun math-half-circle (symb) (if (eq calc-angle-mode 'rad) @@ -2068,7 +2139,7 @@ calc-kill calc-kill-region calc-yank)))) ;;; True if A is a real or will evaluate to a real. [P x] [Public] (defun math-provably-realp (a) (or (Math-realp a) - (math-provably-integer a) + (math-provably-integerp a) (memq (car-safe a) '(abs arg)))) ;;; True if A is a non-real, complex number. [P x] [Public] @@ -2126,12 +2197,12 @@ calc-kill calc-kill-region calc-yank)))) (unless a (setq a 1)) (and - (not (memq nil (mapcar + (not (memq nil (mapcar (lambda (x) (eq x 0)) (nthcdr (1+ n) row)))) - (not (memq nil (mapcar + (not (memq nil (mapcar (lambda (x) (eq x 0)) - (butlast + (butlast (cdr row) (- (length row) n))))) (eq (elt row n) a))) @@ -2189,6 +2260,25 @@ calc-kill calc-kill-region calc-yank)))) a (math-reject-arg a 'constp))) +;;; Some functions for working with error forms. +(defun math-get-value (x) + "Get the mean value of the error form X. +If X is not an error form, return X." + (if (eq (car-safe x) 'sdev) + (nth 1 x) + x)) + +(defun math-get-sdev (x &optional one) + "Get the standard deviation of the error form X. +If X is not an error form, return 1." + (if (eq (car-safe x) 'sdev) + (nth 2 x) + (if one 1 0))) + +(defun math-contains-sdev-p (ls) + "Non-nil if the list LS contains an error form." + (let ((ls (if (eq (car-safe ls) 'vec) (cdr ls) ls))) + (memq t (mapcar (lambda (x) (eq (car-safe x) 'sdev)) ls)))) ;;; Coerce integer A to be a small integer. [S I] (defun math-fixnum (a) @@ -2202,7 +2292,7 @@ calc-kill calc-kill-region calc-yank)))) (defun math-fixnum-big (a) (if (cdr a) - (+ (car a) (* (math-fixnum-big (cdr a)) 1000)) + (+ (car a) (* (math-fixnum-big (cdr a)) math-bignum-digit-size)) (car a))) (defvar math-simplify-only nil) @@ -2290,15 +2380,15 @@ calc-kill calc-kill-region calc-yank)))) (and (symbolp (car math-normalize-a)) (or (eq calc-simplify-mode 'none) (and (eq calc-simplify-mode 'num) - (let ((aptr (setq math-normalize-a + (let ((aptr (setq math-normalize-a (cons (car math-normalize-a) - (mapcar 'math-normalize + (mapcar 'math-normalize (cdr math-normalize-a)))))) (while (and aptr (math-constp (car aptr))) (setq aptr (cdr aptr))) aptr))) - (cons (car math-normalize-a) + (cons (car math-normalize-a) (mapcar 'math-normalize (cdr math-normalize-a)))))) @@ -2679,8 +2769,8 @@ calc-kill calc-kill-region calc-yank)))) (setq mmt-nextval (funcall math-mt-func mmt-expr)) (not (equal mmt-expr mmt-nextval))) (setq mmt-expr mmt-nextval - math-mt-many (if (> math-mt-many 0) - (1- math-mt-many) + math-mt-many (if (> math-mt-many 0) + (1- math-mt-many) (1+ math-mt-many)))) (if (or (Math-primp mmt-expr) (<= math-mt-many 0)) @@ -2960,7 +3050,7 @@ calc-kill calc-kill-region calc-yank)))) (defun math-read-plain-expr (exp-str &optional error-check) (let* ((calc-language nil) - (math-expr-opers math-standard-opers) + (math-expr-opers (math-standard-ops)) (val (math-read-expr exp-str))) (and error-check (eq (car-safe val) 'error) @@ -3005,10 +3095,10 @@ calc-kill calc-kill-region calc-yank)))) math-read-big-baseline math-read-big-h2 new-pos p) (while (setq new-pos (string-match "\n" str pos)) - (setq math-read-big-lines + (setq math-read-big-lines (cons (substring str pos new-pos) math-read-big-lines) pos (1+ new-pos))) - (setq math-read-big-lines + (setq math-read-big-lines (nreverse (cons (substring str pos) math-read-big-lines)) p math-read-big-lines) (while p @@ -3116,7 +3206,7 @@ calc-kill calc-kill-region calc-yank)))) (concat (substring (symbol-name (car a)) 9) "(" (math-vector-to-string (nth 1 a) t) ")")) (t - (let ((op (math-assq2 (car a) math-standard-opers))) + (let ((op (math-assq2 (car a) (math-standard-ops)))) (cond ((and op (= (length a) 3)) (if (> prec (min (nth 2 op) (nth 3 op))) (concat "(" (math-format-flat-expr a 0) ")") diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index cc0bfde8ffe..086e083c4de 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -32,6 +32,12 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calendar-current-time-zone "cal-dst" ()) +(declare-function calendar-absolute-from-gregorian "calendar" (date)) +(declare-function dst-in-effect "cal-dst" (date)) + + (defun calc-time () (interactive) (calc-wrapper @@ -544,6 +550,14 @@ (setcdr math-fd-dt nil)) fmt)))) +(defconst math-julian-date-beginning '(float 17214235 -1) + "The beginning of the Julian calendar, +as measured in the number of days before January 1 of the year 1AD.") + +(defconst math-julian-date-beginning-int 1721424 + "The beginning of the Julian calendar, +as measured in the integer number of days before January 1 of the year 1AD.") + (defun math-format-date-part (x) (cond ((stringp x) x) @@ -558,9 +572,12 @@ ((eq x 'n) (math-format-number (math-floor math-fd-date))) ((eq x 'J) - (math-format-number (math-add math-fd-date '(float (bigpos 235 214 17) -1)))) + (math-format-number + (math-add math-fd-date math-julian-date-beginning))) ((eq x 'j) - (math-format-number (math-add (math-floor math-fd-date) '(bigpos 424 721 1)))) + (math-format-number (math-add + (math-floor math-fd-date) + math-julian-date-beginning-int))) ((eq x 'U) (math-format-number (nth 1 (math-date-parts math-fd-date 719164)))) ((progn @@ -935,9 +952,8 @@ 0 (if (or (eq this 'j) (math-integerp num)) - '(bigpos 424 721 1) - '(float (bigpos 235 214 17) - -1)))) + math-julian-date-beginning-int + math-julian-date-beginning))) hour (or (nth 3 num) hour) minute (or (nth 4 num) minute) second (or (nth 5 num) second) @@ -1146,14 +1162,14 @@ (defun calcFunc-julian (date &optional zone) (if (math-realp date) (list 'date (if (math-integerp date) - (math-sub date '(bigpos 424 721 1)) - (setq date (math-sub date '(float (bigpos 235 214 17) -1))) + (math-sub date math-julian-date-beginning-int) + (setq date (math-sub date math-julian-date-beginning)) (math-sub date (math-div (calcFunc-tzone zone date) '(float 864 2))))) (if (eq (car date) 'date) (math-add (nth 1 date) (if (math-integerp (nth 1 date)) - '(bigpos 424 721 1) - (math-add '(float (bigpos 235 214 17) -1) + math-julian-date-beginning-int + (math-add math-julian-date-beginning (math-div (calcFunc-tzone zone date) '(float 864 2))))) (math-reject-arg date 'datep)))) @@ -1191,7 +1207,29 @@ ) "No doc yet. See calc manual for now. ") -(defvar var-TimeZone) +(defvar var-TimeZone nil) + +;; From cal-dst +(defvar calendar-current-time-zone-cache) + +(defvar math-calendar-tzinfo + nil + "Information about the timezone, retrieved from the calendar.") + +(defun math-get-calendar-tzinfo () + "Get information about the timezone from the calendar. +The result should be a list of two items about the current time zone: +first, the number of seconds difference from GMT +second, the number of seconds offset for daylight savings." + (if math-calendar-tzinfo + math-calendar-tzinfo + (require 'cal-dst) + (let ((tzinfo (progn + (calendar-current-time-zone) + calendar-current-time-zone-cache))) + (setq math-calendar-tzinfo + (list (* 60 (abs (nth 0 tzinfo))) + (* 60 (nth 1 tzinfo))))))) (defun calcFunc-tzone (&optional zone date) (if zone @@ -1223,53 +1261,9 @@ (t (math-reject-arg zone "*Expected a time zone"))) (if (calc-var-value 'var-TimeZone) (calcFunc-tzone (calc-var-value 'var-TimeZone) date) - (let ((p math-tzone-names) - (offset 0) - (tz '(var error var-error))) - (save-excursion - (set-buffer (get-buffer-create " *Calc Temporary*")) - (erase-buffer) - (call-process "date" nil t) - (goto-char 1) - (let ((case-fold-search t)) - (while (and p (not (search-forward (car (car p)) nil t))) - (setq p (cdr p)))) - (if (looking-at "\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)") - (setq offset (math-add - (string-to-number (buffer-substring - (match-beginning 1) - (match-end 1))) - (if (match-beginning 2) - (math-div (string-to-number (buffer-substring - (match-beginning 2) - (match-end 2))) - 60) - 0))))) - (if p - (progn - (setq p (car p)) - ;; Try to convert to a generalized time zone. - (if (integerp (nth 2 p)) - (let ((gen math-tzone-names)) - (while (and gen - (not (equal (nth 2 (car gen)) (car p))) - (not (equal (nth 3 (car gen)) (car p))) - (not (equal (nth 4 (car gen)) (car p))) - (not (equal (nth 5 (car gen)) (car p)))) - (setq gen (cdr gen))) - (and gen - (setq gen (car gen)) - (equal (math-daylight-savings-adjust nil (car gen)) - (nth 2 p)) - (setq p gen)))) - (setq tz (math-add (list 'var - (intern (car p)) - (intern (concat "var-" (car p)))) - offset)))) - (kill-buffer " *Calc Temporary*") - (setq var-TimeZone tz) - (calc-refresh-evaltos 'var-TimeZone) - (calcFunc-tzone tz date))))) + (let ((tzinfo (math-get-calendar-tzinfo))) + (+ (nth 0 tzinfo) + (* (math-cal-daylight-savings-adjust date) (nth 1 tzinfo))))))) (defvar math-daylight-savings-hook 'math-std-daylight-savings) @@ -1290,21 +1284,60 @@ (and math-daylight-savings-hook (funcall math-daylight-savings-hook date dt zone bump)))) +;;; Based on part of dst-adjust-time in cal-dst.el +;;; For calcFunc-dst, when zone=nil +(defun math-cal-daylight-savings-adjust (date) + "Return -1 if DATE is using daylight saving, 0 otherwise." + (require 'cal-dst) + (unless date (setq date (calcFunc-now))) + (let* ((dt (math-date-to-dt date)) + (time (cond + ((nth 3 dt) + (nth 3 dt)) + ((nth 4 dt) + (+ (nth 3 dt) (/ (nth 4 dt) 60.0))) + (t + 0))) + (rounded-abs-date + (+ + (calendar-absolute-from-gregorian + (list (nth 1 dt) (nth 2 dt) (nth 0 dt))) + (/ (round (* 60 time)) 60.0 24.0)))) + (if (dst-in-effect rounded-abs-date) + -1 + 0))) + (defun calcFunc-dsadj (date &optional zone) (if zone (or (eq (car-safe zone) 'var) (math-reject-arg zone "*Time zone variable expected")) - (setq zone (or (calc-var-value 'var-TimeZone) - (progn - (calcFunc-tzone) - (calc-var-value 'var-TimeZone))))) - (setq zone (and (eq (car-safe zone) 'var) - (upcase (symbol-name (nth 1 zone))))) - (let ((zadj (assoc zone math-tzone-names))) - (or zadj (math-reject-arg zone "*Unrecognized time zone name")) - (if (integerp (nth 2 zadj)) - (nth 2 zadj) - (math-daylight-savings-adjust date zone)))) + (setq zone (calc-var-value 'var-TimeZone))) + (if zone + (progn + (setq zone (and (eq (car-safe zone) 'var) + (upcase (symbol-name (nth 1 zone))))) + (let ((zadj (assoc zone math-tzone-names))) + (or zadj (math-reject-arg zone "*Unrecognized time zone name")) + (if (integerp (nth 2 zadj)) + (nth 2 zadj) + (math-daylight-savings-adjust date zone)))) + (math-cal-daylight-savings-adjust date))) + +;; (defun calcFunc-dsadj (date &optional zone) +;; (if zone +;; (or (eq (car-safe zone) 'var) +;; (math-reject-arg zone "*Time zone variable expected")) +;; (setq zone (or (calc-var-value 'var-TimeZone) +;; (progn +;; (calcFunc-tzone) +;; (calc-var-value 'var-TimeZone))))) +;; (setq zone (and (eq (car-safe zone) 'var) +;; (upcase (symbol-name (nth 1 zone))))) +;; (let ((zadj (assoc zone math-tzone-names))) +;; (or zadj (math-reject-arg zone "*Unrecognized time zone name")) +;; (if (integerp (nth 2 zadj)) +;; (nth 2 zadj) +;; (math-daylight-savings-adjust date zone)))) (defun calcFunc-tzconv (date z1 z2) (if (math-realp date) diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el index 162692b742c..f4f63d1df8a 100644 --- a/lisp/calc/calc-funcs.el +++ b/lisp/calc/calc-funcs.el @@ -147,7 +147,8 @@ (or (math-numberp x) (math-reject-arg x 'numberp)) (calcFunc-fact (math-add x -1))) -(defun math-gammap1-raw (x &optional fprec nfprec) ; compute gamma(1 + x) +(defun math-gammap1-raw (x &optional fprec nfprec) + "Compute gamma(1+X) to the appropriate precision." (or fprec (setq fprec (math-float calc-internal-prec) nfprec (math-float (- calc-internal-prec)))) @@ -567,42 +568,48 @@ ((Math-lessp '(float 8 0) (math-abs-approx x)) (let* ((z (math-div '(float 8 0) x)) (y (math-sqr z)) - (xx (math-add x '(float (bigneg 164 398 785) -9))) + (xx (math-add x + (math-read-number-simple "-0.785398164"))) (a1 (math-poly-eval y - '((float (bigpos 211 887 093 2) -16) - (float (bigneg 639 370 073 2) -15) - (float (bigpos 407 510 734 2) -14) - (float (bigneg 627 628 098 1) -12) - (float 1 0)))) + (list + (math-read-number-simple "0.0000002093887211") + (math-read-number-simple "-0.000002073370639") + (math-read-number-simple "0.00002734510407") + (math-read-number-simple "-0.001098628627") + '(float 1 0)))) (a2 (math-poly-eval y - '((float (bigneg 152 935 934) -16) - (float (bigpos 161 095 621 7) -16) - (float (bigneg 651 147 911 6) -15) - (float (bigpos 765 488 430 1) -13) - (float (bigneg 995 499 562 1) -11)))) + (list + (math-read-number-simple "-0.0000000934935152") + (math-read-number-simple "0.0000007621095161") + (math-read-number-simple "-0.000006911147651") + (math-read-number-simple "0.0001430488765") + (math-read-number-simple "-0.01562499995")))) (sc (math-sin-cos-raw xx))) (if yflag (setq sc (cons (math-neg (cdr sc)) (car sc)))) (math-mul (math-sqrt - (math-div '(float (bigpos 722 619 636) -9) x)) + (math-div (math-read-number-simple "0.636619722") + x)) (math-sub (math-mul (cdr sc) a1) (math-mul (car sc) (math-mul z a2)))))) (t (let ((y (math-sqr x))) (math-div (math-poly-eval y - '((float (bigneg 456 052 849 1) -7) - (float (bigpos 017 233 739 7) -5) - (float (bigneg 418 442 121 1) -2) - (float (bigpos 407 196 516 6) -1) - (float (bigneg 354 590 362 13) 0) - (float (bigpos 574 490 568 57) 0))) + (list + (math-read-number-simple "-184.9052456") + (math-read-number-simple "77392.33017") + (math-read-number-simple "-11214424.18") + (math-read-number-simple "651619640.7") + (math-read-number-simple "-13362590354.0") + (math-read-number-simple "57568490574.0"))) (math-poly-eval y - '((float 1 0) - (float (bigpos 712 532 678 2) -7) - (float (bigpos 853 264 927 5) -5) - (float (bigpos 718 680 494 9) -3) - (float (bigpos 985 532 029 1) 0) - (float (bigpos 411 490 568 57) 0)))))))) + (list + '(float 1 0) + (math-read-number-simple "267.8532712") + (math-read-number-simple "59272.64853") + (math-read-number-simple "9494680.718") + (math-read-number-simple "1029532985.0") + (math-read-number-simple "57568490411.0")))))))) (defun math-besJ1 (x &optional yflag) (cond ((and (math-negp (calcFunc-re x)) (not yflag)) @@ -610,25 +617,29 @@ ((Math-lessp '(float 8 0) (math-abs-approx x)) (let* ((z (math-div '(float 8 0) x)) (y (math-sqr z)) - (xx (math-add x '(float (bigneg 491 194 356 2) -9))) + (xx (math-add x (math-read-number-simple "-2.356194491"))) (a1 (math-poly-eval y - '((float (bigneg 019 337 240) -15) - (float (bigpos 174 520 457 2) -15) - (float (bigneg 496 396 516 3) -14) - (float 183105 -8) - (float 1 0)))) + (list + (math-read-number-simple "-0.000000240337019") + (math-read-number-simple "0.000002457520174") + (math-read-number-simple "-0.00003516396496") + '(float 183105 -8) + '(float 1 0)))) (a2 (math-poly-eval y - '((float (bigpos 412 787 105) -15) - (float (bigneg 987 228 88) -14) - (float (bigpos 096 199 449 8) -15) - (float (bigneg 873 690 002 2) -13) - (float (bigpos 995 499 687 4) -11)))) + (list + (math-read-number-simple "0.000000105787412") + (math-read-number-simple "-0.00000088228987") + (math-read-number-simple "0.000008449199096") + (math-read-number-simple "-0.0002002690873") + (math-read-number-simple "0.04687499995")))) (sc (math-sin-cos-raw xx))) (if yflag (setq sc (cons (math-neg (cdr sc)) (car sc))) (if (math-negp x) (setq sc (cons (math-neg (car sc)) (math-neg (cdr sc)))))) - (math-mul (math-sqrt (math-div '(float (bigpos 722 619 636) -9) x)) + (math-mul (math-sqrt (math-div + (math-read-number-simple "0.636619722") + x)) (math-sub (math-mul (cdr sc) a1) (math-mul (car sc) (math-mul z a2)))))) (t @@ -636,20 +647,21 @@ (math-mul x (math-div (math-poly-eval y - '((float (bigneg 606 036 016 3) -8) - (float (bigpos 826 044 157) -4) - (float (bigneg 439 611 972 2) -3) - (float (bigpos 531 968 423 2) -1) - (float (bigneg 235 059 895 7) 0) - (float (bigpos 232 614 362 72) 0))) + (list + (math-read-number-simple "-30.16036606") + (math-read-number-simple "15704.4826") + (math-read-number-simple "-2972611.439") + (math-read-number-simple "242396853.1") + (math-read-number-simple "-7895059235.0") + (math-read-number-simple "72362614232.0"))) (math-poly-eval y - '((float 1 0) - (float (bigpos 397 991 769 3) -7) - (float (bigpos 394 743 944 9) -5) - (float (bigpos 474 330 858 1) -2) - (float (bigpos 178 535 300 2) 0) - (float (bigpos 442 228 725 144) - 0))))))))) + (list + '(float 1 0) + (math-read-number-simple "376.9991397") + (math-read-number-simple "99447.43394") + (math-read-number-simple "18583304.74") + (math-read-number-simple "2300535178.0") + (math-read-number-simple "144725228442.0"))))))))) (defun calcFunc-besY (v x) (math-inexact-result) @@ -688,22 +700,24 @@ (defun math-besY0 (x) (cond ((Math-lessp (math-abs-approx x) '(float 8 0)) (let ((y (math-sqr x))) - (math-add + (math-add (math-div (math-poly-eval y - '((float (bigpos 733 622 284 2) -7) - (float (bigneg 757 792 632 8) -5) - (float (bigpos 129 988 087 1) -2) - (float (bigneg 036 598 123 5) -1) - (float (bigpos 065 834 062 7) 0) - (float (bigneg 389 821 957 2) 0))) + (list + (math-read-number-simple "228.4622733") + (math-read-number-simple "-86327.92757") + (math-read-number-simple "10879881.29") + (math-read-number-simple "-512359803.6") + (math-read-number-simple "7062834065.0") + (math-read-number-simple "-2957821389.0"))) (math-poly-eval y - '((float 1 0) - (float (bigpos 244 030 261 2) -7) - (float (bigpos 647 472 474) -4) - (float (bigpos 438 466 189 7) -3) - (float (bigpos 648 499 452 7) -1) - (float (bigpos 269 544 076 40) 0)))) - (math-mul '(float (bigpos 772 619 636) -9) + (list + '(float 1 0) + (math-read-number-simple "226.1030244") + (math-read-number-simple "47447.2647") + (math-read-number-simple "7189466.438") + (math-read-number-simple "745249964.8") + (math-read-number-simple "40076544269.0")))) + (math-mul (math-read-number-simple "0.636619772") (math-mul (math-besJ0 x) (math-ln-raw x)))))) ((math-negp (calcFunc-re x)) (math-add (math-besJ0 (math-neg x) t) @@ -719,22 +733,24 @@ (math-mul x (math-div (math-poly-eval y - '((float (bigpos 935 937 511 8) -6) - (float (bigneg 726 922 237 4) -3) - (float (bigpos 551 264 349 7) -1) - (float (bigneg 139 438 153 5) 1) - (float (bigpos 439 527 127) 4) - (float (bigneg 943 604 900 4) 3))) + (list + (math-read-number-simple "8511.937935") + (math-read-number-simple "-4237922.726") + (math-read-number-simple "734926455.1") + (math-read-number-simple "-51534381390.0") + (math-read-number-simple "1275274390000.0") + (math-read-number-simple "-4900604943000.0"))) (math-poly-eval y - '((float 1 0) - (float (bigpos 885 632 549 3) -7) - (float (bigpos 605 042 102) -3) - (float (bigpos 002 904 245 2) -2) - (float (bigpos 367 650 733 3) 0) - (float (bigpos 664 419 244 4) 2) - (float (bigpos 057 958 249) 5))))) - (math-mul '(float (bigpos 772 619 636) -9) - (math-sub (math-mul (math-besJ1 x) (math-ln-raw x)) + (list + '(float 1 0) + (math-read-number-simple "354.9632885") + (math-read-number-simple "102042.605") + (math-read-number-simple "22459040.02") + (math-read-number-simple "3733650367.0") + (math-read-number-simple "424441966400.0") + (math-read-number-simple "24995805700000.0"))))) + (math-mul (math-read-number-simple "0.636619772") + (math-sub (math-mul (math-besJ1 x) (math-ln-raw x)) (math-div 1 x)))))) ((math-negp (calcFunc-re x)) (math-neg @@ -799,21 +815,45 @@ (calcFunc-euler n '(float 5 -1))) (calcFunc-euler n '(frac 1 2)))))) -(defvar math-bernoulli-b-cache '((frac -174611 - (bigpos 0 200 291 698 662 857 802)) - (frac 43867 (bigpos 0 944 170 217 94 109 5)) - (frac -3617 (bigpos 0 880 842 622 670 10)) - (frac 1 (bigpos 600 249 724 74)) - (frac -691 (bigpos 0 368 674 307 1)) - (frac 1 (bigpos 160 900 47)) - (frac -1 (bigpos 600 209 1)) - (frac 1 30240) (frac -1 720) - (frac 1 12) 1 )) - -(defvar math-bernoulli-B-cache '((frac -174611 330) (frac 43867 798) - (frac -3617 510) (frac 7 6) (frac -691 2730) - (frac 5 66) (frac -1 30) (frac 1 42) - (frac -1 30) (frac 1 6) 1 )) +(defvar math-bernoulli-b-cache + (list + (list 'frac + -174611 + (math-read-number-simple "802857662698291200000")) + (list 'frac + 43867 + (math-read-number-simple "5109094217170944000")) + (list 'frac + -3617 + (math-read-number-simple "10670622842880000")) + (list 'frac + 1 + (math-read-number-simple "74724249600")) + (list 'frac + -691 + (math-read-number-simple "1307674368000")) + (list 'frac + 1 + (math-read-number-simple "47900160")) + (list 'frac + -1 + (math-read-number-simple "1209600")) + (list 'frac + 1 + 30240) + (list 'frac + -1 + 720) + (list 'frac + 1 + 12) + 1 )) + +(defvar math-bernoulli-B-cache + '((frac -174611 330) (frac 43867 798) + (frac -3617 510) (frac 7 6) (frac -691 2730) + (frac 5 66) (frac -1 30) (frac 1 42) + (frac -1 30) (frac 1 6) 1 )) (defvar math-bernoulli-cache-size 11) (defun math-bernoulli-coefs (n) diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 6d9f7061c05..d52dc6d84b0 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -218,7 +218,8 @@ 0) (or (and (Math-num-integerp pstyle) (math-trunc pstyle)) (if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec) - 0 -1))))) + 0 -1)) + (math-contains-sdev-p (eval (nth 2 ydata)))))) (defun calc-graph-lookup (thing) (if (and (eq (car-safe thing) 'var) @@ -792,6 +793,10 @@ calc-graph-numsteps (1- (* calc-graph-numsteps (1+ calc-graph-numsteps3)))))) (defun calc-graph-format-data () + (if (math-contains-sdev-p calc-graph-yp) + (let ((yp calc-graph-yp)) + (setq calc-graph-yp (cons 'vec (mapcar 'math-get-value (cdr yp)))) + (setq calc-graph-zp (cons 'vec (mapcar 'math-get-sdev (cdr yp)))))) (while (<= (setq calc-graph-stepcount (1+ calc-graph-stepcount)) calc-graph-numsteps) (if calc-graph-xvec (setq calc-graph-xp (cdr calc-graph-xp) @@ -1059,7 +1064,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (interactive "P") (calc-graph-set-styles t (and style (prefix-numeric-value style)))) -(defun calc-graph-set-styles (lines points) +(defun calc-graph-set-styles (lines points &optional yerr) (calc-graph-init) (save-excursion (set-buffer calc-gnuplot-input) @@ -1067,7 +1072,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (error "No data points have been set!")) (let ((base (point)) (mode nil) (lstyle nil) (pstyle nil) - start end lenbl penbl) + start end lenbl penbl errform) (re-search-forward "[,\n]") (forward-char -1) (setq end (point) start end) @@ -1087,29 +1092,48 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (setq pstyle (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))))) - (setq lenbl (or (equal mode "lines") (equal mode "linespoints")) - penbl (or (equal mode "points") (equal mode "linespoints"))) - (if lines - (or (eq lines t) - (setq lstyle lines - lenbl (>= lines 0))) - (setq lenbl (not lenbl))) - (if points - (or (eq points t) - (setq pstyle points - penbl (>= points 0))) - (setq penbl (not penbl))) - (delete-region start end) + (unless yerr + (setq lenbl (or (equal mode "lines") + (equal mode "linespoints")) + penbl (or (equal mode "points") + (equal mode "linespoints"))) + (if lines + (or (eq lines t) + (setq lstyle lines + lenbl (>= lines 0))) + (setq lenbl (not lenbl))) + (if points + (or (eq points t) + (setq pstyle points + penbl (>= points 0))) + (setq penbl (not penbl)))) + (delete-region start end) (goto-char start) - (insert " with " - (if lenbl - (if penbl "linespoints" "lines") - (if penbl "points" "dots"))) - (if (and pstyle (> pstyle 0)) - (insert " " (if (and lstyle (> lstyle 0)) (int-to-string lstyle) "1") - " " (int-to-string pstyle)) - (if (and lstyle (> lstyle 0)) - (insert " " (int-to-string lstyle)))))) + (setq errform + (condition-case nil + (math-contains-sdev-p + (eval (intern + (concat "var-" + (save-excursion + (re-search-backward ":\\(.*\\)\\}") + (match-string 1)))))) + (error nil))) + (if yerr + (insert " with yerrorbars") + (insert " with " + (if (and errform + (equal mode "dots") + (eq lines t)) + "yerrorbars" + (if lenbl + (if penbl "linespoints" "lines") + (if penbl "points" "dots")))) + (if (and pstyle (> pstyle 0)) + (insert " " + (if (and lstyle (> lstyle 0)) (int-to-string lstyle) "1") + " " (int-to-string pstyle)) + (if (and lstyle (> lstyle 0)) + (insert " " (int-to-string lstyle))))))) (calc-graph-view-commands)) (defun calc-graph-zero-x (flag) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index 46cf2ce8dbb..320e8e43459 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -32,6 +32,11 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function Info-goto-node "info" (nodename &optional fork)) +(declare-function Info-last "info" ()) + + (defun calc-help-prefix (arg) "This key is the prefix for Calc help functions. See calc-help-for-help." (interactive "P") @@ -321,11 +326,11 @@ C-w Describe how there is no warranty for Calc." (defun calc-describe-function (&optional func) (interactive) (unless calc-help-function-list - (setq calc-help-function-list + (setq calc-help-function-list (calc-help-index-entries "Function" "Command"))) (or func (setq func (completing-read "Describe function: " - calc-help-function-list + calc-help-function-list nil t))) (if (string-match "\\`calc-." func) (calc-describe-thing func "Command Index") @@ -334,7 +339,7 @@ C-w Describe how there is no warranty for Calc." (defun calc-describe-variable (&optional var) (interactive) (unless calc-help-variable-list - (setq calc-help-variable-list + (setq calc-help-variable-list (calc-help-index-entries "Variable"))) (or var (setq var (completing-read "Describe variable: " @@ -419,49 +424,49 @@ C-w Describe how there is no warranty for Calc." (princ "Or type `h i' to read the full Calc manual on-line.\n\n") (princ "Basic keys:\n") (let* ((calc-full-help-flag t)) - (mapcar (function (lambda (x) (princ (format " %s\n" x)))) - (nreverse (cdr (reverse (cdr (calc-help)))))) - (mapcar (function (lambda (prefix) - (let ((msgs (condition-case err - (funcall prefix) - (error nil)))) - (if (car msgs) - (princ - (if (eq (nth 2 msgs) ?v) - "\n`v' or `V' prefix (vector/matrix) keys: \n" - (if (nth 2 msgs) - (format - "\n`%c' prefix (%s) keys:\n" - (nth 2 msgs) - (or (cdr (assq (nth 2 msgs) - calc-help-long-names)) - (nth 1 msgs))) - (format "\n%s-modified keys:\n" - (capitalize (nth 1 msgs))))))) - (mapcar (function (lambda (x) - (princ (format " %s\n" x)))) - (car msgs))))) - '(calc-inverse-prefix-help - calc-hyperbolic-prefix-help - calc-inv-hyp-prefix-help - calc-a-prefix-help - calc-b-prefix-help - calc-c-prefix-help - calc-d-prefix-help - calc-f-prefix-help - calc-g-prefix-help - calc-h-prefix-help - calc-j-prefix-help - calc-k-prefix-help - calc-m-prefix-help - calc-r-prefix-help - calc-s-prefix-help - calc-t-prefix-help - calc-u-prefix-help - calc-v-prefix-help - calc-shift-Y-prefix-help - calc-shift-Z-prefix-help - calc-z-prefix-help))) + (mapc (function (lambda (x) (princ (format " %s\n" x)))) + (nreverse (cdr (reverse (cdr (calc-help)))))) + (mapc (function (lambda (prefix) + (let ((msgs (condition-case err + (funcall prefix) + (error nil)))) + (if (car msgs) + (princ + (if (eq (nth 2 msgs) ?v) + "\n`v' or `V' prefix (vector/matrix) keys: \n" + (if (nth 2 msgs) + (format + "\n`%c' prefix (%s) keys:\n" + (nth 2 msgs) + (or (cdr (assq (nth 2 msgs) + calc-help-long-names)) + (nth 1 msgs))) + (format "\n%s-modified keys:\n" + (capitalize (nth 1 msgs))))))) + (mapcar (function (lambda (x) + (princ (format " %s\n" x)))) + (car msgs))))) + '(calc-inverse-prefix-help + calc-hyperbolic-prefix-help + calc-inv-hyp-prefix-help + calc-a-prefix-help + calc-b-prefix-help + calc-c-prefix-help + calc-d-prefix-help + calc-f-prefix-help + calc-g-prefix-help + calc-h-prefix-help + calc-j-prefix-help + calc-k-prefix-help + calc-m-prefix-help + calc-r-prefix-help + calc-s-prefix-help + calc-t-prefix-help + calc-u-prefix-help + calc-v-prefix-help + calc-shift-Y-prefix-help + calc-shift-Z-prefix-help + calc-z-prefix-help))) (print-help-return-message))) (defun calc-h-prefix-help () @@ -596,6 +601,7 @@ C-w Describe how there is no warranty for Calc." "\" (strings); Truncate, [, ]; SPC (refresh), RET, @" "SHIFT + language: Normal, One-line, Big, Unformatted" "SHIFT + language: C, Pascal, Fortran; TeX, LaTeX, Eqn" + "SHIFT + language: Yacas, X=Maxima, A=Giac" "SHIFT + language: Mathematica, W=Maple") "display" ?d)) diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index 7ea2fe4c49a..fc1a50f1d23 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -32,12 +32,28 @@ (require 'calc-ext) (require 'calc-macs) + +;; Declare functions which are defined elsewhere. +(declare-function math-compose-vector "calccomp" (a sep prec)) +(declare-function math-compose-var "calccomp" (a)) +(declare-function math-tex-expr-is-flat "calccomp" (a)) +(declare-function math-read-factor "calc-aent" ()) +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + +;; Declare variables which are defined elsewhere. +(defvar calc-lang-slash-idiv) +(defvar calc-lang-allow-underscores) +(defvar calc-lang-allow-percentsigns) +(defvar math-comp-left-bracket) +(defvar math-comp-right-bracket) +(defvar math-comp-comma) +(defvar math-comp-vector-prec) + ;;; Alternate entry/display languages. (defun calc-set-language (lang &optional option no-refresh) - (setq math-expr-opers (or (get lang 'math-oper-table) math-standard-opers) + (setq math-expr-opers (or (get lang 'math-oper-table) (math-standard-ops)) math-expr-function-mapping (get lang 'math-function-table) - math-expr-special-function-mapping (get lang 'math-special-function-table) math-expr-variable-mapping (get lang 'math-variable-table) calc-language-input-filter (get lang 'math-input-filter) calc-language-output-filter (get lang 'math-output-filter) @@ -84,10 +100,10 @@ (message "`C' language mode"))) (put 'c 'math-oper-table - '( ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 ) - ( "u!" calcFunc-lnot -1 1000 ) + '( ( "u!" calcFunc-lnot -1 1000 ) ( "~" calcFunc-not -1 1000 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "*" * 190 191 ) ( "/" / 190 191 ) ( "%" % 190 191 ) @@ -135,6 +151,20 @@ (if (= r 8) (format "0%s" s) (format "%d#%s" r s)))))) +(put 'c 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(add-to-list 'calc-lang-slash-idiv 'c) +(add-to-list 'calc-lang-allow-underscores 'c) +(add-to-list 'calc-lang-c-type-hex 'c) +(add-to-list 'calc-lang-brackets-are-subscripts 'c) (defun calc-pascal-language (n) (interactive "P") @@ -183,6 +213,32 @@ (if (= r 16) (format "$%s" s) (format "%d#%s" r s))))) +(put 'pascal 'math-lang-read-symbol + '((?\$ + (eq (string-match + "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)" + math-exp-str math-exp-pos) + math-exp-pos) + (setq math-exp-token 'number + math-expr-data (math-match-substring math-exp-str 1) + math-exp-pos (match-end 1))))) + +(put 'pascal 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(add-to-list 'calc-lang-allow-underscores 'pascal) +(add-to-list 'calc-lang-brackets-are-subscripts 'pascal) + (defun calc-input-case-filter (str) (cond ((or (null calc-language-option) (= calc-language-option 0)) str) @@ -253,8 +309,34 @@ ( real . calcFunc-re ))) (put 'fortran 'math-input-filter 'calc-input-case-filter) + (put 'fortran 'math-output-filter 'calc-output-case-filter) +(put 'fortran 'math-lang-read-symbol + '((?\. + (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\." + math-exp-str math-exp-pos) math-exp-pos) + (setq math-exp-token 'punc + math-expr-data (upcase (math-match-substring math-exp-str 0)) + math-exp-pos (match-end 0))))) + +(put 'fortran 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "(" + (math-compose-vector args ", " 0) + ")"))))) + +(add-to-list 'calc-lang-slash-idiv 'fortran) +(add-to-list 'calc-lang-allow-underscores 'fortran) +(add-to-list 'calc-lang-parens-are-subscripts 'fortran) + ;; The next few variables are local to math-read-exprs in calc-aent.el ;; and math-read-expr in calc-ext.el, but are set in functions they call. @@ -327,10 +409,11 @@ (message "LaTeX language mode with \\func(\\text{var}) and multiline matrices"))))) +(put 'tex 'math-lang-name "TeX") +(put 'latex 'math-lang-name "LaTeX") + (put 'tex 'math-oper-table - '( ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 ) - ( "\\hat" calcFunc-hat -1 950 ) + '( ( "\\hat" calcFunc-hat -1 950 ) ( "\\check" calcFunc-check -1 950 ) ( "\\tilde" calcFunc-tilde -1 950 ) ( "\\acute" calcFunc-acute -1 950 ) @@ -351,13 +434,15 @@ ( "!" calcFunc-fact 210 -1 ) ( "^" ^ 201 200 ) ( "_" calcFunc-subscr 201 200 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "\\times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) - ( "/" / 185 186 ) ( "+" + 180 181 ) ( "-" - 180 181 ) ( "\\over" / 170 171 ) + ( "/" / 170 171 ) ( "\\choose" calcFunc-choose 170 171 ) ( "\\mod" % 170 171 ) ( "<" calcFunc-lt 160 161 ) @@ -408,6 +493,11 @@ ( \\phi . calcFunc-totient ) ( \\mu . calcFunc-moebius ))) +(put 'tex 'math-special-function-table + '((calcFunc-sum . (math-compose-tex-sum "\\sum")) + (calcFunc-prod . (math-compose-tex-sum "\\prod")) + (intv . math-compose-tex-intv))) + (put 'tex 'math-variable-table '( ;; The Greek letters @@ -458,8 +548,112 @@ ( \\sum . (math-parse-tex-sum calcFunc-sum) ) ( \\prod . (math-parse-tex-sum calcFunc-prod) ))) +(put 'tex 'math-punc-table + '((?\{ . ?\() + (?\} . ?\)) + (?\& . ?\,))) + (put 'tex 'math-complex-format 'i) +(put 'tex 'math-input-filter 'math-tex-input-filter) + +(put 'tex 'math-matrix-formatter + (function + (lambda (a) + (if (and (integerp calc-language-option) + (or (= calc-language-option 0) + (> calc-language-option 1) + (< calc-language-option -1))) + (append '(vleft 0 "\\matrix{") + (math-compose-tex-matrix (cdr a)) + '("}")) + (append '(horiz "\\matrix{ ") + (math-compose-tex-matrix (cdr a)) + '(" }")))))) + +(put 'tex 'math-var-formatter 'math-compose-tex-var) + +(put 'tex 'math-func-formatter 'math-compose-tex-func) + +(put 'tex 'math-dots "\\ldots") + +(put 'tex 'math-big-parens '("\\left( " . " \\right)")) + +(put 'tex 'math-evalto '("\\evalto " . " \\to ")) + +(defconst math-tex-ignore-words + '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") + ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") + ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") + ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") + ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") + ("\\rm") ("\\bf") ("\\it") ("\\sl") + ("\\roman") ("\\bold") ("\\italic") ("\\slanted") + ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") + ("\\evalto") + ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) + ("\\begin" begenv) + ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") + ("\\{" punc "[") ("\\}" punc "]"))) + +(defconst math-latex-ignore-words + (append math-tex-ignore-words + '(("\\begin" begenv)))) + +(put 'tex 'math-lang-read-symbol + '((?\\ + (< math-exp-pos (1- (length math-exp-str))) + (progn + (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" + math-exp-str math-exp-pos) + (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" + math-exp-str math-exp-pos)) + (setq math-exp-token 'symbol + math-exp-pos (match-end 0) + math-expr-data (math-restore-dashes + (math-match-substring math-exp-str 1))) + (let ((code (assoc math-expr-data math-latex-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + ((and (eq (nth 1 code) 'mat) + (string-match " *{" math-exp-str math-exp-pos)) + (setq math-exp-pos (match-end 0) + math-exp-token 'punc + math-expr-data "[") + (let ((right (string-match "}" math-exp-str math-exp-pos))) + (and right + (setq math-exp-str (copy-sequence math-exp-str)) + (aset math-exp-str right ?\])))))))))) + +(defun math-compose-tex-matrix (a &optional ltx) + (if (cdr a) + (cons (append (math-compose-vector (cdr (car a)) " & " 0) + (if ltx '(" \\\\ ") '(" \\cr "))) + (math-compose-tex-matrix (cdr a) ltx)) + (list (math-compose-vector (cdr (car a)) " & " 0)))) + +(defun math-compose-tex-sum (a fn) + (cond + ((nth 4 a) + (list 'horiz (nth 1 fn) + "_{" (math-compose-expr (nth 2 a) 0) + "=" (math-compose-expr (nth 3 a) 0) + "}^{" (math-compose-expr (nth 4 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")) + ((nth 3 a) + (list 'horiz (nth 1 fn) + "_{" (math-compose-expr (nth 2 a) 0) + "=" (math-compose-expr (nth 3 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")) + (t + (list 'horiz (nth 1 fn) + "_{" (math-compose-expr (nth 2 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")))) + (defun math-parse-tex-sum (f val) (let (low high save) (or (equal math-expr-data "_") (throw 'syntax "Expected `_'")) @@ -480,7 +674,59 @@ (setq str (concat (substring str 0 (1+ (match-beginning 0))) (substring str (1- (match-end 0)))))) str) -(put 'tex 'math-input-filter 'math-tex-input-filter) + +;(defun math-tex-print-sqrt (a) +; (list 'horiz +; "\\sqrt{" +; (math-compose-expr (nth 1 a) 0) +; "}")) + +(defun math-compose-tex-intv (a) + (list 'horiz + (if (memq (nth 1 a) '(0 1)) "(" "[") + (math-compose-expr (nth 2 a) 0) + " \\ldots " + (math-compose-expr (nth 3 a) 0) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) + +(defun math-compose-tex-var (a prec) + (if (and calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" + (symbol-name (nth 1 a)))) + (if (eq calc-language 'latex) + (format "\\text{%s}" (symbol-name (nth 1 a))) + (format "\\hbox{%s}" (symbol-name (nth 1 a)))) + (math-compose-var a))) + +(defun math-compose-tex-func (func a) + (let (left right) + (if (and calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) + (if (< (prefix-numeric-value calc-language-option) 0) + (setq func (format "\\%s" func)) + (setq func (if (eq calc-language 'latex) + (format "\\text{%s}" func) + (format "\\hbox{%s}" func))))) + (cond ((or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a)))) + (setq left "\\left( " + right " \\right)")) + ((and (eq (aref func 0) ?\\) + (not (or + (string-match "\\hbox{" func) + (string-match "\\text{" func))) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left "{" right "}")) + (t (setq left calc-function-open + right calc-function-close))) + (list 'horiz func + left + (math-compose-vector (cdr a) ", " 0) + right))) (put 'latex 'math-oper-table (append (get 'tex 'math-oper-table) @@ -496,7 +742,7 @@ ( "\\Vec" calcFunc-VEC -1 950 ) ( "\\dddot" calcFunc-dddot -1 950 ) ( "\\ddddot" calcFunc-ddddot -1 950 ) - ( "\div" / 170 171 ) + ( "\\div" / 170 171 ) ( "\\le" calcFunc-leq 160 161 ) ( "\\leqq" calcFunc-leq 160 161 ) ( "\\leqsland" calcFunc-leq 160 161 ) @@ -534,15 +780,93 @@ ( \\mu . calcFunc-moebius )))) (put 'latex 'math-special-function-table - '((/ . (math-latex-print-frac "\\frac")) - (calcFunc-choose . (math-latex-print-frac "\\binom")))) + '((/ . (math-compose-latex-frac "\\frac")) + (calcFunc-choose . (math-compose-latex-frac "\\binom")) + (calcFunc-sum . (math-compose-tex-sum "\\sum")) + (calcFunc-prod . (math-compose-tex-sum "\\prod")) + (intv . math-compose-tex-intv))) (put 'latex 'math-variable-table (get 'tex 'math-variable-table)) -(put 'latex 'math-complex-format 'i) +(put 'latex 'math-punc-table + '((?\{ . ?\() + (?\} . ?\)) + (?\& . ?\,))) +(put 'latex 'math-complex-format 'i) +(put 'latex 'math-matrix-formatter + (function + (lambda (a) + (if (and (integerp calc-language-option) + (or (= calc-language-option 0) + (> calc-language-option 1) + (< calc-language-option -1))) + (append '(vleft 0 "\\begin{pmatrix}") + (math-compose-tex-matrix (cdr a) t) + '("\\end{pmatrix}")) + (append '(horiz "\\begin{pmatrix} ") + (math-compose-tex-matrix (cdr a) t) + '(" \\end{pmatrix}")))))) + +(put 'latex 'math-var-formatter 'math-compose-tex-var) + +(put 'latex 'math-func-formatter 'math-compose-tex-func) + +(put 'latex 'math-dots "\\ldots") + +(put 'latex 'math-big-parens '("\\left( " . " \\right)")) + +(put 'latex 'math-evalto '("\\evalto " . " \\to ")) + +(put 'latex 'math-lang-read-symbol + '((?\\ + (< math-exp-pos (1- (length math-exp-str))) + (progn + (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" + math-exp-str math-exp-pos) + (string-match "\\\\text *{\\([a-zA-Z0-9]+\\)}" + math-exp-str math-exp-pos) + (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" + math-exp-str math-exp-pos)) + (setq math-exp-token 'symbol + math-exp-pos (match-end 0) + math-expr-data (math-restore-dashes + (math-match-substring math-exp-str 1))) + (let ((code (assoc math-expr-data math-tex-ignore-words)) + envname) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + ((and (eq (nth 1 code) 'begenv) + (string-match " *{\\([^}]*\\)}" math-exp-str math-exp-pos)) + (setq math-exp-pos (match-end 0) + envname (match-string 1 math-exp-str) + math-exp-token 'punc + math-expr-data "[") + (cond ((or (string= envname "matrix") + (string= envname "bmatrix") + (string= envname "smallmatrix") + (string= envname "pmatrix")) + (if (string-match (concat "\\\\end{" envname "}") + math-exp-str math-exp-pos) + (setq math-exp-str + (replace-match "]" t t math-exp-str)) + (error "%s" (concat "No closing \\end{" envname "}")))))) + ((and (eq (nth 1 code) 'mat) + (string-match " *{" math-exp-str math-exp-pos)) + (setq math-exp-pos (match-end 0) + math-exp-token 'punc + math-expr-data "[") + (let ((right (string-match "}" math-exp-str math-exp-pos))) + (and right + (setq math-exp-str (copy-sequence math-exp-str)) + (aset math-exp-str right ?\])))))))))) + (defun math-latex-parse-frac (f val) (let (numer denom) (setq numer (car (math-read-expr-list))) @@ -560,7 +884,7 @@ (setq second (math-read-factor)) (list (nth 2 f) first second))) -(defun math-latex-print-frac (a fn) +(defun math-compose-latex-frac (a fn) (list 'horiz (nth 1 fn) "{" (math-compose-expr (nth 1 a) -1) "}{" (math-compose-expr (nth 2 a) -1) @@ -575,9 +899,7 @@ (message "Eqn language mode"))) (put 'eqn 'math-oper-table - '( ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 ) - ( "prime" (math-parse-eqn-prime) 950 -1 ) + '( ( "prime" (math-parse-eqn-prime) 950 -1 ) ( "prime" calcFunc-Prime 950 -1 ) ( "dot" calcFunc-dot 950 -1 ) ( "dotdot" calcFunc-dotdot 950 -1 ) @@ -599,6 +921,8 @@ ( "right ceil" closing 0 -1 ) ( "+-" sdev 300 300 ) ( "!" calcFunc-fact 210 -1 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) @@ -640,11 +964,162 @@ ( mu . calcFunc-moebius ) ( matrix . (math-parse-eqn-matrix) ))) +(put 'eqn 'math-special-function-table + '((intv . math-compose-eqn-intv))) + +(put 'eqn 'math-punc-table + '((?\{ . ?\() + (?\} . ?\)))) + (put 'eqn 'math-variable-table '( ( inf . var-uinf ))) (put 'eqn 'math-complex-format 'i) +(put 'eqn 'math-big-parens '("{left ( " . " right )}")) + +(put 'eqn 'math-evalto '("evalto " . " -> ")) + +(put 'eqn 'math-matrix-formatter + (function + (lambda (a) + (append '(horiz "matrix { ") + (math-compose-eqn-matrix + (cdr (math-transpose a))) + '("}"))))) + +(put 'eqn 'math-var-formatter + (function + (lambda (a prec) + (let (v) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (if (string-match ".'\\'" (symbol-name (nth 2 a))) + (math-compose-expr + (list 'calcFunc-Prime + (list + 'var + (intern (substring (symbol-name (nth 1 a)) 0 -1)) + (intern (substring (symbol-name (nth 2 a)) 0 -1)))) + prec) + (symbol-name (nth 1 a)))))))) + +(defconst math-eqn-special-funcs + '( calcFunc-log + calcFunc-ln calcFunc-exp + calcFunc-sin calcFunc-cos calcFunc-tan + calcFunc-sec calcFunc-csc calcFunc-cot + calcFunc-sinh calcFunc-cosh calcFunc-tanh + calcFunc-sech calcFunc-csch calcFunc-coth + calcFunc-arcsin calcFunc-arccos calcFunc-arctan + calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)) + +(put 'eqn 'math-func-formatter + (function + (lambda (func a) + (let (left right) + (if (string-match "[^']'+\\'" func) + (let ((n (- (length func) (match-beginning 0) 1))) + (setq func (substring func 0 (- n))) + (while (>= (setq n (1- n)) 0) + (setq func (concat func " prime"))))) + (cond ((or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a)))) + (setq left "{left ( " + right " right )}")) + + ((and + (memq (car a) math-eqn-special-funcs) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left "~{" right "}")) + (t + (setq left " ( " + right " )"))) + (list 'horiz func left + (math-compose-vector (cdr a) " , " 0) + right))))) + +(put 'eqn 'math-lang-read-symbol + '((?\" + (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" + math-exp-str math-exp-pos) + (progn + (setq math-exp-str (copy-sequence math-exp-str)) + (aset math-exp-str (match-beginning 1) ?\{) + (if (< (match-end 1) (length math-exp-str)) + (aset math-exp-str (match-end 1) ?\})) + (math-read-token))))) + +(defconst math-eqn-ignore-words + '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") + ("left" ("floor") ("ceil")) + ("right" ("floor") ("ceil")) + ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) + ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) + ("above" punc ","))) + +(put 'eqn 'math-lang-adjust-words + (function + (lambda () + (let ((code (assoc math-expr-data math-eqn-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((consp (nth 1 code)) + (math-read-token) + (if (assoc math-expr-data (cdr code)) + (setq math-expr-data (format "%s %s" + (car code) math-expr-data)))) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + (t + (math-read-token) + (math-read-token))))))) + +(put 'eqn 'math-lang-read + '((eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^" + math-exp-str math-exp-pos) + math-exp-pos) + (progn + (setq math-exp-token 'punc + math-expr-data (math-match-substring math-exp-str 0) + math-exp-pos (match-end 0)) + (and (eq (string-match "\\\\dots\\." math-exp-str math-exp-pos) + math-exp-pos) + (setq math-exp-pos (match-end 0))) + (if (memq (aref math-expr-data 0) '(?~ ?^)) + (math-read-token))))) + + +(defun math-compose-eqn-matrix (a) + (if a + (cons + (cond ((eq calc-matrix-just 'right) "rcol ") + ((eq calc-matrix-just 'center) "ccol ") + (t "lcol ")) + (cons + (list 'break math-compose-level) + (cons + "{ " + (cons + (let ((math-compose-level (1+ math-compose-level))) + (math-compose-vector (cdr (car a)) " above " 1000)) + (cons + " } " + (math-compose-eqn-matrix (cdr a))))))) + nil)) + (defun math-parse-eqn-matrix (f sym) (let ((vec nil)) (while (assoc math-expr-data '(("ccol") ("lcol") ("rcol"))) @@ -680,6 +1155,634 @@ (intern (concat (symbol-name (nth 2 x)) "'")))) (list 'calcFunc-Prime x))) +(defun math-compose-eqn-intv (a) + (list 'horiz + (if (memq (nth 1 a) '(0 1)) "(" "[") + (math-compose-expr (nth 2 a) 0) + " ... " + (math-compose-expr (nth 3 a) 0) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) + + +;;; Yacas + +(defun calc-yacas-language () + "Change the Calc language to be Yacas-like." + (interactive) + (calc-wrapper + (calc-set-language 'yacas) + (message "`Yacas' language mode"))) + +(put 'yacas 'math-vector-brackets "{}") + +(put 'yacas 'math-complex-format 'I) + +(add-to-list 'calc-lang-brackets-are-subscripts 'yacas) + +(put 'yacas 'math-variable-table + '(( Infinity . var-inf) + ( Infinity . var-uinf) + ( Undefined . var-nan) + ( Pi . var-pi) + ( E . var-e) ;; Not really in Yacas + ( GoldenRatio . var-phi) + ( Gamma . var-gamma))) + +(put 'yacas 'math-parse-table + '((("Deriv(" 0 ")" 0) + calcFunc-deriv (var ArgB var-ArgB) (var ArgA var-ArgA)) + (("D(" 0 ")" 0) + calcFunc-deriv (var ArgB var-ArgB) (var ArgA var-ArgA)) + (("Integrate(" 0 ")" 0) + calcFunc-integ (var ArgB var-ArgB)(var ArgA var-ArgA)) + (("Integrate(" 0 "," 0 "," 0 ")" 0) + calcFunc-integ (var ArgD var-ArgD) (var ArgA var-ArgA) + (var ArgB var-ArgB) (var ArgC var-ArgC)) + (("Subst(" 0 "," 0 ")" 0) + calcFunc-subst (var ArgC var-ArgC) (var ArgA var-ArgA) + (var ArgB var-ArgB)) + (("Taylor(" 0 "," 0 "," 0 ")" 0) + calcFunc-taylor (var ArgD var-ArgD) + (calcFunc-eq (var ArgA var-ArgA) (var ArgB var-ArgB)) + (var ArgC var-ArgC)))) + +(put 'yacas 'math-oper-table + '(("+" + 30 30) + ("-" - 30 60) + ("*" * 60 60) + ("/" / 70 70) + ("u-" neg -1 60) + ("^" ^ 80 80) + ("u+" ident -1 30) + ("<<" calcFunc-lsh 80 80) + (">>" calcFunc-rsh 80 80) + ("!" calcFunc-fact 80 -1) + ("!!" calcFunc-dfact 80 -1) + ("X" calcFunc-cross 70 70) + ("=" calcFunc-eq 10 10) + ("!=" calcFunc-neq 10 10) + ("<" calcFunc-lt 10 10) + (">" calcFunc-gt 10 10) + ("<=" calcFunc-leq 10 10) + (">=" calcFunc-geq 10 10) + ("And" calcFunc-land 5 5) + ("Or" calcFunc-or 4 4) + ("Not" calcFunc-lnot -1 3) + (":=" calcFunc-assign 1 1))) + +(put 'yacas 'math-function-table + '(( Div . calcFunc-idiv) + ( Mod . calcFunc-mod) + ( Abs . calcFunc-abs) + ( Sign . calcFunc-sign) + ( Sqrt . calcFunc-sqrt) + ( Max . calcFunc-max) + ( Min . calcFunc-min) + ( Floor . calcFunc-floor) + ( Ceil . calcFunc-ceil) + ( Round . calcFunc-round) + ( Conjugate . calcFunc-conj) + ( Arg . calcFunc-arg) + ( Re . calcFunc-re) + ( Im . calcFunc-im) + ( Rationalize . calcFunc-pfrac) + ( Sin . calcFunc-sin) + ( Cos . calcFunc-cos) + ( Tan . calcFunc-tan) + ( Sec . calcFunc-sec) + ( Csc . calcFunc-csc) + ( Cot . calcFunc-cot) + ( ArcSin . calcFunc-arcsin) + ( ArcCos . calcFunc-arccos) + ( ArcTan . calcFunc-arctan) + ( Sinh . calcFunc-sinh) + ( Cosh . calcFunc-cosh) + ( Tanh . calcFunc-tanh) + ( Sech . calcFunc-sech) + ( Csch . calcFunc-csch) + ( Coth . calcFunc-coth) + ( ArcSinh . calcFunc-arcsinh) + ( ArcCosh . calcFunc-arccosh) + ( ArcTanh . calcFunc-arctanh) + ( Ln . calcFunc-ln) + ( Exp . calcFunc-exp) + ( Gamma . calcFunc-gamma) + ( Gcd . calcFunc-gcd) + ( Lcm . calcFunc-lcm) + ( Bin . calcFunc-choose) + ( Bernoulli . calcFunc-bern) + ( Euler . calcFunc-euler) + ( StirlingNumber1 . calcFunc-stir1) + ( StirlingNumber2 . calcFunc-stir2) + ( IsPrime . calcFunc-prime) + ( Factors . calcFunc-prfac) + ( NextPrime . calcFunc-nextprime) + ( Moebius . calcFunc-moebius) + ( Random . calcFunc-random) + ( Concat . calcFunc-vconcat) + ( Head . calcFunc-head) + ( Tail . calcFunc-tail) + ( Length . calcFunc-vlen) + ( Reverse . calcFunc-rev) + ( CrossProduct . calcFunc-cross) + ( Dot . calcFunc-mul) + ( DiagonalMatrix . calcFunc-diag) + ( Transpose . calcFunc-trn) + ( Inverse . calcFunc-inv) + ( Determinant . calcFunc-det) + ( Trace . calcFunc-tr) + ( RemoveDuplicates . calcFunc-rdup) + ( Union . calcFunc-vunion) + ( Intersection . calcFunc-vint) + ( Difference . calcFunc-vdiff) + ( Apply . calcFunc-apply) + ( Map . calcFunc-map) + ( Simplify . calcFunc-simplify) + ( ExpandBrackets . calcFunc-expand) + ( Solve . calcFunc-solve) + ( Degree . calcFunc-pdeg) + ( If . calcFunc-if) + ( Contains . (math-lang-switch-args calcFunc-in)) + ( Sum . (math-yacas-parse-Sum calcFunc-sum)) + ( Factorize . (math-yacas-parse-Sum calcFunc-prod)))) + +(put 'yacas 'math-special-function-table + '(( calcFunc-sum . (math-yacas-compose-sum "Sum")) + ( calcFunc-prod . (math-yacas-compose-sum "Factorize")) + ( calcFunc-deriv . (math-yacas-compose-deriv "Deriv")) + ( calcFunc-integ . (math-yacas-compose-deriv "Integrate")) + ( calcFunc-taylor . math-yacas-compose-taylor) + ( calcFunc-in . (math-lang-compose-switch-args "Contains")))) + +(put 'yacas 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(defun math-yacas-parse-Sum (f val) + "Read in the arguments to \"Sum\" in Calc's Yacas mode." + (let ((args (math-read-expr-list))) + (math-read-token) + (list (nth 2 f) + (nth 3 args) + (nth 0 args) + (nth 1 args) + (nth 2 args)))) + +(defun math-yacas-compose-sum (a fn) + "Compose the \"Sum\" function in Calc's Yacas mode." + (list 'horiz + (nth 1 fn) + "(" + (math-compose-expr (nth 2 a) -1) + "," + (math-compose-expr (nth 3 a) -1) + "," + (math-compose-expr (nth 4 a) -1) + "," + (math-compose-expr (nth 1 a) -1) + ")")) + +(defun math-yacas-compose-deriv (a fn) + "Compose the \"Deriv\" function in Calc's Yacas mode." + (list 'horiz + (nth 1 fn) + "(" + (math-compose-expr (nth 2 a) -1) + (if (not (nth 3 a)) + ")" + (concat + "," + (math-compose-expr (nth 3 a) -1) + "," + (math-compose-expr (nth 4 a) -1) + ")")) + " " + (math-compose-expr (nth 1 a) -1))) + +(defun math-yacas-compose-taylor (a) + "Compose the \"Taylor\" function in Calc's Yacas mode." + (list 'horiz + "Taylor(" + (if (eq (car-safe (nth 2 a)) 'calcFunc-eq) + (concat (math-compose-expr (nth 1 (nth 2 a)) -1) + "," + (math-compose-expr (nth 2 (nth 2 a)) -1)) + (concat (math-compose-expr (nth 2 a) -1) ",0")) + "," + (math-compose-expr (nth 3 a) -1) + ") " + (math-compose-expr (nth 1 a) -1))) + + +;;; Maxima + +(defun calc-maxima-language () + "Change the Calc language to be Maxima-like." + (interactive) + (calc-wrapper + (calc-set-language 'maxima) + (message "`Maxima' language mode"))) + +(put 'maxima 'math-oper-table + '(("+" + 100 100) + ("-" - 100 134) + ("*" * 120 120) + ("." * 130 129) + ("/" / 120 120) + ("u-" neg -1 180) + ("u+" ident -1 180) + ("^" ^ 140 139) + ("**" ^ 140 139) + ("!" calcFunc-fact 160 -1) + ("!!" calcFunc-dfact 160 -1) + ("=" calcFunc-eq 80 80) + ("#" calcFunc-neq 80 80) + ("<" calcFunc-lt 80 80) + (">" calcFunc-gt 80 80) + ("<=" calcFunc-leq 80 80) + (">=" calcFunc-geq 80 80) + ("and" calcFunc-land 65 65) + ("or" calcFunc-or 60 60) + ("not" calcFunc-lnot -1 70) + (":" calcFunc-assign 180 20))) + + +(put 'maxima 'math-function-table + '(( matrix . vec) + ( abs . calcFunc-abs) + ( cabs . calcFunc-abs) + ( signum . calcFunc-sign) + ( floor . calcFunc-floor) + ( entier . calcFunc-floor) + ( fix . calcFunc-floor) + ( conjugate . calcFunc-conj ) + ( carg . calcFunc-arg) + ( realpart . calcFunc-re) + ( imagpart . calcFunc-im) + ( rationalize . calcFunc-pfrac) + ( asin . calcFunc-arcsin) + ( acos . calcFunc-arccos) + ( atan . calcFunc-arctan) + ( atan2 . calcFunc-arctan2) + ( asinh . calcFunc-arcsinh) + ( acosh . calcFunc-arccosh) + ( atanh . calcFunc-arctanh) + ( log . calcFunc-ln) + ( plog . calcFunc-ln) + ( bessel_j . calcFunc-besJ) + ( bessel_y . calcFunc-besY) + ( factorial . calcFunc-fact) + ( binomial . calcFunc-choose) + ( primep . calcFunc-prime) + ( next_prime . calcFunc-nextprime) + ( prev_prime . calcFunc-prevprime) + ( append . calcFunc-vconcat) + ( rest . calcFunc-tail) + ( reverse . calcFunc-rev) + ( innerproduct . calcFunc-mul) + ( inprod . calcFunc-mul) + ( row . calcFunc-mrow) + ( columnvector . calcFunc-mcol) + ( covect . calcFunc-mcol) + ( transpose . calcFunc-trn) + ( invert . calcFunc-inv) + ( determinant . calcFunc-det) + ( mattrace . calcFunc-tr) + ( member . calcFunc-in) + ( lmax . calcFunc-vmax) + ( lmin . calcFunc-vmin) + ( distrib . calcFunc-expand) + ( partfrac . calcFunc-apart) + ( rat . calcFunc-nrat) + ( product . calcFunc-prod) + ( diff . calcFunc-deriv) + ( integrate . calcFunc-integ) + ( quotient . calcFunc-pdiv) + ( remainder . calcFunc-prem) + ( divide . calcFunc-pdivrem) + ( equal . calcFunc-eq) + ( notequal . calcFunc-neq) + ( rhs . calcFunc-rmeq) + ( subst . (math-maxima-parse-subst)) + ( substitute . (math-maxima-parse-subst)) + ( taylor . (math-maxima-parse-taylor)))) + +(defun math-maxima-parse-subst (f val) + "Read in the arguments to \"subst\" in Calc's Maxima mode." + (let ((args (math-read-expr-list))) + (math-read-token) + (list 'calcFunc-subst + (nth 1 args) + (nth 2 args) + (nth 0 args)))) + +(defun math-maxima-parse-taylor (f val) + "Read in the arguments to \"taylor\" in Calc's Maxima mode." + (let ((args (math-read-expr-list))) + (math-read-token) + (list 'calcFunc-taylor + (nth 0 args) + (list 'calcFunc-eq + (nth 1 args) + (nth 2 args)) + (nth 3 args)))) + +(put 'maxima 'math-parse-table + '((("if" 0 "then" 0 "else" 0) + calcFunc-if + (var ArgA var-ArgA) + (var ArgB var-ArgB) + (var ArgC var-ArgC)))) + +(put 'maxima 'math-special-function-table + '(( calcFunc-taylor . math-maxima-compose-taylor) + ( calcFunc-subst . math-maxima-compose-subst) + ( calcFunc-if . math-maxima-compose-if))) + +(defun math-maxima-compose-taylor (a) + "Compose the \"taylor\" function in Calc's Maxima mode." + (list 'horiz + "taylor(" + (math-compose-expr (nth 1 a) -1) + "," + (if (eq (car-safe (nth 2 a)) 'calcFunc-eq) + (concat (math-compose-expr (nth 1 (nth 2 a)) -1) + "," + (math-compose-expr (nth 2 (nth 2 a)) -1)) + (concat (math-compose-expr (nth 2 a) -1) ",0")) + "," + (math-compose-expr (nth 3 a) -1) + ")")) + +(defun math-maxima-compose-subst (a) + "Compose the \"subst\" function in Calc's Maxima mode." + (list 'horiz + "substitute(" + (math-compose-expr (nth 2 a) -1) + "," + (math-compose-expr (nth 3 a) -1) + "," + (math-compose-expr (nth 1 a) -1) + ")")) + +(defun math-maxima-compose-if (a) + "Compose the \"if\" function in Calc's Maxima mode." + (list 'horiz + "if " + (math-compose-expr (nth 1 a) -1) + " then " + (math-compose-expr (nth 2 a) -1) + " else " + (math-compose-expr (nth 3 a) -1))) + +(put 'maxima 'math-variable-table + '(( infinity . var-uinf) + ( %pi . var-pi) + ( %e . var-e) + ( %i . var-i) + ( %phi . var-phi) + ( %gamma . var-gamma))) + +(put 'maxima 'math-complex-format '%i) + +(add-to-list 'calc-lang-allow-underscores 'maxima) + +(add-to-list 'calc-lang-allow-percentsigns 'maxima) + +(add-to-list 'calc-lang-brackets-are-subscripts 'maxima) + +(put 'maxima 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(put 'maxima 'math-matrix-formatter + (function + (lambda (a) + (list 'horiz + "matrix(" + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + ")")))) + + +;;; Giac + +(defun calc-giac-language () + "Change the Calc language to be Giac-like." + (interactive) + (calc-wrapper + (calc-set-language 'giac) + (message "`Giac' language mode"))) + +(put 'giac 'math-oper-table + '( ( "[" (math-read-giac-subscr) 250 -1 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "/" / 191 192 ) + ( "*" * 191 192 ) + ( "^" ^ 201 200 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) + ( "!" calcFunc-fact 210 -1 ) + ( ".." (math-read-maple-dots) 165 165 ) + ( "\\dots" (math-read-maple-dots) 165 165 ) + ( "intersect" calcFunc-vint 191 192 ) + ( "union" calcFunc-vunion 180 181 ) + ( "minus" calcFunc-vdiff 180 181 ) + ( "<" calcFunc-lt 160 160 ) + ( ">" calcFunc-gt 160 160 ) + ( "<=" calcFunc-leq 160 160 ) + ( ">=" calcFunc-geq 160 160 ) + ( "=" calcFunc-eq 160 160 ) + ( "==" calcFunc-eq 160 160 ) + ( "!=" calcFunc-neq 160 160 ) + ( "and" calcFunc-land 110 111 ) + ( "or" calcFunc-lor 100 101 ) + ( "&&" calcFunc-land 110 111 ) + ( "||" calcFunc-lor 100 101 ) + ( "not" calcFunc-lnot -1 121 ) + ( ":=" calcFunc-assign 51 50 ))) + + +(put 'giac 'math-function-table + '(( rdiv . calcFunc-div) + ( iquo . calcFunc-idiv) + ( irem . calcFunc-mod) + ( remain . calcFunc-mod) + ( floor . calcFunc-floor) + ( iPart . calcFunc-floor) + ( ceil . calcFunc-ceil) + ( ceiling . calcFunc-ceil) + ( re . calcFunc-re) + ( real . calcFunc-re) + ( im . calcFunc-im) + ( imag . calcFunc-im) + ( float2rational . calcFunc-pfrac) + ( exact . calcFunc-pfrac) + ( evalf . calcFunc-pfloat) + ( bitand . calcFunc-and) + ( bitor . calcFunc-or) + ( bitxor . calcFunc-xor) + ( asin . calcFunc-arcsin) + ( acos . calcFunc-arccos) + ( atan . calcFunc-arctan) + ( asinh . calcFunc-arcsinh) + ( acosh . calcFunc-arccosh) + ( atanh . calcFunc-arctanh) + ( log . calcFunc-ln) + ( logb . calcFunc-log) + ( factorial . calcFunc-fact) + ( comb . calcFunc-choose) + ( binomial . calcFunc-choose) + ( nCr . calcFunc-choose) + ( perm . calcFunc-perm) + ( nPr . calcFunc-perm) + ( bernoulli . calcFunc-bern) + ( is_prime . calcFunc-prime) + ( isprime . calcFunc-prime) + ( isPrime . calcFunc-prime) + ( ifactors . calcFunc-prfac) + ( euler . calcFunc-totient) + ( phi . calcFunc-totient) + ( rand . calcFunc-random) + ( concat . calcFunc-vconcat) + ( augment . calcFunc-vconcat) + ( mid . calcFunc-subvec) + ( length . calcFunc-length) + ( size . calcFunc-length) + ( nops . calcFunc-length) + ( SortA . calcFunc-sort) + ( SortB . calcFunc-rsort) + ( revlist . calcFunc-rev) + ( cross . calcFunc-cross) + ( crossP . calcFunc-cross) + ( crossproduct . calcFunc-cross) + ( mul . calcFunc-mul) + ( dot . calcFunc-mul) + ( dotprod . calcFunc-mul) + ( dotP . calcFunc-mul) + ( scalar_product . calcFunc-mul) + ( scalar_Product . calcFunc-mul) + ( row . calcFunc-mrow) + ( col . calcFunc-mcol) + ( dim . calcFunc-mdims) + ( tran . calcFunc-trn) + ( transpose . calcFunc-trn) + ( lu . calcFunc-lud) + ( trace . calcFunc-tr) + ( member . calcFunc-in) + ( sum . calcFunc-vsum) + ( add . calcFunc-vsum) + ( product . calcFunc-vprod) + ( mean . calcFunc-vmean) + ( median . calcFunc-vmedian) + ( stddev . calcFunc-vsdev) + ( stddevp . calcFunc-vpsdev) + ( variance . calcFunc-vpvar) + ( map . calcFunc-map) + ( apply . calcFunc-map) + ( of . calcFunc-map) + ( zip . calcFunc-map) + ( expand . calcFunc-expand) + ( fdistrib . calcFunc-expand) + ( partfrac . calcFunc-apart) + ( ratnormal . calcFunc-nrat) + ( diff . calcFunc-deriv) + ( derive . calcFunc-deriv) + ( integrate . calcFunc-integ) + ( int . calcFunc-integ) + ( Int . calcFunc-integ) + ( romberg . calcFunc-ninteg) + ( nInt . calcFunc-ninteg) + ( lcoeff . calcFunc-plead) + ( content . calcFunc-pcont) + ( primpart . calcFunc-pprim) + ( quo . calcFunc-pdiv) + ( rem . calcFunc-prem) + ( quorem . calcFunc-pdivrem) + ( divide . calcFunc-pdivrem) + ( equal . calcFunc-eq) + ( ifte . calcFunc-if) + ( not . calcFunc-lnot) + ( rhs . calcFunc-rmeq) + ( right . calcFunc-rmeq) + ( prepend . (math-lang-switch-args calcFunc-cons)) + ( contains . (math-lang-switch-args calcFunc-in)) + ( has . (math-lang-switch-args calcFunc-refers)))) + +(defun math-lang-switch-args (f val) + "Read the arguments to a Calc function in reverse order. +This is used for various language modes which have functions in reverse +order to Calc's." + (let ((args (math-read-expr-list))) + (math-read-token) + (list (nth 2 f) + (nth 1 args) + (nth 0 args)))) + +(put 'giac 'math-parse-table + '((("set" 0) + calcFunc-rdup + (var ArgA var-ArgA)))) + +(put 'giac 'math-special-function-table + '((calcFunc-cons . (math-lang-compose-switch-args "prepend")) + (calcFunc-in . (math-lang-compose-switch-args "contains")) + (calcFunc-refers . (math-lang-compose-switch-args "has")) + (intv . math-compose-maple-intv))) + +(defun math-lang-compose-switch-args (a fn) + "Compose the arguments to a Calc function in reverse order. +This is used for various language modes which have functions in reverse +order to Calc's." + (list 'horiz (nth 1 fn) + "(" + (math-compose-expr (nth 2 a) 0) + "," + (math-compose-expr (nth 1 a) 0) + ")")) + +(put 'giac 'math-variable-table + '(( infinity . var-inf) + ( infinity . var-uinf))) + +(put 'giac 'math-complex-format 'i) + +(add-to-list 'calc-lang-allow-underscores 'giac) + +(put 'giac 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-expr + (calc-normalize (list '- (nth 2 a) 1)) 0) + "]"))))) + +(defun math-read-giac-subscr (x op) + (let ((idx (math-read-expr-level 0))) + (or (equal math-expr-data "]") + (throw 'syntax "Expected ']'")) + (math-read-token) + (list 'calcFunc-subscr x (calc-normalize (list '+ idx 1))))) + +(add-to-list 'calc-lang-c-type-hex 'giac) + (defun calc-mathematica-language () (interactive) @@ -789,6 +1892,22 @@ (put 'math 'math-radix-formatter (function (lambda (r s) (format "%d^^%s" r s)))) +(put 'math 'math-lang-read + '((eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos) + math-exp-pos) + (setq math-exp-token 'punc + math-expr-data (math-match-substring math-exp-str 0) + math-exp-pos (match-end 0)))) + +(put 'math 'math-compose-subscr + (function + (lambda (a) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[[" + (math-compose-expr (nth 2 a) 0) + "]]")))) + (defun math-read-math-subscr (x op) (let ((idx (math-read-expr-level 0))) (or (and (equal math-expr-data "]") @@ -862,6 +1981,9 @@ ( vectdim . calcFunc-vlen ) )) +(put 'maple 'math-special-function-table + '((intv . math-compose-maple-intv))) + (put 'maple 'math-variable-table '( ( I . var-i ) ( Pi . var-pi ) @@ -873,6 +1995,37 @@ (put 'maple 'math-complex-format 'I) +(put 'maple 'math-matrix-formatter + (function + (lambda (a) + (list 'horiz + "matrix(" + math-comp-left-bracket + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + math-comp-right-bracket + ")")))) + +(put 'maple 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(add-to-list 'calc-lang-allow-underscores 'maple) +(add-to-list 'calc-lang-brackets-are-subscripts 'maple) + +(defun math-compose-maple-intv (a) + (list 'horiz + (math-compose-expr (nth 2 a) 0) + " .. " + (math-compose-expr (nth 3 a) 0))) + (defun math-read-maple-dots (x op) (list 'intv 3 x (math-read-expr-level (nth 3 op)))) @@ -1225,7 +2378,7 @@ h (1+ v) (1+ h) math-rb-v2) (string-match "<=\\|>=\\|\\+/-\\|!=\\|&&\\|||\\|:=\\|=>\\|." line h) (assoc (math-match-substring line 0) - math-standard-opers))) + (math-standard-ops)))) (and (>= (nth 2 widest) prec) (setq h (match-end 0))) (and (not (eq (string-match ",\\|;\\|\\.\\.\\|)\\|\\]\\|:" line h) diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index 4825ef4ab4a..c5d06031de7 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -27,6 +27,16 @@ ;;; Code: +;; Declare functions which are defined elsewhere. +(declare-function math-zerop "calc-misc" (a)) +(declare-function math-negp "calc-misc" (a)) +(declare-function math-looks-negp "calc-misc" (a)) +(declare-function math-posp "calc-misc" (a)) +(declare-function math-compare "calc-ext" (a b)) +(declare-function math-bignum "calc" (a)) +(declare-function math-compare-bignum "calc-ext" (a b)) + + (defmacro calc-wrapper (&rest body) `(calc-do (function (lambda () ,@body)))) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 07432a39881..920022aed91 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -32,6 +32,84 @@ (require 'calc-ext) (require 'calc-macs) + +;;; Find out how many 9s in 9.9999... will give distinct Emacs floats, +;;; then back off by one. + +(defvar math-emacs-precision + (let* ((n 1) + (x 9) + (xx (+ x (* 9 (expt 10 (- n)))))) + (while (/= x xx) + (progn + (setq n (1+ n)) + (setq x xx) + (setq xx (+ x (* 9 (expt 10 (- n))))))) + (1- n)) + "The number of digits in an Emacs float.") + +;;; Find the largest power of 10 which is an Emacs float, +;;; then back off by one so that any float d.dddd...eN +;;; is an Emacs float, for acceptable d.dddd.... + +(defvar math-largest-emacs-expt + (let ((x 1) + (pow 1e2)) + ;; The following loop is for efficiency; it should stop when + ;; 10^(2x) is too large. This could be indicated by a range + ;; error when computing 10^(2x) or an infinite value for 10^(2x). + (while (and + pow + (< pow 1.0e+INF)) + (setq x (* 2 x)) + (setq pow (condition-case nil + (expt 10.0 (* 2 x)) + (error nil)))) + ;; The following loop should stop when 10^(x+1) is too large. + (setq pow (condition-case nil + (expt 10.0 (1+ x)) + (error nil))) + (while (and + pow + (< pow 1.0e+INF)) + (setq x (1+ x)) + (setq pow (condition-case nil + (expt 10.0 (1+ x)) + (error nil)))) + (1- x)) + "The largest exponent which Calc will convert to an Emacs float.") + +(defvar math-smallest-emacs-expt + (let ((x -1)) + (while (condition-case nil + (> (expt 10.0 x) 0.0) + (error nil)) + (setq x (* 2 x))) + (setq x (/ x 2)) + (while (condition-case nil + (> (expt 10.0 x) 0.0) + (error nil)) + (setq x (1- x))) + (+ x 2)) + "The smallest exponent which Calc will convert to an Emacs float.") + +(defun math-use-emacs-fn (fn x) + "Use the native Emacs function FN to evaluate the Calc number X. +If this can't be done, return NIL." + (and + (<= calc-internal-prec math-emacs-precision) + (math-realp x) + (let* ((fx (math-float x)) + (xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) + (and (<= math-smallest-emacs-expt xpon) + (<= xpon math-largest-emacs-expt) + (condition-case nil + (math-read-number + (number-to-string + (funcall fn + (string-to-number (math-format-number (math-float x)))))) + (error nil)))))) + (defun calc-sqrt (arg) (interactive "P") (calc-slow-wrapper @@ -310,15 +388,15 @@ (let* ((top (nthcdr (- len 2) a))) (math-isqrt-bignum-iter a - (math-scale-bignum-3 + (math-scale-bignum-digit-size (math-bignum-big (1+ (math-isqrt-small - (+ (* (nth 1 top) 1000) (car top))))) + (+ (* (nth 1 top) math-bignum-digit-size) (car top))))) (1- (/ len 2))))) (let* ((top (nth (1- len) a))) (math-isqrt-bignum-iter a - (math-scale-bignum-3 + (math-scale-bignum-digit-size (list (1+ (math-isqrt-small top))) (/ len 2))))))) @@ -341,14 +419,15 @@ (while (eq (car (setq a (cdr a))) 0)) (null a)))) -(defun math-scale-bignum-3 (a n) ; [L L S] +(defun math-scale-bignum-digit-size (a n) ; [L L S] (while (> n 0) (setq a (cons 0 a) n (1- n))) a) (defun math-isqrt-small (a) ; A > 0. [S S] - (let ((g (cond ((>= a 10000) 1000) + (let ((g (cond ((>= a 1000000) 10000) + ((>= a 10000) 1000) ((>= a 100) 100) (t 10))) g2) @@ -463,13 +542,16 @@ (defun math-sqrt-raw (a &optional guess) ; [F F F] (if (not (Math-posp a)) (math-sqrt a) - (if (null guess) - (let ((ldiff (- (math-numdigs (nth 1 a)) 6))) - (or (= (% (+ (nth 2 a) ldiff) 2) 0) (setq ldiff (1+ ldiff))) - (setq guess (math-make-float (math-isqrt-small - (math-scale-int (nth 1 a) (- ldiff))) - (/ (+ (nth 2 a) ldiff) 2))))) - (math-sqrt-float-iter a guess))) + (cond + ((math-use-emacs-fn 'sqrt a)) + (t + (if (null guess) + (let ((ldiff (- (math-numdigs (nth 1 a)) 6))) + (or (= (% (+ (nth 2 a) ldiff) 2) 0) (setq ldiff (1+ ldiff))) + (setq guess (math-make-float (math-isqrt-small + (math-scale-int (nth 1 a) (- ldiff))) + (/ (+ (nth 2 a) ldiff) 2))))) + (math-sqrt-float-iter a guess))))) (defun math-sqrt-float-iter (a guess) ; [F F F] (math-working "sqrt" guess) @@ -1135,11 +1217,13 @@ ((math-lessp-float x (math-neg (math-pi-over-4))) (math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) ((math-nearly-zerop-float x orgx) '(float 0 0)) + ((math-use-emacs-fn 'sin x)) (calc-symbolic-mode (signal 'inexact-result nil)) (t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x))))))) (defun math-cos-raw-2 (x orgx) ; [F F] (cond ((math-nearly-zerop-float x orgx) '(float 1 0)) + ((math-use-emacs-fn 'cos x)) (calc-symbolic-mode (signal 'inexact-result nil)) (t (let ((xnegsqr (math-neg-float (math-sqr-float x)))) (math-sin-series @@ -1253,6 +1337,7 @@ ((Math-integer-negp (nth 1 x)) (math-neg-float (math-arctan-raw (math-neg-float x)))) ((math-zerop x) x) + ((math-use-emacs-fn 'atan x)) (calc-symbolic-mode (signal 'inexact-result nil)) ((math-equal-int x 1) (math-pi-over-4)) ((math-equal-int x -1) (math-neg (math-pi-over-4))) @@ -1402,6 +1487,7 @@ (list 'polar (math-exp-raw (nth 1 xc)) (math-from-radians (nth 2 xc))))) + ((math-use-emacs-fn 'exp x)) ((or (math-lessp-float '(float 5 -1) x) (math-lessp-float x '(float -5 -1))) (if (math-lessp-float '(float 921035 1) x) @@ -1670,10 +1756,13 @@ '(float 0 0)) (calc-symbolic-mode (signal 'inexact-result nil)) ((math-posp (nth 1 x)) ; positive and real - (let ((xdigs (1- (math-numdigs (nth 1 x))))) - (math-add-float (math-ln-raw-2 (list 'float (nth 1 x) (- xdigs))) - (math-mul-float (math-float (+ (nth 2 x) xdigs)) - (math-ln-10))))) + (cond + ((math-use-emacs-fn 'log x)) + (t + (let ((xdigs (1- (math-numdigs (nth 1 x))))) + (math-add-float (math-ln-raw-2 (list 'float (nth 1 x) (- xdigs))) + (math-mul-float (math-float (+ (nth 2 x) xdigs)) + (math-ln-10))))))) ((math-zerop x) (math-reject-arg x "*Logarithm of zero")) ((eq calc-complex-mode 'polar) ; negative and real @@ -1717,10 +1806,18 @@ sum (math-lnp1-series nextsum (1+ n) nextx x)))) -(math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) +(defconst math-approx-ln-10 + (math-read-number-simple "2.302585092994045684018") + "An approximation for ln(10).") + +(math-defcache math-ln-10 math-approx-ln-10 (math-ln-raw-2 '(float 1 1))) -(math-defcache math-ln-2 (float (bigpos 417 309 945 559 180 147 693) -21) +(defconst math-approx-ln-2 + (math-read-number-simple "0.693147180559945309417") + "An approximation for ln(2).") + +(math-defcache math-ln-2 math-approx-ln-2 (math-ln-raw-3 (math-float '(frac 1 3)))) diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el new file mode 100644 index 00000000000..ca67b65abfa --- /dev/null +++ b/lisp/calc/calc-menu.el @@ -0,0 +1,1429 @@ +;;; calc-menu.el --- a menu for Calc + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; 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 +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +(defvar calc-arithmetic-menu + (list "Arithmetic" + (list "Basic" + ["-(1:)" calc-change-sign + :keys "n" :active (>= (calc-stack-size) 1)] + ["(2:) + (1:)" calc-plus + :keys "+" :active (>= (calc-stack-size) 2)] + ["(2:) - (1:)" calc-minus + :keys "-" :active (>= (calc-stack-size) 2)] + ["(2:) * (1:)" calc-times + :keys "*" :active (>= (calc-stack-size) 2)] + ["(2:) / (1:)" calc-divide + :keys "/" :active (>= (calc-stack-size) 2)] + ["(2:) ^ (1:)" calc-power + :keys "^" :active (>= (calc-stack-size) 2)] + ["(2:) ^ (1/(1:))" + (progn + (require 'calc-ext) + (let ((calc-inverse-flag t)) + (call-interactively 'calc-power))) + :keys "I ^" + :active (>= (calc-stack-size) 2) + :help "The (1:)th root of (2:)"] + ["abs(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-abs)) + :keys "A" + :active (>= (calc-stack-size) 1) + :help "Absolute value"] + ["1/(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-inv)) + :keys "&" + :active (>= (calc-stack-size) 1)] + ["sqrt(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-sqrt)) + :keys "Q" + :active (>= (calc-stack-size) 1)] + ["idiv(2:,1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-idiv)) + :keys "\\" + :active (>= (calc-stack-size) 2) + :help "The integer quotient of (2:) over (1:)"] + ["(2:) mod (1:)" + (progn + (require 'calc-misc) + (call-interactively 'calc-mod)) + :keys "%" + :active (>= (calc-stack-size) 2) + :help "The remainder when (2:) is divided by (1:)"]) + (list "Rounding" + ["floor(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-floor)) + :keys "F" + :active (>= (calc-stack-size) 1) + :help "The greatest integer less than or equal to (1:)"] + ["ceiling(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-ceiling)) + :keys "I F" + :active (>= (calc-stack-size) 1) + :help "The smallest integer greater than or equal to (1:)"] + ["round(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-round)) + :keys "R" + :active (>= (calc-stack-size) 1) + :help "The nearest integer to (1:)"] + ["truncate(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-trunc)) + :keys "I R" + :active (>= (calc-stack-size) 1) + :help "The integer part of (1:)"]) + (list "Complex Numbers" + ["Re(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-re)) + :keys "f r" + :active (>= (calc-stack-size) 1)] + ["Im(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-im)) + :keys "f i" + :active (>= (calc-stack-size) 1)] + ["conj(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-conj)) + :keys "J" + :active (>= (calc-stack-size) 1) + :help "The complex conjugate of (1:)"] + ["length(1:)" + (progn (require 'calc-arith) + (call-interactively 'calc-abs)) + :keys "A" + :active (>= (calc-stack-size) 1) + :help "The length (absolute value) of (1:)"] + ["arg(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-argument)) + :keys "G" + :active (>= (calc-stack-size) 1) + :help "The argument (polar angle) of (1:)"]) + (list "Conversion" + ["Convert (1:) to a float" + (progn + (require 'calc-ext) + (call-interactively 'calc-float)) + :keys "c f" + :active (>= (calc-stack-size) 1)] + ["Convert (1:) to a fraction" + (progn + (require 'calc-ext) + (call-interactively 'calc-fraction)) + :keys "c F" + :active (>= (calc-stack-size) 1)]) + (list "Binary" + ["Set word size" + (progn + (require 'calc-bin) + (call-interactively 'calc-word-size)) + :keys "b w"] + ["Clip (1:) to word size" + (progn + (require 'calc-bin) + (call-interactively 'calc-clip)) + :keys "b c" + :active (>= (calc-stack-size) 1) + :help "Reduce (1:) modulo 2^wordsize"] + ["(2:) and (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-and)) + :keys "b a" + :active (>= (calc-stack-size) 2) + :help "Bitwise AND [modulo 2^wordsize]"] + ["(2:) or (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-or)) + :keys "b o" + :active (>= (calc-stack-size) 2) + :help "Bitwise inclusive OR [modulo 2^wordsize]"] + ["(2:) xor (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-xor)) + :keys "b x" + :active (>= (calc-stack-size) 2) + :help "Bitwise exclusive OR [modulo 2^wordsize]"] + ["diff(2:,1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-diff)) + :keys "b d" + :active (>= (calc-stack-size) 2) + :help "Bitwise difference [modulo 2^wordsize]"] + ["not (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-not)) + :keys "b n" + :active (>= (calc-stack-size) 1) + :help "Bitwise NOT [modulo 2^wordsize]"] + ["left shift(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-lshift-binary)) + :keys "b l" + :active (>= (calc-stack-size) 1) + :help "Shift (1:)[modulo 2^wordsize] one bit left"] + ["right shift(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-rshift-binary)) + :keys "b r" + :active (>= (calc-stack-size) 1) + :help "Shift (1:)[modulo 2^wordsize] one bit right, putting 0s on the left"] + ["arithmetic right shift(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-rshift-arith)) + :keys "b R" + :active (>= (calc-stack-size) 1) + :help "Shift (1:)[modulo 2^wordsize] one bit right, duplicating the leftmost bit"] + ["rotate(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-rotate-binary)) + :keys "b t" + :active (>= (calc-stack-size) 1) + :help "Rotate (1:)[modulo 2^wordsize] one bit left"]) + "-------" + ["Help on Arithmetic" + (calc-info-goto-node "Arithmetic")]) + "Menu for Calc's arithmetic functions.") + +(defvar calc-scientific-function-menu + (list "Scientific Functions" + (list "Constants" + ["pi" + (progn + (require 'calc-math) + (call-interactively 'calc-pi)) + :keys "P"] + ["e" + (progn + (require 'calc-math) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-pi))) + :keys "H P"] + ["phi" + (progn + (require 'calc-math) + (let ((calc-inverse-flag t) + (calc-hyperbolic-flag t)) + (call-interactively 'calc-pi))) + :keys "I H P" + :help "The golden ratio"] + ["gamma" + (progn + (require 'calc-math) + (let ((calc-inverse-flag t)) + (call-interactively 'calc-pi))) + :keys "I P" + :help "Euler's constant"]) + (list "Logs and Exps" + ["ln(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-ln)) + :keys "L" + :active (>= (calc-stack-size) 1) + :help "The natural logarithm"] + ["e^(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-exp)) + :keys "E" + :active (>= (calc-stack-size) 1)] + ["log(1:) [base 10]" + (progn + (require 'calc-math) + (call-interactively 'calc-log10)) + :keys "H L" + :active (>= (calc-stack-size) 1) + :help "The common logarithm"] + ["10^(1:)" + (progn + (require 'calc-math) + (let ((calc-inverse-flag t)) + (call-interactively 'calc-log10))) + :keys "I H L" + :active (>= (calc-stack-size) 1)] + ["log(2:) [base(1:)]" + (progn + (require 'calc-math) + (call-interactively 'calc-log)) + :keys "B" + :active (>= (calc-stack-size) 2) + :help "The logarithm with an arbitrary base"] + ["(2:) ^ (1:)" + calc-power + :keys "^" + :active (>= (calc-stack-size) 2)]) + (list "Trigonometric Functions" + ["sin(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-sin)) + :keys "S" + :active (>= (calc-stack-size) 1)] + ["cos(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-cos)) + :keys "C" + :active (>= (calc-stack-size) 1)] + ["tan(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-tan)) + :keys "T" + :active (>= (calc-stack-size) 1)] + ["arcsin(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arcsin)) + :keys "I S" + :active (>= (calc-stack-size) 1)] + ["arccos(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arccos)) + :keys "I C" + :active (>= (calc-stack-size) 1)] + ["arctan(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arctan)) + :keys "I T" + :active (>= (calc-stack-size) 1)] + ["arctan2(2:,1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arctan2)) + :keys "f T" + :active (>= (calc-stack-size) 2)] + "--Angle Measure--" + ["Radians" + (progn + (require 'calc-math) + (calc-radians-mode)) + :keys "m r" + :style radio + :selected (eq calc-angle-mode 'rad)] + ["Degrees" + (progn + (require 'calc-math) + (calc-degrees-mode)) + :keys "m d" + :style radio + :selected (eq calc-angle-mode 'deg)] + ["HMS" + (progn + (require 'calc-math) + (calc-hms-mode)) + :keys "m h" + :style radio + :selected (eq calc-angle-mode 'hms)]) + (list "Hyperbolic Functions" + ["sinh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-sinh)) + :keys "H S" + :active (>= (calc-stack-size) 1)] + ["cosh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-cosh)) + :keys "H C" + :active (>= (calc-stack-size) 1)] + ["tanh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-tanh)) + :keys "H T" + :active (>= (calc-stack-size) 1)] + ["arcsinh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arcsinh)) + :keys "I H S" + :active (>= (calc-stack-size) 1)] + ["arccosh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arccosh)) + :keys "I H C" + :active (>= (calc-stack-size) 1)] + ["arctanh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arctanh)) + :keys "I H T" + :active (>= (calc-stack-size) 1)]) + (list "Advanced Math Functions" + ["Gamma(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-gamma)) + :keys "f g" + :active (>= (calc-stack-size) 1) + :help "The Euler Gamma function"] + ["GammaP(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-inc-gamma)) + :keys "f G" + :active (>= (calc-stack-size) 2) + :help "The lower incomplete Gamma function"] + ["Beta(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-beta)) + :keys "f b" + :active (>= (calc-stack-size) 2) + :help "The Euler Beta function"] + ["BetaI(3:,2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-inc-beta)) + :keys "f B" + :active (>= (calc-stack-size) 3) + :help "The incomplete Beta function"] + ["erf(1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-erf)) + :keys "f e" + :active (>= (calc-stack-size) 1) + :help "The error function"] + ["BesselJ(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-bessel-J)) + :keys "f j" + :active (>= (calc-stack-size) 2) + :help "The Bessel function of the first kind (of order (2:))"] + ["BesselY(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-bessel-Y)) + :keys "f y" + :active (>= (calc-stack-size) 2) + :help "The Bessel function of the second kind (of order (2:))"]) + (list "Combinatorial Functions" + ["gcd(2:,1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-gcd)) + :keys "k g" + :active (>= (calc-stack-size) 2)] + ["lcm(2:,1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-lcm)) + :keys "k l" + :active (>= (calc-stack-size) 2)] + ["factorial(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-factorial)) + :keys "!" + :active (>= (calc-stack-size) 1)] + ["(2:) choose (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-choose)) + :keys "k c" + :active (>= (calc-stack-size) 2)] + ["permutations(2:,1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-perm)) + :keys "H k c" + :active (>= (calc-stack-size) 2)] + ["Primality test for (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-prime-test)) + :keys "k p" + :active (>= (calc-stack-size) 1) + :help "For large (1:), a probabilistic test"] + ["Factor (1:) into primes" + (progn + (require 'calc-comb) + (call-interactively 'calc-prime-factors)) + :keys "k f" + :active (>= (calc-stack-size) 1)] + ["Next prime after (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-next-prime)) + :keys "k n" + :active (>= (calc-stack-size) 1)] + ["Previous prime before (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-prev-prime)) + :keys "I k n" + :active (>= (calc-stack-size) 1)] + ["phi(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-totient)) + :keys "k n" + :active (>= (calc-stack-size) 1) + :help "Euler's totient function"] + ["random(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-random)) + :keys "k r" + :active (>= (calc-stack-size) 1) + :help "A random number >=1 and < (1:)"]) + "----" + ["Help on Scientific Functions" + (calc-info-goto-node "Scientific Functions")]) + "Menu for Calc's scientific functions.") + +(defvar calc-algebra-menu + (list "Algebra" + (list "Simplification" + ["Simplify (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-simplify)) + :keys "a s" + :active (>= (calc-stack-size) 1)] + ["Simplify (1:) with extended rules" + (progn + (require 'calc-alg) + (call-interactively 'calc-simplify-extended)) + :keys "a e" + :active (>= (calc-stack-size) 1) + :help "Apply possibly unsafe simplifications"]) + (list "Manipulation" + ["Expand formula (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-expand-formula)) + :keys "a \"" + :active (>= (calc-stack-size) 1) + :help "Expand (1:) into its defining formula, if possible"] + ["Evaluate variables in (1:)" + (progn + (require 'calc-ext) + (call-interactively 'calc-evaluate)) + :keys "=" + :active (>= (calc-stack-size) 1)] + ["Make substitution in (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-substitute)) + :keys "a b" + :active (>= (calc-stack-size) 1) + :help + "Substitute all occurrences of a sub-expression with a new sub-expression"]) + (list "Polynomials" + ["Factor (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-factor)) + :keys "a f" + :active (>= (calc-stack-size) 1)] + ["Collect terms in (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-collect)) + :keys "a c" + :active (>= (calc-stack-size) 1) + :help "Arrange as a polynomial in a given variable"] + ["Expand (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-expand)) + :keys "a x" + :active (>= (calc-stack-size) 1) + :help "Apply distributive law everywhere"] + ["Find roots of (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-poly-roots)) + :keys "a P" + :active (>= (calc-stack-size) 1)]) + (list "Calculus" + ["Differentiate (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-derivative)) + :keys "a d" + :active (>= (calc-stack-size) 1)] + ["Integrate (1:) [indefinite]" + (progn + (require 'calcalg2) + (call-interactively 'calc-integral)) + :keys "a i" + :active (>= (calc-stack-size) 1)] + ["Integrate (1:) [definite]" + (progn + (require 'calcalg2) + (let ((var (read-string "Integration variable: "))) + (calc-tabular-command 'calcFunc-integ "Integration" + "intg" nil var nil nil))) + :keys "C-u a i" + :active (>= (calc-stack-size) 1)] + ["Integrate (1:) [numeric]" + (progn + (require 'calcalg2) + (call-interactively 'calc-num-integral)) + :keys "a I" + :active (>= (calc-stack-size) 1) + :help "Integrate using the open Romberg method"] + ["Taylor expand (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-taylor)) + :keys "a t" + :active (>= (calc-stack-size) 1)] + ["Minimize (2:) [initial guess = (1:)]" + (progn + (require 'calcalg3) + (call-interactively 'calc-find-minimum)) + :keys "a N" + :active (>= (calc-stack-size) 2) + :help "Find a local minimum"] + ["Maximize (2:) [initial guess = (1:)]" + (progn + (require 'calcalg3) + (call-interactively 'calc-find-maximum)) + :keys "a X" + :active (>= (calc-stack-size) 2) + :help "Find a local maximum"]) + (list "Solving" + ["Solve equation (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-solve-for)) + :keys "a S" + :active (>= (calc-stack-size) 1)] + ["Solve equation (2:) numerically [initial guess = (1:)]" + (progn + (require 'calcalg3) + (call-interactively 'calc-find-root)) + :keys "a R" + :active (>= (calc-stack-size) 2)] + ["Find roots of polynomial (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-poly-roots)) + :keys "a P" + :active (>= (calc-stack-size) 1)]) + (list "Curve Fitting" + ["Fit (1:)=[x values, y values] to a curve" + (progn + (require 'calcalg3) + (call-interactively 'calc-curve-fit)) + :keys "a F" + :active (>= (calc-stack-size) 1)]) + "----" + ["Help on Algebra" + (calc-info-goto-node "Algebra")]) + "Menu for Calc's algebraic facilities.") + + +(defvar calc-graphics-menu + (list "Graphics" + ["Graph 2D [(1:)= y values, (2:)= x values]" + (progn + (require 'calc-graph) + (call-interactively 'calc-graph-fast)) + :keys "g f" + :active (>= (calc-stack-size) 2)] + ["Graph 3D [(1:)= z values, (2:)= y values, (3:)= x values]" + (progn + (require 'calc-graph) + (call-interactively 'calc-graph-fast-3d)) + :keys "g F" + :active (>= (calc-stack-size) 3)] + "----" + ["Help on Graphics" + (calc-info-goto-node "Graphics")]) + "Menu for Calc's graphics.") + + +(defvar calc-vectors-menu + (list "Matrices/Vectors" + (list "Matrices" + ["(2:) + (1:)" calc-plus + :keys "+" :active (>= (calc-stack-size) 2)] + ["(2:) - (1:)" calc-minus + :keys "-" :active (>= (calc-stack-size) 2)] + ["(2:) * (1:)" calc-times + :keys "*" :active (>= (calc-stack-size) 2)] + ["(1:)^(-1)" + (progn + (require 'calc-arith) + (call-interactively 'calc-inv)) + :keys "&" + :active (>= (calc-stack-size) 1)] + ["Create an identity matrix" + (progn + (require 'calc-vec) + (call-interactively 'calc-ident)) + :keys "v i"] + ["transpose(1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-transpose)) + :keys "v t" + :active (>= (calc-stack-size) 1)] + ["det(1:)" + (progn + (require 'calc-mtx) + (call-interactively 'calc-mdet)) + :keys "V D" + :active (>= (calc-stack-size) 1)] + ["trace(1:)" + (progn + (require 'calc-mtx) + (call-interactively 'calc-mtrace)) + :keys "V T" + :active (>= (calc-stack-size) 1)] + ["LUD decompose (1:)" + (progn + (require 'calc-mtx) + (call-interactively 'calc-mlud)) + :keys "V L" + :active (>= (calc-stack-size) 1)] + ["Extract a row from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-mrow)) + :keys "v r" + :active (>= (calc-stack-size) 1)] + ["Extract a column from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-mcol)) + :keys "v c" + :active (>= (calc-stack-size) 1)]) + (list "Vectors" + ["Extract the first element of (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-head)) + :keys "v h" + :active (>= (calc-stack-size) 1)] + ["Extract an element from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-mrow)) + :keys "v r" + :active (>= (calc-stack-size) 1)] + ["Reverse (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-reverse-vector)) + :keys "v v" + :active (>= (calc-stack-size) 1)] + ["Unpack (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-unpack)) + :keys "v u" + :active (>= (calc-stack-size) 1) + :help "Separate the elements of (1:)"] + ["(2:) cross (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-cross)) + :keys "V C" + :active (>= (calc-stack-size) 2) + :help "The cross product in R^3"] + ["(2:) dot (1:)" + calc-mult + :keys "*" + :active (>= (calc-stack-size) 2) + :help "The dot product"] + ["Map a function across (1:)" + (progn + (require 'calc-map) + (call-interactively 'calc-map)) + :keys "V M" + :active (>= (calc-stack-size) 1) + :help "Apply a function to each element"]) + (list "Vectors As Sets" + ["Remove duplicates from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-remove-duplicates)) + :keys "V +" + :active (>= (calc-stack-size) 1)] + ["(2:) union (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-set-union)) + :keys "V V" + :active (>= (calc-stack-size) 2)] + ["(2:) intersect (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-set-intersect)) + :keys "V ^" + :active (>= (calc-stack-size) 2)] + ["(2:) \\ (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-set-difference)) + :keys "V -" + :help "Set difference" + :active (>= (calc-stack-size) 2)]) + (list "Statistics On Vectors" + ["length(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-count)) + :keys "u #" + :active (>= (calc-stack-size) 1) + :help "The number of data values"] + ["sum(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-sum)) + :keys "u +" + :active (>= (calc-stack-size) 1) + :help "The sum of the data values"] + ["max(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-max)) + :keys "u x" + :active (>= (calc-stack-size) 1) + :help "The maximum of the data values"] + ["min(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-min)) + :keys "u N" + :active (>= (calc-stack-size) 1) + :help "The minumum of the data values"] + ["mean(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-mean)) + :keys "u M" + :active (>= (calc-stack-size) 1) + :help "The average (arithmetic mean) of the data values"] + ["mean(1:) with error" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-mean-error)) + :keys "I u M" + :active (>= (calc-stack-size) 1) + :help "The average (arithmetic mean) of the data values as an error form"] + ["sdev(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-sdev)) + :keys "u S" + :active (>= (calc-stack-size) 1) + :help "The sample sdev, sqrt[sum((values - mean)^2)/(N-1)]"] + ["variance(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-variance)) + :keys "H u S" + :active (>= (calc-stack-size) 1) + :help "The sample variance, sum((values - mean)^2)/(N-1)"] + ["population sdev(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-pop-sdev)) + :keys "I u S" + :active (>= (calc-stack-size) 1) + :help "The population sdev, sqrt[sum((values - mean)^2)/N]"] + ["population variance(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-pop-variance)) + :keys "H I u S" + :active (>= (calc-stack-size) 1) + :help "The population variance, sum((values - mean)^2)/N"] + ["median(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-median)) + :keys "H u M" + :active (>= (calc-stack-size) 1) + :help "The median of the data values"] + ["harmonic mean(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-harmonic-mean)) + :keys "H I u M" + :active (>= (calc-stack-size) 1)] + ["geometric mean(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-geometric-mean)) + :keys "u G" + :active (>= (calc-stack-size) 1)] + ["arithmetic-geometric mean(1:)" + (progn + (require 'calc-stat) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-vector-geometric-mean))) + :keys "H u G" + :active (>= (calc-stack-size) 1)] + ["RMS(1:)" + (progn (require 'calc-arith) + (call-interactively 'calc-abs)) + :keys "A" + :active (>= (calc-stack-size) 1) + :help "The root-mean-square, or quadratic mean"]) + ["Abbreviate long vectors" + (progn + (require 'calc-mode) + (call-interactively 'calc-full-vectors)) + :keys "v ." + :style toggle + :selected (not calc-full-vectors)] + "----" + ["Help on Matrices/Vectors" + (calc-info-goto-node "Matrix Functions")]) + "Menu for Calc's vector and matrix functions.") + +(defvar calc-units-menu + (list "Units" + ["Convert units in (1:)" + (progn + (require 'calc-units) + (call-interactively 'calc-convert-units )) + :keys "u c" + :active (>= (calc-stack-size) 1)] + ["Convert temperature in (1:)" + (progn + (require 'calc-units) + (call-interactively 'calc-convert-temperature)) + :keys "u t" + :active (>= (calc-stack-size) 1)] + ["Simplify units in (1:)" + (progn + (require 'calc-units) + (call-interactively 'calc-simplify-units)) + :keys "u s" + :active (>= (calc-stack-size) 1)] + ["View units table" + (progn + (require 'calc-units) + (call-interactively 'calc-view-units-table)) + :keys "u V"] + "----" + ["Help on Units" + (calc-info-goto-node "Units")]) + "Menu for Calc's units functions.") + +(defvar calc-variables-menu + (list "Variables" + ["Store (1:) into a variable" + (progn + (require 'calc-store) + (call-interactively 'calc-store)) + :keys "s s" + :active (>= (calc-stack-size) 1)] + ["Recall a variable value" + (progn + (require 'calc-store) + (call-interactively 'calc-recall )) + :keys "s r"] + ["Edit the value of a variable" + (progn + (require 'calc-store) + (call-interactively 'calc-edit-variable)) + :keys "s e"] + ["Exchange (1:) with a variable value" + (progn + (require 'calc-store) + (call-interactively 'calc-store-exchange)) + :keys "s x" + :active (>= (calc-stack-size) 1)] + ["Clear variable value" + (progn + (require 'calc-store) + (call-interactively 'calc-unstore)) + :keys "s u"] + ["Evaluate variables in (1:)" + (progn + (require 'calc-ext) + (call-interactively 'calc-evaluate)) + :keys "=" + :active (>= (calc-stack-size) 1)] + ["Evaluate (1:), assigning a value to a variable" + (progn + (require 'calc-store) + (call-interactively 'calc-let)) + :keys "s l" + :active (>= (calc-stack-size) 1) + :help "Evaluate (1:) under a temporary assignment of a variable"] + "----" + ["Help on Variables" + (calc-info-goto-node "Store and Recall")]) + "Menu for Calc's variables.") + +(defvar calc-stack-menu + (list "Stack" + ["Remove (1:)" + calc-pop + :keys "DEL" + :active (>= (calc-stack-size) 1)] + ["Switch (1:) and (2:)" + calc-roll-down + :keys "TAB" + :active (>= (calc-stack-size) 2)] + ["Duplicate (1:)" + calc-enter + :keys "RET" + :active (>= (calc-stack-size) 1)] + ["Edit (1:)" + (progn + (require 'calc-yank) + (call-interactively calc-edit)) + :keys "`" + :active (>= (calc-stack-size) 1)] + "----" + ["Help on Stack" + (calc-info-goto-node "Stack and Trail")]) + "Menu for Calc's stack functions.") + +(defvar calc-errors-menu + (list "Undo" + ["Undo" + (progn + (require 'calc-undo) + (call-interactively 'calc-undo)) + :keys "U"] + ["Redo" + (progn + (require 'calc-undo) + (call-interactively 'calc-redo)) + :keys "D"] + "----" + ["Help on Undo" + (progn + (calc-info-goto-node "Introduction") + (Info-goto-node "Undo"))])) + +(defvar calc-modes-menu + (list "Modes" + ["Precision" + (progn + (require 'calc-ext) + (call-interactively 'calc-precision)) + :keys "p" + :help "Set the precision for floating point calculations"] + ["Fraction mode" + (progn + (require 'calc-frac) + (call-interactively 'calc-frac-mode)) + :keys "m f" + :style toggle + :selected calc-prefer-frac + :help "Leave integer quotients as fractions"] + ["Symbolic mode" + (lambda () + (interactive) + (require 'calc-mode) + (calc-symbolic-mode nil)) + :keys "m s" + :style toggle + :selected calc-symbolic-mode + :help "Leave functions producing inexact answers in symbolic form"] + ["Infinite mode" + (lambda () + (interactive) + (require 'calc-mode) + (calc-infinite-mode nil)) + :keys "m i" + :style toggle + :selected calc-infinite-mode + :help "Let expressions like 1/0 produce infinite results"] + ["Abbreviate long vectors" + (progn + (require 'calc-mode) + (call-interactively 'calc-full-vectors)) + :keys "v ." + :style toggle + :selected (not calc-full-vectors)] + (list "Angle Measure" + ["Radians" + (progn + (require 'calc-math) + (call-interactively 'calc-radians-mode)) + :keys "m r" + :style radio + :selected (eq calc-angle-mode 'rad)] + ["Degrees" + (progn + (require 'calc-math) + (call-interactively 'calc-degrees-mode)) + :keys "m d" + :style radio + :selected (eq calc-angle-mode 'deg)] + ["HMS" + (progn + (require 'calc-math) + (call-interactively 'calc-hms-mode)) + :keys "m h" + :style radio + :selected (eq calc-angle-mode 'hms)]) + (list "Radix" + ["Decimal" + (progn + (require 'calc-bin) + (call-interactively 'calc-decimal-radix)) + :keys "d 0" + :style radio + :selected (= calc-number-radix 10)] + ["Binary" + (progn + (require 'calc-bin) + (call-interactively 'calc-binary-radix)) + :keys "d 2" + :style radio + :selected (= calc-number-radix 2)] + ["Octal" + (progn + (require 'calc-bin) + (call-interactively 'calc-octal-radix)) + :keys "d 8" + :style radio + :selected (= calc-number-radix 8)] + ["Hexadecimal" + (progn + (require 'calc-bin) + (call-interactively 'calc-hex-radix)) + :keys "d 6" + :style radio + :selected (= calc-number-radix 16)] + ["Other" + (progn + (require 'calc-bin) + (call-interactively 'calc-radix)) + :keys "d r" + :style radio + :selected (not + (or + (= calc-number-radix 10) + (= calc-number-radix 2) + (= calc-number-radix 8) + (= calc-number-radix 16)))]) + (list "Float Format" + ["Normal" + (progn + (require 'calc-mode) + (call-interactively 'calc-normal-notation)) + :keys "d n" + :style radio + :selected (eq (car-safe calc-float-format) 'float)] + ["Fixed point" + (progn + (require 'calc-mode) + (call-interactively 'calc-fix-notation)) + :keys "d f" + :style radio + :selected (eq (car-safe calc-float-format) 'fix)] + ["Scientific notation" + (progn + (require 'calc-mode) + (call-interactively 'calc-sci-notation)) + :keys "d s" + :style radio + :selected (eq (car-safe calc-float-format) 'sci)] + ["Engineering notation" + (progn + (require 'calc-mode) + (call-interactively 'calc-eng-notation)) + :keys "d e" + :style radio + :selected (eq (car-safe calc-float-format) 'eng)]) + (list "Complex Format" + ["Default" + (progn + (require 'calc-cplx) + (calc-complex-notation)) + :style radio + :selected (not calc-complex-format) + :keys "d c" + :help "Display complex numbers as ordered pairs."] + ["i notation" + (progn + (require 'calc-cplx) + (calc-i-notation)) + :style radio + :selected (eq calc-complex-format 'i) + :keys "d i" + :help "Display complex numbers as a+bi."] + ["j notation" + (progn + (require 'calc-cplx) + (calc-i-notation)) + :style radio + :selected (eq calc-complex-format 'j) + :keys "d j" + :help "Display complex numbers as a+bj."] + ["Other" + (calc-complex-notation) + :style radio + :selected (and calc-complex-format + (not (eq calc-complex-format 'i)) + (not (eq calc-complex-format 'j))) + :active nil] + "----" + ["Polar mode" + (progn + (require 'calc-cplx) + (calc-polar-mode nil)) + :style toggle + :selected (eq calc-complex-mode 'polar) + :keys "m p" + :help "Prefer polar form for complex numbers."]) + (list "Algebraic" + ["Normal" + (progn + (require 'calc-mode) + (cond + (calc-incomplete-algebraic-mode + (calc-algebraic-mode t)) + (calc-algebraic-mode + (calc-algebraic-mode nil)))) + :style radio + :selected (not calc-algebraic-mode)] + ["Algebraic mode" + (progn + (require 'calc-mode) + (if (or + calc-incomplete-algebraic-mode + (not calc-algebraic-mode)) + (calc-algebraic-mode nil))) + :keys "m a" + :style radio + :selected (and calc-algebraic-mode + (not calc-incomplete-algebraic-mode)) + :help "Keys which start numeric entry also start algebraic entry"] + ["Incomplete algebraic mode" + (progn + (require 'calc-mode) + (unless calc-incomplete-algebraic-mode + (calc-algebraic-mode t))) + :keys "C-u m a" + :style radio + :selected calc-incomplete-algebraic-mode + :help "Only ( and [ begin algebraic entry"] + ["Total algebraic mode" + (progn + (require 'calc-mode) + (unless (eq calc-algebraic-mode 'total) + (calc-total-algebraic-mode nil))) + :keys "m t" + :style radio + :selected (eq calc-algebraic-mode 'total) + :help "All regular letters and punctuation begin algebraic entry"]) + (list "Language" + ["Normal" + (progn + (require 'calc-lang) + (call-interactively 'calc-normal-language)) + :keys "d N" + :style radio + :selected (eq calc-language nil)] + ["Big" + (progn + (require 'calc-lang) + (call-interactively 'calc-big-language)) + :keys "d B" + :style radio + :selected (eq calc-language 'big) + :help "Use textual approximations to various mathematical notations"] + ["Flat" + (progn + (require 'calc-lang) + (call-interactively 'calc-flat-language)) + :keys "d O" + :style radio + :selected (eq calc-language 'flat) + :help "Write matrices on a single line"] + ["C" + (progn + (require 'calc-lang) + (call-interactively 'calc-c-language)) + :keys "d C" + :style radio + :selected (eq calc-language 'c)] + ["Pascal" + (progn + (require 'calc-lang) + (call-interactively 'calc-pascal-language)) + :keys "d P" + :style radio + :selected (eq calc-language 'pascal)] + ["Fortran" + (progn + (require 'calc-lang) + (call-interactively 'calc-fortran-language)) + :keys "d F" + :style radio + :selected (eq calc-language 'fortran)] + ["TeX" + (progn + (require 'calc-lang) + (call-interactively 'calc-tex-language)) + :keys "d T" + :style radio + :selected (eq calc-language 'tex)] + ["LaTeX" + (progn + (require 'calc-lang) + (call-interactively 'calc-latex-language)) + :keys "d L" + :style radio + :selected (eq calc-language 'latex)] + ["Eqn" + (progn + (require 'calc-lang) + (call-interactively 'calc-eqn-language)) + :keys "d E" + :style radio + :selected (eq calc-language 'eqn)] + ["Yacas" + (progn + (require 'calc-lang) + (call-interactively 'calc-yacas-language)) + :keys "d Y" + :style radio + :selected (eq calc-language 'yacas)] + ["Maxima" + (progn + (require 'calc-lang) + (call-interactively 'calc-maxima-language)) + :keys "d X" + :style radio + :selected (eq calc-language 'maxima)] + ["Giac" + (progn + (require 'calc-lang) + (call-interactively 'calc-giac-language)) + :keys "d A" + :style radio + :selected (eq calc-language 'giac)] + ["Mma" + (progn + (require 'calc-lang) + (call-interactively 'calc-mathematica-language)) + :keys "d M" + :style radio + :selected (eq calc-language 'math)] + ["Maple" + (progn + (require 'calc-lang) + (call-interactively 'calc-maple-language)) + :keys "d W" + :style radio + :selected (eq calc-language 'maple)]) + "----" + ["Save mode settings" calc-save-modes :keys "m m"] + "----" + ["Help on Modes" + (calc-info-goto-node "Mode settings")]) + "Menu for Calc's mode settings.") + +(defvar calc-help-menu + (list "Help" + ["Manual" + calc-info + :keys "h i"] + ["Tutorial" + calc-tutorial + :keys "h t"] + ["Summary" + calc-info-summary + :keys "h s"] + "----" + ["Help on Help" + (progn + (calc-info-goto-node "Introduction") + (Info-goto-node "Help Commands"))]) + "Menu for Calc's help functions.") + +(defvar calc-mode-map) + +(easy-menu-define + calc-menu + calc-mode-map + "Menu for Calc." + (list "Calc" + :visible '(eq major-mode 'calc-mode) + calc-arithmetic-menu + calc-scientific-function-menu + calc-algebra-menu + calc-graphics-menu + calc-vectors-menu + calc-units-menu + calc-variables-menu + calc-stack-menu + calc-errors-menu + calc-modes-menu + calc-help-menu + ["Reset" + (progn + (require 'calc-ext) + (call-interactively 'calc-reset)) + :help "Reset Calc to its initial state"] + ["Quit" calc-quit])) + +(provide 'calc-menu) + +;; arch-tag: 9612c86a-cd4f-4baa-ab0b-40af7344d21f diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index ecbc4c57190..036850e3a25 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -32,6 +32,35 @@ (require 'calc) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-do-keypad "calc-keypd" (&optional full-display interactive)) +(declare-function calc-inv-hyp-prefix-help "calc-help" ()) +(declare-function calc-inverse-prefix-help "calc-help" ()) +(declare-function calc-hyperbolic-prefix-help "calc-help" ()) +(declare-function calc-explain-why "calc-stuff" (why &optional more)) +(declare-function calc-clear-command-flag "calc-ext" (f)) +(declare-function calc-roll-down-with-selections "calc-sel" (n m)) +(declare-function calc-roll-up-with-selections "calc-sel" (n m)) +(declare-function calc-last-args "calc-undo" (n)) +(declare-function calc-is-inverse "calc-ext" ()) +(declare-function calc-do-prefix-help "calc-ext" (msgs group key)) +(declare-function math-objvecp "calc-ext" (a)) +(declare-function math-known-scalarp "calc-arith" (a &optional assume-scalar)) +(declare-function math-vectorp "calc-ext" (a)) +(declare-function math-matrixp "calc-ext" (a)) +(declare-function math-trunc-special "calc-arith" (a prec)) +(declare-function math-trunc-fancy "calc-arith" (a)) +(declare-function math-floor-special "calc-arith" (a prec)) +(declare-function math-floor-fancy "calc-arith" (a)) +(declare-function math-square-matrixp "calc-ext" (a)) +(declare-function math-matrix-inv-raw "calc-mtx" (m)) +(declare-function math-known-matrixp "calc-arith" (a)) +(declare-function math-mod-fancy "calc-arith" (a b)) +(declare-function math-pow-of-zero "calc-arith" (a b)) +(declare-function math-pow-zero "calc-arith" (a b)) +(declare-function math-pow-fancy "calc-arith" (a b)) + + (defun calc-dispatch-help (arg) "C-x* is a prefix key sequence; follow it with one of these letters: @@ -145,9 +174,9 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C). "Create another, independent Calculator buffer." (interactive) (if (eq major-mode 'calc-mode) - (mapcar (function - (lambda (v) - (set-default v (symbol-value v)))) calc-local-var-list)) + (mapc (function + (lambda (v) + (set-default v (symbol-value v)))) calc-local-var-list)) (set-buffer (generate-new-buffer "*Calculator*")) (pop-to-buffer (current-buffer)) (calc-mode)) @@ -579,7 +608,7 @@ loaded and the keystroke automatically re-typed." (defun math-div2-bignum (a) ; [l l] (if (cdr a) - (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500)) + (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) (/ math-bignum-digit-size 2))) (math-div2-bignum (cdr a))) (list (/ (car a) 2)))) diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index e315a7d475b..730a80e5a48 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -32,6 +32,10 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-embedded-save-original-modes "calc-embed" ()) + + (defun calc-line-numbering (n) (interactive "P") (calc-wrapper @@ -501,7 +505,7 @@ mode) (and (not (eq calc-simplify-mode mode)) mode))) - (message (if (eq calc-simplify-mode mode) + (message "%s" (if (eq calc-simplify-mode mode) msg "Default simplifications enabled"))) diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el new file mode 100644 index 00000000000..4019058a567 --- /dev/null +++ b/lisp/calc/calc-nlfit.el @@ -0,0 +1,823 @@ +;;; calc-nlfit.el --- nonlinear curve fitting for Calc + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; 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 +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This code uses the Levenberg-Marquardt method, as described in +;; _Numerical Analysis_ by H. R. Schwarz, to fit data to +;; nonlinear curves. Currently, the only the following curves are +;; supported: +;; The logistic S curve, y=a/(1+exp(b*(t-c))) +;; Here, y is usually interpreted as the population of some +;; quantity at time t. So we will think of the data as consisting +;; of quantities q0, q1, ..., qn and their respective times +;; t0, t1, ..., tn. + +;; The logistic bell curve, y=A*exp(B*(t-C))/(1+exp(B*(t-C)))^2 +;; Note that this is the derivative of the formula for the S curve. +;; We get A=-a*b, B=b and C=c. Here, y is interpreted as the rate +;; of growth of a population at time t. So we will think of the +;; data as consisting of rates p0, p1, ..., pn and their +;; respective times t0, t1, ..., tn. + +;; The Hubbert Linearization, y/x=A*(1-x/B) +;; Here, y is thought of as the rate of growth of a population +;; and x represents the actual population. This is essentially +;; the differential equation describing the actual population. + +;; The Levenberg-Marquardt method is an iterative process: it takes +;; an initial guess for the parameters and refines them. To get an +;; initial guess for the parameters, we'll use a method described by +;; Luis de Sousa in "Hubbert's Peak Mathematics". The idea is that +;; given quantities Q and the corresponding rates P, they should +;; satisfy P/Q= mQ+a. We can use the parameter a for an +;; approximation for the parameter a in the S curve, and +;; approximations for b and c are found using least squares on the +;; linearization log((a/y)-1) = log(bb) + cc*t of +;; y=a/(1+bb*exp(cc*t)), which is equivalent to the above s curve +;; formula, and then tranlating it to b and c. From this, we can +;; also get approximations for the bell curve parameters. + +;;; Code: + +(require 'calc-arith) +(require 'calcalg3) + +;; Declare functions which are defined elsewhere. +(declare-function calc-get-fit-variables "calcalg3" (nv nc &optional defv defc with-y homog)) +(declare-function math-map-binop "calcalg3" (binop args1 args2)) + +(defun math-nlfit-least-squares (xdata ydata &optional sdata sigmas) + "Return the parameters A and B for the best least squares fit y=a+bx." + (let* ((n (length xdata)) + (s2data (if sdata + (mapcar 'calcFunc-sqr sdata) + (make-list n 1))) + (S (if sdata 0 n)) + (Sx 0) + (Sy 0) + (Sxx 0) + (Sxy 0) + D) + (while xdata + (let ((x (car xdata)) + (y (car ydata)) + (s (car s2data))) + (setq Sx (math-add Sx (if s (math-div x s) x))) + (setq Sy (math-add Sy (if s (math-div y s) y))) + (setq Sxx (math-add Sxx (if s (math-div (math-mul x x) s) + (math-mul x x)))) + (setq Sxy (math-add Sxy (if s (math-div (math-mul x y) s) + (math-mul x y)))) + (if sdata + (setq S (math-add S (math-div 1 s))))) + (setq xdata (cdr xdata)) + (setq ydata (cdr ydata)) + (setq s2data (cdr s2data))) + (setq D (math-sub (math-mul S Sxx) (math-mul Sx Sx))) + (let ((A (math-div (math-sub (math-mul Sxx Sy) (math-mul Sx Sxy)) D)) + (B (math-div (math-sub (math-mul S Sxy) (math-mul Sx Sy)) D))) + (if sigmas + (let ((C11 (math-div Sxx D)) + (C12 (math-neg (math-div Sx D))) + (C22 (math-div S D))) + (list (list 'sdev A (calcFunc-sqrt C11)) + (list 'sdev B (calcFunc-sqrt C22)) + (list 'vec + (list 'vec C11 C12) + (list 'vec C12 C22)))) + (list A B))))) + +;;; The methods described by de Sousa require the cumulative data qdata +;;; and the rates pdata. We will assume that we are given either +;;; qdata and the corresponding times tdata, or pdata and the corresponding +;;; tdata. The following two functions will find pdata or qdata, +;;; given the other.. + +;;; First, given two lists; one of values q0, q1, ..., qn and one of +;;; corresponding times t0, t1, ..., tn; return a list +;;; p0, p1, ..., pn of the rates of change of the qi with respect to t. +;;; p0 is the right hand derivative (q1 - q0)/(t1 - t0). +;;; pn is the left hand derivative (qn - q(n-1))/(tn - t(n-1)). +;;; The other pis are the averages of the two: +;;; (1/2)((qi - q(i-1))/(ti - t(i-1)) + (q(i+1) - qi)/(t(i+1) - ti)). + +(defun math-nlfit-get-rates-from-cumul (tdata qdata) + (let ((pdata (list + (math-div + (math-sub (nth 1 qdata) + (nth 0 qdata)) + (math-sub (nth 1 tdata) + (nth 0 tdata)))))) + (while (> (length qdata) 2) + (setq pdata + (cons + (math-mul + '(float 5 -1) + (math-add + (math-div + (math-sub (nth 2 qdata) + (nth 1 qdata)) + (math-sub (nth 2 tdata) + (nth 1 tdata))) + (math-div + (math-sub (nth 1 qdata) + (nth 0 qdata)) + (math-sub (nth 1 tdata) + (nth 0 tdata))))) + pdata)) + (setq qdata (cdr qdata))) + (setq pdata + (cons + (math-div + (math-sub (nth 1 qdata) + (nth 0 qdata)) + (math-sub (nth 1 tdata) + (nth 0 tdata))) + pdata)) + (reverse pdata))) + +;;; Next, given two lists -- one of rates p0, p1, ..., pn and one of +;;; corresponding times t0, t1, ..., tn -- and an initial values q0, +;;; return a list q0, q1, ..., qn of the cumulative values. +;;; q0 is the initial value given. +;;; For i>0, qi is computed using the trapezoid rule: +;;; qi = q(i-1) + (1/2)(pi + p(i-1))(ti - t(i-1)) + +(defun math-nlfit-get-cumul-from-rates (tdata pdata q0) + (let* ((qdata (list q0))) + (while (cdr pdata) + (setq qdata + (cons + (math-add (car qdata) + (math-mul + (math-mul + '(float 5 -1) + (math-add (nth 1 pdata) (nth 0 pdata))) + (math-sub (nth 1 tdata) + (nth 0 tdata)))) + qdata)) + (setq pdata (cdr pdata)) + (setq tdata (cdr tdata))) + (reverse qdata))) + +;;; Given the qdata, pdata and tdata, find the parameters +;;; a, b and c that fit q = a/(1+b*exp(c*t)). +;;; a is found using the method described by de Sousa. +;;; b and c are found using least squares on the linearization +;;; log((a/q)-1) = log(b) + c*t +;;; In some cases (where the logistic curve may well be the wrong +;;; model), the computed a will be less than or equal to the maximum +;;; value of q in qdata; in which case the above linearization won't work. +;;; In this case, a will be replaced by a number slightly above +;;; the maximum value of q. + +(defun math-nlfit-find-qmax (qdata pdata tdata) + (let* ((ratios (math-map-binop 'math-div pdata qdata)) + (lsdata (math-nlfit-least-squares ratios tdata)) + (qmax (math-max-list (car qdata) (cdr qdata))) + (a (math-neg (math-div (nth 1 lsdata) (nth 0 lsdata))))) + (if (math-lessp a qmax) + (math-add '(float 5 -1) qmax) + a))) + +(defun math-nlfit-find-logistic-parameters (qdata pdata tdata) + (let* ((a (math-nlfit-find-qmax qdata pdata tdata)) + (newqdata + (mapcar (lambda (q) (calcFunc-ln (math-sub (math-div a q) 1))) + qdata)) + (bandc (math-nlfit-least-squares tdata newqdata))) + (list + a + (calcFunc-exp (nth 0 bandc)) + (nth 1 bandc)))) + +;;; Next, given the pdata and tdata, we can find the qdata if we know q0. +;;; We first try to find q0, using the fact that when p takes on its largest +;;; value, q is half of its maximum value. So we'll find the maximum value +;;; of q given various q0, and use bisection to approximate the correct q0. + +;;; First, given pdata and tdata, find what half of qmax would be if q0=0. + +(defun math-nlfit-find-qmaxhalf (pdata tdata) + (let ((pmax (math-max-list (car pdata) (cdr pdata))) + (qmh 0)) + (while (math-lessp (car pdata) pmax) + (setq qmh + (math-add qmh + (math-mul + (math-mul + '(float 5 -1) + (math-add (nth 1 pdata) (nth 0 pdata))) + (math-sub (nth 1 tdata) + (nth 0 tdata))))) + (setq pdata (cdr pdata)) + (setq tdata (cdr tdata))) + qmh)) + +;;; Next, given pdata and tdata, approximate q0. + +(defun math-nlfit-find-q0 (pdata tdata) + (let* ((qhalf (math-nlfit-find-qmaxhalf pdata tdata)) + (q0 (math-mul 2 qhalf)) + (qdata (math-nlfit-get-cumul-from-rates tdata pdata q0))) + (while (math-lessp (math-nlfit-find-qmax + (mapcar + (lambda (q) (math-add q0 q)) + qdata) + pdata tdata) + (math-mul + '(float 5 -1) + (math-add + q0 + qhalf))) + (setq q0 (math-add q0 qhalf))) + (let* ((qmin (math-sub q0 qhalf)) + (qmax q0) + (qt (math-nlfit-find-qmax + (mapcar + (lambda (q) (math-add q0 q)) + qdata) + pdata tdata)) + (i 0)) + (while (< i 10) + (setq q0 (math-mul '(float 5 -1) (math-add qmin qmax))) + (if (math-lessp + (math-nlfit-find-qmax + (mapcar + (lambda (q) (math-add q0 q)) + qdata) + pdata tdata) + (math-mul '(float 5 -1) (math-add qhalf q0))) + (setq qmin q0) + (setq qmax q0)) + (setq i (1+ i))) + (math-mul '(float 5 -1) (math-add qmin qmax))))) + +;;; To improve the approximations to the parameters, we can use +;;; Marquardt method as described in Schwarz's book. + +;;; Small numbers used in the Givens algorithm +(defvar math-nlfit-delta '(float 1 -8)) + +(defvar math-nlfit-epsilon '(float 1 -5)) + +;;; Maximum number of iterations +(defvar math-nlfit-max-its 100) + +;;; Next, we need some functions for dealing with vectors and +;;; matrices. For convenience, we'll work with Emacs lists +;;; as vectors, rather than Calc's vectors. + +(defun math-nlfit-set-elt (vec i x) + (setcar (nthcdr (1- i) vec) x)) + +(defun math-nlfit-get-elt (vec i) + (nth (1- i) vec)) + +(defun math-nlfit-make-matrix (i j) + (let ((row (make-list j 0)) + (mat nil) + (k 0)) + (while (< k i) + (setq mat (cons (copy-sequence row) mat)) + (setq k (1+ k))) + mat)) + +(defun math-nlfit-set-matx-elt (mat i j x) + (setcar (nthcdr (1- j) (nth (1- i) mat)) x)) + +(defun math-nlfit-get-matx-elt (mat i j) + (nth (1- j) (nth (1- i) mat))) + +;;; For solving the linearized system. +;;; (The Givens method, from Schwarz.) + +(defun math-nlfit-givens (C d) + (let* ((C (copy-tree C)) + (d (copy-tree d)) + (n (length (car C))) + (N (length C)) + (j 1) + (r (make-list N 0)) + (x (make-list N 0)) + w + gamma + sigma + rho) + (while (<= j n) + (let ((i (1+ j))) + (while (<= i N) + (let ((cij (math-nlfit-get-matx-elt C i j)) + (cjj (math-nlfit-get-matx-elt C j j))) + (when (not (math-equal 0 cij)) + (if (math-lessp (calcFunc-abs cjj) + (math-mul math-nlfit-delta (calcFunc-abs cij))) + (setq w (math-neg cij) + gamma 0 + sigma 1 + rho 1) + (setq w (math-mul + (calcFunc-sign cjj) + (calcFunc-sqrt + (math-add + (math-mul cjj cjj) + (math-mul cij cij)))) + gamma (math-div cjj w) + sigma (math-neg (math-div cij w))) + (if (math-lessp (calcFunc-abs sigma) gamma) + (setq rho sigma) + (setq rho (math-div (calcFunc-sign sigma) gamma)))) + (setq cjj w + cij rho) + (math-nlfit-set-matx-elt C j j w) + (math-nlfit-set-matx-elt C i j rho) + (let ((k (1+ j))) + (while (<= k n) + (let* ((cjk (math-nlfit-get-matx-elt C j k)) + (cik (math-nlfit-get-matx-elt C i k)) + (h (math-sub + (math-mul gamma cjk) (math-mul sigma cik)))) + (setq cik (math-add + (math-mul sigma cjk) + (math-mul gamma cik))) + (setq cjk h) + (math-nlfit-set-matx-elt C i k cik) + (math-nlfit-set-matx-elt C j k cjk) + (setq k (1+ k))))) + (let* ((di (math-nlfit-get-elt d i)) + (dj (math-nlfit-get-elt d j)) + (h (math-sub + (math-mul gamma dj) + (math-mul sigma di)))) + (setq di (math-add + (math-mul sigma dj) + (math-mul gamma di))) + (setq dj h) + (math-nlfit-set-elt d i di) + (math-nlfit-set-elt d j dj)))) + (setq i (1+ i)))) + (setq j (1+ j))) + (let ((i n) + s) + (while (>= i 1) + (math-nlfit-set-elt r i 0) + (setq s (math-nlfit-get-elt d i)) + (let ((k (1+ i))) + (while (<= k n) + (setq s (math-add s (math-mul (math-nlfit-get-matx-elt C i k) + (math-nlfit-get-elt x k)))) + (setq k (1+ k)))) + (math-nlfit-set-elt x i + (math-neg + (math-div s + (math-nlfit-get-matx-elt C i i)))) + (setq i (1- i)))) + (let ((i (1+ n))) + (while (<= i N) + (math-nlfit-set-elt r i (math-nlfit-get-elt d i)) + (setq i (1+ i)))) + (let ((j n)) + (while (>= j 1) + (let ((i N)) + (while (>= i (1+ j)) + (setq rho (math-nlfit-get-matx-elt C i j)) + (if (math-equal rho 1) + (setq gamma 0 + sigma 1) + (if (math-lessp (calcFunc-abs rho) 1) + (setq sigma rho + gamma (calcFunc-sqrt + (math-sub 1 (math-mul sigma sigma)))) + (setq gamma (math-div 1 (calcFunc-abs rho)) + sigma (math-mul (calcFunc-sign rho) + (calcFunc-sqrt + (math-sub 1 (math-mul gamma gamma))))))) + (let ((ri (math-nlfit-get-elt r i)) + (rj (math-nlfit-get-elt r j)) + h) + (setq h (math-add (math-mul gamma rj) + (math-mul sigma ri))) + (setq ri (math-sub + (math-mul gamma ri) + (math-mul sigma rj))) + (setq rj h) + (math-nlfit-set-elt r i ri) + (math-nlfit-set-elt r j rj)) + (setq i (1- i)))) + (setq j (1- j)))) + + x)) + +(defun math-nlfit-jacobian (grad xlist parms &optional slist) + (let ((j nil)) + (while xlist + (let ((row (apply grad (car xlist) parms))) + (setq j + (cons + (if slist + (mapcar (lambda (x) (math-div x (car slist))) row) + row) + j))) + (setq slist (cdr slist)) + (setq xlist (cdr xlist))) + (reverse j))) + +(defun math-nlfit-make-ident (l n) + (let ((m (math-nlfit-make-matrix n n)) + (i 1)) + (while (<= i n) + (math-nlfit-set-matx-elt m i i l) + (setq i (1+ i))) + m)) + +(defun math-nlfit-chi-sq (xlist ylist parms fn &optional slist) + (let ((cs 0)) + (while xlist + (let ((c + (math-sub + (apply fn (car xlist) parms) + (car ylist)))) + (if slist + (setq c (math-div c (car slist)))) + (setq cs + (math-add cs + (math-mul c c)))) + (setq xlist (cdr xlist)) + (setq ylist (cdr ylist)) + (setq slist (cdr slist))) + cs)) + +(defun math-nlfit-init-lambda (C) + (let ((l 0) + (n (length (car C))) + (N (length C))) + (while C + (let ((row (car C))) + (while row + (setq l (math-add l (math-mul (car row) (car row)))) + (setq row (cdr row)))) + (setq C (cdr C))) + (calcFunc-sqrt (math-div l (math-mul n N))))) + +(defun math-nlfit-make-Ctilda (C l) + (let* ((n (length (car C))) + (bot (math-nlfit-make-ident l n))) + (append C bot))) + +(defun math-nlfit-make-d (fn xdata ydata parms &optional sdata) + (let ((d nil)) + (while xdata + (setq d (cons + (let ((dd (math-sub (apply fn (car xdata) parms) + (car ydata)))) + (if sdata (math-div dd (car sdata)) dd)) + d)) + (setq xdata (cdr xdata)) + (setq ydata (cdr ydata)) + (setq sdata (cdr sdata))) + (reverse d))) + +(defun math-nlfit-make-dtilda (d n) + (append d (make-list n 0))) + +(defun math-nlfit-fit (xlist ylist parms fn grad &optional slist) + (let* + ((C (math-nlfit-jacobian grad xlist parms slist)) + (d (math-nlfit-make-d fn xlist ylist parms slist)) + (chisq (math-nlfit-chi-sq xlist ylist parms fn slist)) + (lambda (math-nlfit-init-lambda C)) + (really-done nil) + (iters 0)) + (while (and + (not really-done) + (< iters math-nlfit-max-its)) + (setq iters (1+ iters)) + (let ((done nil)) + (while (not done) + (let* ((Ctilda (math-nlfit-make-Ctilda C lambda)) + (dtilda (math-nlfit-make-dtilda d (length (car C)))) + (zeta (math-nlfit-givens Ctilda dtilda)) + (newparms (math-map-binop 'math-add (copy-tree parms) zeta)) + (newchisq (math-nlfit-chi-sq xlist ylist newparms fn slist))) + (if (math-lessp newchisq chisq) + (progn + (if (math-lessp + (math-div + (math-sub chisq newchisq) newchisq) math-nlfit-epsilon) + (setq really-done t)) + (setq lambda (math-div lambda 10)) + (setq chisq newchisq) + (setq parms newparms) + (setq done t)) + (setq lambda (math-mul lambda 10))))) + (setq C (math-nlfit-jacobian grad xlist parms slist)) + (setq d (math-nlfit-make-d fn xlist ylist parms slist)))) + (list chisq parms))) + +;;; The functions that describe our models, and their gradients. + +(defun math-nlfit-s-logistic-fn (x a b c) + (math-div a (math-add 1 (math-mul b (calcFunc-exp (math-mul c x)))))) + +(defun math-nlfit-s-logistic-grad (x a b c) + (let* ((ep (calcFunc-exp (math-mul c x))) + (d (math-add 1 (math-mul b ep))) + (d2 (math-mul d d))) + (list + (math-div 1 d) + (math-neg (math-div (math-mul a ep) d2)) + (math-neg (math-div (math-mul a (math-mul b (math-mul x ep))) d2))))) + +(defun math-nlfit-b-logistic-fn (x a c d) + (let ((ex (calcFunc-exp (math-mul c (math-sub x d))))) + (math-div + (math-mul a ex) + (math-sqr + (math-add + 1 ex))))) + +(defun math-nlfit-b-logistic-grad (x a c d) + (let* ((ex (calcFunc-exp (math-mul c (math-sub x d)))) + (ex1 (math-add 1 ex)) + (xd (math-sub x d))) + (list + (math-div + ex + (math-sqr ex1)) + (math-sub + (math-div + (math-mul a (math-mul xd ex)) + (math-sqr ex1)) + (math-div + (math-mul 2 (math-mul a (math-mul xd (math-sqr ex)))) + (math-pow ex1 3))) + (math-sub + (math-div + (math-mul 2 (math-mul a (math-mul c (math-sqr ex)))) + (math-pow ex1 3)) + (math-div + (math-mul a (math-mul c ex)) + (math-sqr ex1)))))) + +;;; Functions to get the final covariance matrix and the sdevs + +(defun math-nlfit-find-covar (grad xlist pparms) + (let ((j nil)) + (while xlist + (setq j (cons (cons 'vec (apply grad (car xlist) pparms)) j)) + (setq xlist (cdr xlist))) + (setq j (cons 'vec (reverse j))) + (setq j + (math-mul + (calcFunc-trn j) j)) + (calcFunc-inv j))) + +(defun math-nlfit-get-sigmas (grad xlist pparms chisq) + (let* ((sgs nil) + (covar (math-nlfit-find-covar grad xlist pparms)) + (n (1- (length covar))) + (N (length xlist)) + (i 1)) + (when (> N n) + (while (<= i n) + (setq sgs (cons (calcFunc-sqrt (nth i (nth i covar))) sgs)) + (setq i (1+ i))) + (setq sgs (reverse sgs))) + (list sgs covar))) + +;;; Now the Calc functions + +(defun math-nlfit-s-logistic-params (xdata ydata) + (let ((pdata (math-nlfit-get-rates-from-cumul xdata ydata))) + (math-nlfit-find-logistic-parameters ydata pdata xdata))) + +(defun math-nlfit-b-logistic-params (xdata ydata) + (let* ((q0 (math-nlfit-find-q0 ydata xdata)) + (qdata (math-nlfit-get-cumul-from-rates xdata ydata q0)) + (abc (math-nlfit-find-logistic-parameters qdata ydata xdata)) + (B (nth 1 abc)) + (C (nth 2 abc)) + (A (math-neg + (math-mul + (nth 0 abc) + (math-mul B C)))) + (D (math-neg (math-div (calcFunc-ln B) C))) + (A (math-div A B))) + (list A C D))) + +;;; Some functions to turn the parameter lists and variables +;;; into the appropriate functions. + +(defun math-nlfit-s-logistic-solnexpr (pms var) + (let ((a (nth 0 pms)) + (b (nth 1 pms)) + (c (nth 2 pms))) + (list '/ a + (list '+ + 1 + (list '* + b + (calcFunc-exp + (list '* + c + var))))))) + +(defun math-nlfit-b-logistic-solnexpr (pms var) + (let ((a (nth 0 pms)) + (c (nth 1 pms)) + (d (nth 2 pms))) + (list '/ + (list '* + a + (calcFunc-exp + (list '* + c + (list '- var d)))) + (list '^ + (list '+ + 1 + (calcFunc-exp + (list '* + c + (list '- var d)))) + 2)))) + +(defun math-nlfit-enter-result (n prefix vals) + (setq calc-aborted-prefix prefix) + (calc-pop-push-record-list n prefix vals) + (calc-handle-whys)) + +(defun math-nlfit-fit-curve (fn grad solnexpr initparms &optional sdv) + (calc-slow-wrapper + (let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit))) + (calc-display-working-message nil) + (data (calc-top 1)) + (xdata (cdr (car (cdr data)))) + (ydata (cdr (car (cdr (cdr data))))) + (sdata (if (math-contains-sdev-p ydata) + (mapcar (lambda (x) (math-get-sdev x t)) ydata) + nil)) + (ydata (mapcar (lambda (x) (math-get-value x)) ydata)) + (calc-curve-varnames nil) + (calc-curve-coefnames nil) + (calc-curve-nvars 1) + (fitvars (calc-get-fit-variables 1 3)) + (var (nth 1 calc-curve-varnames)) + (parms (cdr calc-curve-coefnames)) + (parmguess + (funcall initparms xdata ydata)) + (fit (math-nlfit-fit xdata ydata parmguess fn grad sdata)) + (finalparms (nth 1 fit)) + (sigmacovar + (if sdevv + (math-nlfit-get-sigmas grad xdata finalparms (nth 0 fit)))) + (sigmas + (if sdevv + (nth 0 sigmacovar))) + (finalparms + (if sigmas + (math-map-binop + (lambda (x y) (list 'sdev x y)) finalparms sigmas) + finalparms)) + (soln (funcall solnexpr finalparms var))) + (let ((calc-fit-to-trail t) + (traillist nil)) + (while parms + (setq traillist (cons (list 'calcFunc-eq (car parms) (car finalparms)) + traillist)) + (setq finalparms (cdr finalparms)) + (setq parms (cdr parms))) + (setq traillist (calc-normalize (cons 'vec (nreverse traillist)))) + (cond ((eq sdv 'calcFunc-efit) + (math-nlfit-enter-result 1 "efit" soln)) + ((eq sdv 'calcFunc-xfit) + (let (sln) + (setq sln + (list 'vec + soln + traillist + (nth 1 sigmacovar) + '(vec) + (nth 0 fit) + (let ((n (length xdata)) + (m (length finalparms))) + (if (and sdata (> n m)) + (calcFunc-utpc (nth 0 fit) + (- n m)) + '(var nan var-nan))))) + (math-nlfit-enter-result 1 "xfit" sln))) + (t + (math-nlfit-enter-result 1 "fit" soln))) + (calc-record traillist "parm"))))) + +(defun calc-fit-s-shaped-logistic-curve (arg) + (interactive "P") + (math-nlfit-fit-curve 'math-nlfit-s-logistic-fn + 'math-nlfit-s-logistic-grad + 'math-nlfit-s-logistic-solnexpr + 'math-nlfit-s-logistic-params + arg)) + +(defun calc-fit-bell-shaped-logistic-curve (arg) + (interactive "P") + (math-nlfit-fit-curve 'math-nlfit-b-logistic-fn + 'math-nlfit-b-logistic-grad + 'math-nlfit-b-logistic-solnexpr + 'math-nlfit-b-logistic-params + arg)) + +(defun calc-fit-hubbert-linear-curve (&optional sdv) + (calc-slow-wrapper + (let* ((sdevv (or (eq sdv 'calcFunc-efit) (eq sdv 'calcFunc-xfit))) + (calc-display-working-message nil) + (data (calc-top 1)) + (qdata (cdr (car (cdr data)))) + (pdata (cdr (car (cdr (cdr data))))) + (sdata (if (math-contains-sdev-p pdata) + (mapcar (lambda (x) (math-get-sdev x t)) pdata) + nil)) + (pdata (mapcar (lambda (x) (math-get-value x)) pdata)) + (poverqdata (math-map-binop 'math-div pdata qdata)) + (parmvals (math-nlfit-least-squares qdata poverqdata sdata sdevv)) + (finalparms (list (nth 0 parmvals) + (math-neg + (math-div (nth 0 parmvals) + (nth 1 parmvals))))) + (calc-curve-varnames nil) + (calc-curve-coefnames nil) + (calc-curve-nvars 1) + (fitvars (calc-get-fit-variables 1 2)) + (var (nth 1 calc-curve-varnames)) + (parms (cdr calc-curve-coefnames)) + (soln (list '* (nth 0 finalparms) + (list '- 1 + (list '/ var (nth 1 finalparms)))))) + (let ((calc-fit-to-trail t) + (traillist nil)) + (setq traillist + (list 'vec + (list 'calcFunc-eq (nth 0 parms) (nth 0 finalparms)) + (list 'calcFunc-eq (nth 1 parms) (nth 1 finalparms)))) + (cond ((eq sdv 'calcFunc-efit) + (math-nlfit-enter-result 1 "efit" soln)) + ((eq sdv 'calcFunc-xfit) + (let (sln + (chisq + (math-nlfit-chi-sq + qdata poverqdata + (list (nth 1 (nth 0 finalparms)) + (nth 1 (nth 1 finalparms))) + (lambda (x a b) + (math-mul a + (math-sub + 1 + (math-div x b)))) + sdata))) + (setq sln + (list 'vec + soln + traillist + (nth 2 parmvals) + (list + 'vec + '(calcFunc-fitdummy 1) + (list 'calcFunc-neg + (list '/ + '(calcFunc-fitdummy 1) + '(calcFunc-fitdummy 2)))) + chisq + (let ((n (length qdata))) + (if (and sdata (> n 2)) + (calcFunc-utpc + chisq + (- n 2)) + '(var nan var-nan))))) + (math-nlfit-enter-result 1 "xfit" sln))) + (t + (math-nlfit-enter-result 1 "fit" soln))) + (calc-record traillist "parm"))))) + +(provide 'calc-nlfit) + +;; arch-tag: 6eba3cd6-f48b-4a84-8174-10c15a024928 diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el index 29396a57dc1..608d16fbab8 100644 --- a/lisp/calc/calc-poly.el +++ b/lisp/calc/calc-poly.el @@ -982,10 +982,16 @@ (defun math-padded-polynomial (expr var deg) + "Return a polynomial as list of coefficients. +If EXPR is of the form \"a + bx + cx^2 + ...\" in the variable VAR, return +the list (a b c ...) with at least DEG elements, else return NIL." (let ((p (math-is-polynomial expr var deg))) (append p (make-list (- deg (length p)) 0)))) (defun math-partial-fractions (r den var) + "Return R divided by DEN expressed in partial fractions of VAR. +All whole factors of DEN have already been split off from R. +If no partial fraction representation can be found, return nil." (let* ((fden (calcFunc-factors den var)) (tdeg (math-polynomial-p den var)) (fp fden) diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index e5642002be0..124558c4ca0 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -32,6 +32,11 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function edmacro-format-keys "edmacro" (macro &optional verbose)) +(declare-function edmacro-parse-keys "edmacro" (string &optional need-vector)) +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + (defun calc-equal-to (arg) (interactive "P") @@ -568,7 +573,7 @@ (set-buffer calc-buf) (let ((calc-user-parse-tables nil) (calc-language nil) - (math-expr-opers math-standard-opers) + (math-expr-opers (math-standard-ops)) (calc-hashes-used 0)) (math-read-expr (if (string-match ",[ \t]*\\'" str) diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index 6191a0f2e05..5ffabe4adba 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -127,7 +127,7 @@ (cond ((and (memq var '(var-e var-i var-pi var-phi var-gamma)) (eq (car-safe old) 'special-const)) - (setq msg (format " (Note: Built-in definition of %s has been lost)" + (setq msg (format " (Note: Built-in definition of %s has been lost)" (calc-var-name var)))) ((and (memq var '(var-inf var-uinf var-nan)) (null old)) @@ -172,28 +172,28 @@ () (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map)) (define-key calc-var-name-map " " 'self-insert-command) - (mapcar (function - (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-digit))) - "0123456789") - (mapcar (function - (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-oper))) - "+-*/^|")) + (mapc (function + (lambda (x) + (define-key calc-var-name-map (char-to-string x) + 'calcVar-digit))) + "0123456789") + (mapc (function + (lambda (x) + (define-key calc-var-name-map (char-to-string x) + 'calcVar-oper))) + "+-*/^|")) (defvar calc-store-opers) (defun calc-read-var-name (prompt &optional calc-store-opers) (setq calc-given-value nil calc-aborted-prefix nil) - (let ((var (concat + (let ((var (concat "var-" (let ((minibuffer-completion-table - (mapcar (lambda (x) (substring x 4)) + (mapcar (lambda (x) (substring x 4)) (all-completions "var-" obarray))) - (minibuffer-completion-predicate + (minibuffer-completion-predicate (lambda (x) (boundp (intern (concat "var-" x))))) (minibuffer-completion-confirm t)) (read-from-minibuffer prompt nil calc-var-name-map nil))))) @@ -401,7 +401,7 @@ (unless (string= sconst "") (let ((value (cdr (assoc sconst sc)))) (or var (setq var (calc-read-var-name - (format "Copy special constant %s, to: " + (format "Copy special constant %s, to: " sconst)))) (if var (let ((msg (calc-store-value var value ""))) @@ -417,7 +417,7 @@ (or value (error "No such variable: \"%s\"" (calc-var-name var1))) (or var2 (setq var2 (calc-read-var-name - (format "Copy variable: %s, to: " + (format "Copy variable: %s, to: " (calc-var-name var1))))) (if var2 (let ((msg (calc-store-value var2 value ""))) diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el index 10002dcb4e5..8840ad827e1 100644 --- a/lisp/calc/calc-stuff.el +++ b/lisp/calc/calc-stuff.el @@ -191,7 +191,7 @@ With a prefix, push that prefix as a number onto the stack." math-eval-rules-cache-tag t math-format-date-cache nil math-holidays-cache-tag t) - (mapcar (function (lambda (x) (set x -100))) math-cache-list) + (mapc (function (lambda (x) (set x -100))) math-cache-list) (unless inhibit-msg (message "All internal calculator caches have been reset")))) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index f648a37cb7f..27d76fe4b8a 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -40,45 +40,47 @@ ;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov) ;;; Updated April 2002 by Jochen Küpper -;;; for CODATA 1998 see one of -;;; - Journal of Physical and Chemical Reference Data, 28(6), 1713-1852, 1999. -;;; - Reviews of Modern Physics, 72(2), 351-495, 2000. -;;; for CODATA 2005 see -;;; - http://physics.nist.gov/cuu/Constants/index.html +;;; Updated August 2007, using +;;; CODATA (http://physics.nist.gov/cuu/Constants/index.html) +;;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) +;;; ESUWM (Encyclopaedia of Scientific Units, Weights and +;;; Measures, by François Cardarelli) +;;; All conversions are exact unless otherwise noted. (defvar math-standard-units '( ;; Length ( m nil "*Meter" ) - ( in "2.54 cm" "Inch" ) + ( in "254*10^(-2) cm" "Inch" ) ( ft "12 in" "Foot" ) ( yd "3 ft" "Yard" ) ( mi "5280 ft" "Mile" ) - ( au "149597870691 m" "Astronomical Unit" ) ;; NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html) - ( lyr "9460536207068016 m" "Light Year" ) - ( pc "206264.80625 au" "Parsec" ) + ( au "149597870691. m" "Astronomical Unit" ) + ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html) + ( lyr "c yr" "Light Year" ) + ( pc "3.0856775854e16 m" "Parsec" ) ;; (approx) ESUWM ( nmi "1852 m" "Nautical Mile" ) ( fath "6 ft" "Fathom" ) ( mu "1 um" "Micron" ) ( mil "in/1000" "Mil" ) ( point "in/72" "Point (1/72 inch)" ) - ( Ang "1e-10 m" "Angstrom" ) + ( Ang "10^(-10) m" "Angstrom" ) ( mfi "mi+ft+in" "Miles + feet + inches" ) ;; TeX lengths - ( texpt "in/72.27" "Point (TeX conventions)" ) + ( texpt "(100/7227) in" "Point (TeX conventions)" ) ( texpc "12 texpt" "Pica" ) ( texbp "point" "Big point (TeX conventions)" ) - ( texdd "1238/1157 texpt" "Didot point" ) + ( texdd "(1238/1157) texpt" "Didot point" ) ( texcc "12 texdd" "Cicero" ) - ( texsp "1/66536 texpt" "Scaled TeX point" ) + ( texsp "(1/65536) texpt" "Scaled TeX point" ) ;; Area ( hect "10000 m^2" "*Hectare" ) ( a "100 m^2" "Are") ( acre "mi^2 / 640" "Acre" ) - ( b "1e-28 m^2" "Barn" ) + ( b "10^(-28) m^2" "Barn" ) ;; Volume - ( L "1e-3 m^3" "*Liter" ) + ( L "10^(-3) m^3" "*Liter" ) ( l "L" "Liter" ) ( gal "4 qt" "US Gallon" ) ( qt "2 pt" "Quart" ) @@ -87,10 +89,12 @@ ( ozfl "2 tbsp" "Fluid Ounce" ) ( floz "2 tbsp" "Fluid Ounce" ) ( tbsp "3 tsp" "Tablespoon" ) - ( tsp "4.92892159375 ml" "Teaspoon" ) + ;; ESUWM defines a US gallon as 231 in^3. + ;; That gives the following exact value for tsp. + ( tsp "492892159375*10^(-11) ml" "Teaspoon" ) ( vol "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" ) - ( galC "4.54609 L" "Canadian Gallon" ) - ( galUK "4.546092 L" "UK Gallon" ) + ( galC "galUK" "Canadian Gallon" ) + ( galUK "454609*10^(-5) L" "UK Gallon" ) ;; NIST ;; Time ( s nil "*Second" ) @@ -100,44 +104,44 @@ ( day "24 hr" "Day" ) ( wk "7 day" "Week" ) ( hms "wk+day+hr+min+s" "Hours, minutes, seconds" ) - ( yr "365.25 day" "Year" ) + ( yr "365.25 day" "Year" ) ;; (approx, but keep) ( Hz "1/s" "Hertz" ) ;; Speed ( mph "mi/hr" "*Miles per hour" ) ( kph "km/hr" "Kilometers per hour" ) ( knot "nmi/hr" "Knot" ) - ( c "299792458 m/s" "Speed of light" ) ;;; CODATA 2005 + ( c "299792458 m/s" "Speed of light" ) ;;; CODATA ;; Acceleration - ( ga "9.80665 m/s^2" "*\"g\" acceleration" ) ;; CODATA 2005 + ( ga "980665*10^(-5) m/s^2" "*\"g\" acceleration" ) ;; CODATA ;; Mass ( g nil "*Gram" ) ( lb "16 oz" "Pound (mass)" ) - ( oz "28.349523125 g" "Ounce (mass)" ) + ( oz "28349523125*10^(-9) g" "Ounce (mass)" ) ;; ESUWM ( ton "2000 lb" "Ton" ) ( tpo "ton+lb+oz" "Tons + pounds + ounces (mass)" ) ( t "1000 kg" "Metric ton" ) - ( tonUK "1016.0469088 kg" "UK ton" ) + ( tonUK "10160469088*10^(-7) kg" "UK ton" ) ;; ESUWM ( lbt "12 ozt" "Troy pound" ) - ( ozt "31.103475 g" "Troy ounce" ) - ( ct ".2 g" "Carat" ) - ( u "1.66053886e-27 kg" "Unified atomic mass" ) ;; CODATA 2005 + ( ozt "31.10347680 g" "Troy ounce" ) ;; (approx) ESUWM + ( ct "(2/10) g" "Carat" ) ;; ESUWM + ( u "1.660538782e-27 kg" "Unified atomic mass" );;(approx) CODATA ;; Force ( N "m kg/s^2" "*Newton" ) - ( dyn "1e-5 N" "Dyne" ) + ( dyn "10^(-5) N" "Dyne" ) ( gf "ga g" "Gram (force)" ) - ( lbf "4.44822161526 N" "Pound (force)" ) + ( lbf "ga lb" "Pound (force)" ) ( kip "1000 lbf" "Kilopound (force)" ) - ( pdl "0.138255 N" "Poundal" ) + ( pdl "138254954376*10^(-12) N" "Poundal" ) ;; ESUWM ;; Energy ( J "N m" "*Joule" ) - ( erg "1e-7 J" "Erg" ) - ( cal "4.1868 J" "International Table Calorie" ) - ( Btu "1055.05585262 J" "International Table Btu" ) + ( erg "10^(-7) J" "Erg" ) + ( cal "4.18674 J" "International Table Calorie" );;(approx) ESUWM + ( Btu "105505585262*10^(-8) J" "International Table Btu" ) ;; ESUWM ( eV "ech V" "Electron volt" ) ( ev "eV" "Electron volt" ) ( therm "105506000 J" "EEC therm" ) @@ -151,7 +155,7 @@ ;; Power ( W "J/s" "*Watt" ) - ( hp "745.7 W" "Horsepower" ) + ( hp "745.699871581 W" "Horsepower" ) ;;(approx) ESUWM ;; Temperature ( K nil "*Degree Kelvin" K ) @@ -164,24 +168,24 @@ ;; Pressure ( Pa "N/m^2" "*Pascal" ) - ( bar "1e5 Pa" "Bar" ) - ( atm "101325 Pa" "Standard atmosphere" ) ;; CODATA 2005 - ( Torr " 1.333224e2 Pa" "Torr" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) + ( bar "10^5 Pa" "Bar" ) + ( atm "101325 Pa" "Standard atmosphere" ) ;; CODATA + ( Torr "1.333224e2 Pa" "Torr" ) ;;(approx) NIST ( mHg "1000 Torr" "Meter of mercury" ) - ( inHg "25.4 mmHg" "Inch of mercury" ) - ( inH2O "2.490889e2 Pa" "Inch of water" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) - ( psi "6894.75729317 Pa" "Pound per square inch" ) + ( inHg "254*10^(-1) mmHg" "Inch of mercury" ) + ( inH2O "2.490889e2 Pa" "Inch of water" ) ;;(approx) NIST + ( psi "lbf/in^2" "Pounds per square inch" ) ;; Viscosity - ( P "0.1 Pa s" "*Poise" ) - ( St "1e-4 m^2/s" "Stokes" ) + ( P "(1/10) Pa s" "*Poise" ) + ( St "10^(-4) m^2/s" "Stokes" ) ;; Electromagnetism ( A nil "*Ampere" ) ( C "A s" "Coulomb" ) ( Fdy "ech Nav" "Faraday" ) - ( e "1.60217653e-19 C" "Elementary charge" ) ;; CODATA 2005 - ( ech "1.60217653e-19 C" "Elementary charge" ) ;; CODATA 2005 + ( e "ech" "Elementary charge" ) + ( ech "1.602176487e-19 C" "Elementary charge" ) ;;(approx) CODATA ( V "W/A" "Volt" ) ( ohm "V/A" "Ohm" ) ( mho "A/V" "Mho" ) @@ -189,26 +193,26 @@ ( F "C/V" "Farad" ) ( H "Wb/A" "Henry" ) ( T "Wb/m^2" "Tesla" ) - ( Gs "1e-4 T" "Gauss" ) + ( Gs "10^(-4) T" "Gauss" ) ( Wb "V s" "Weber" ) ;; Luminous intensity ( cd nil "*Candela" ) - ( sb "1e4 cd/m^2" "Stilb" ) + ( sb "10000 cd/m^2" "Stilb" ) ( lm "cd sr" "Lumen" ) ( lx "lm/m^2" "Lux" ) - ( ph "1e4 lx" "Phot" ) - ( fc "10.76391 lx" "Footcandle" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) - ( lam "1e4 lm/m^2" "Lambert" ) - ( flam "3.426259 cd/m^2" "Footlambert" ) ;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html) + ( ph "10000 lx" "Phot" ) + ( fc "10.76391 lx" "Footcandle" ) ;;(approx) NIST + ( lam "10000 lm/m^2" "Lambert" ) + ( flam "3.426259 cd/m^2" "Footlambert" ) ;;(approx) NIST ;; Radioactivity ( Bq "1/s" "*Becquerel" ) - ( Ci "3.7e10 Bq" "Curie" ) + ( Ci "37*10^9 Bq" "Curie" ) ;; ESUWM ( Gy "J/kg" "Gray" ) ( Sv "Gy" "Sievert" ) - ( R "2.58e-4 C/kg" "Roentgen" ) - ( rd ".01 Gy" "Rad" ) + ( R "258*10^(-6) C/kg" "Roentgen" ) ;; NIST + ( rd "(1/100) Gy" "Rad" ) ( rem "rd" "Rem" ) ;; Amount of substance @@ -228,23 +232,24 @@ ( sr nil "*Steradian" ) ;; Other physical quantities - ( h "6.6260693e-34 J s" "*Planck's constant" ) ;; CODATA 2005 - ( hbar "h / 2 pi" "Planck's constant" ) - ( mu0 "4 pi 1e-7 H/m" "Permeability of vacuum" ) - ( G "6.6742e-11 m^3/kg^1/s^2" "Gravitational constant" ) ;; CODATA 2005 - ( Nav "6.02214115e23 / mol" "Avagadro's constant" ) ;; CODATA 2005 - ( me "9.1093826e-31 kg" "Electron rest mass" ) ;; CODATA 2005 - ( mp "1.67262171e-27 kg" "Proton rest mass" ) ;; CODATA 2005 - ( mn "1.67492728e-27 kg" "Neutron rest mass" ) ;; CODATA 2005 - ( mmu "1.88353140e-28 kg" "Muon rest mass" ) ;; CODATA 2005 - ( Ryd "10973731.568525 /m" "Rydberg's constant" ) ;; CODATA 2005 - ( k "1.3806505e-23 J/K" "Boltzmann's constant" ) ;; CODATA 2005 - ( alpha "7.297352568e-3" "Fine structure constant" ) ;; CODATA 2005 - ( muB "927.400949e-26 J/T" "Bohr magneton" ) ;; CODATA 2005 - ( muN "5.05078343e-27 J/T" "Nuclear magneton" ) ;; CODATA 2005 - ( mue "-928.476412e-26 J/T" "Electron magnetic moment" ) ;; CODATA 2005 - ( mup "1.41060671e-26 J/T" "Proton magnetic moment" ) ;; CODATA 2005 - ( R0 "8.314472 J/mol/K" "Molar gas constant" ) ;; CODATA 2005 + ;; The values are from CODATA, and are approximate. + ( h "6.62606896e-34 J s" "*Planck's constant" ) + ( hbar "h / (2 pi)" "Planck's constant" ) + ( mu0 "4 pi 10^(-7) H/m" "Permeability of vacuum" ) + ( G "6.67428e-11 m^3/(kg s^2)" "Gravitational constant" ) + ( Nav "6.02214179e23 / mol" "Avagadro's constant" ) + ( me "9.10938215e-31 kg" "Electron rest mass" ) + ( mp "1.672621637e-27 kg" "Proton rest mass" ) + ( mn "1.674927211e-27 kg" "Neutron rest mass" ) + ( mmu "1.88353130e-28 kg" "Muon rest mass" ) + ( Ryd "10973731.568527 /m" "Rydberg's constant" ) + ( k "1.3806504e-23 J/K" "Boltzmann's constant" ) + ( alpha "7.2973525376e-3" "Fine structure constant" ) + ( muB "927.400915e-26 J/T" "Bohr magneton" ) + ( muN "5.05078324e-27 J/T" "Nuclear magneton" ) + ( mue "-928.476377e-26 J/T" "Electron magnetic moment" ) + ( mup "1.410606662e-26 J/T" "Proton magnetic moment" ) + ( R0 "8.314472 J/(mol K)" "Molar gas constant" ) ( V0 "22.710981e-3 m^3/mol" "Standard volume of ideal gas" ))) @@ -255,35 +260,35 @@ If this is changed, be sure to set math-units-table to nil to ensure that the combined units table will be rebuilt.") (defvar math-unit-prefixes - '( ( ?Y (float 1 24) "Yotta" ) - ( ?Z (float 1 21) "Zetta" ) - ( ?E (float 1 18) "Exa" ) - ( ?P (float 1 15) "Peta" ) - ( ?T (float 1 12) "Tera" ) - ( ?G (float 1 9) "Giga" ) - ( ?M (float 1 6) "Mega" ) - ( ?k (float 1 3) "Kilo" ) - ( ?K (float 1 3) "Kilo" ) - ( ?h (float 1 2) "Hecto" ) - ( ?H (float 1 2) "Hecto" ) - ( ?D (float 1 1) "Deka" ) - ( 0 (float 1 0) nil ) - ( ?d (float 1 -1) "Deci" ) - ( ?c (float 1 -2) "Centi" ) - ( ?m (float 1 -3) "Milli" ) - ( ?u (float 1 -6) "Micro" ) - ( ?n (float 1 -9) "Nano" ) - ( ?p (float 1 -12) "Pico" ) - ( ?f (float 1 -15) "Femto" ) - ( ?a (float 1 -18) "Atto" ) - ( ?z (float 1 -21) "zepto" ) - ( ?y (float 1 -24) "yocto" ))) + '( ( ?Y (^ 10 24) "Yotta" ) + ( ?Z (^ 10 21) "Zetta" ) + ( ?E (^ 10 18) "Exa" ) + ( ?P (^ 10 15) "Peta" ) + ( ?T (^ 10 12) "Tera" ) + ( ?G (^ 10 9) "Giga" ) + ( ?M (^ 10 6) "Mega" ) + ( ?k (^ 10 3) "Kilo" ) + ( ?K (^ 10 3) "Kilo" ) + ( ?h (^ 10 2) "Hecto" ) + ( ?H (^ 10 2) "Hecto" ) + ( ?D (^ 10 1) "Deka" ) + ( 0 (^ 10 0) nil ) + ( ?d (^ 10 -1) "Deci" ) + ( ?c (^ 10 -2) "Centi" ) + ( ?m (^ 10 -3) "Milli" ) + ( ?u (^ 10 -6) "Micro" ) + ( ?n (^ 10 -9) "Nano" ) + ( ?p (^ 10 -12) "Pico" ) + ( ?f (^ 10 -15) "Femto" ) + ( ?a (^ 10 -18) "Atto" ) + ( ?z (^ 10 -21) "zepto" ) + ( ?y (^ 10 -24) "yocto" ))) (defvar math-standard-units-systems '( ( base nil ) - ( si ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) ) - ( mks ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) ) - ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) ))) + ( si ( ( g '(/ (var kg var-kg) 1000) ) ) ) + ( mks ( ( g '(/ (var kg var-kg) 1000) ) ) ) + ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) ))) (defvar math-units-table nil "Internal units table derived from math-defined-units. @@ -321,13 +326,67 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (math-simplify-units (math-mul expr (nth pos units)))))))) +(defun math-get-standard-units (expr) + "Return the standard units in EXPR." + (math-simplify-units + (math-extract-units + (math-to-standard-units expr nil)))) + +(defun math-get-units (expr) + "Return the units in EXPR." + (math-simplify-units + (math-extract-units expr))) + +(defun math-make-unit-string (expr) + "Return EXPR in string form. +If EXPR is nil, return nil." + (if expr + (let ((cexpr (math-compose-expr expr 0))) + (replace-regexp-in-string + " / " "/" + (if (stringp cexpr) + cexpr + (math-composition-to-string cexpr)))))) + +(defvar math-default-units-table + (make-hash-table :test 'equal) + "A table storing previously converted units.") + +(defun math-get-default-units (expr) + "Get default units to use when converting the units in EXPR." + (let* ((units (math-get-units expr)) + (standard-units (math-get-standard-units expr)) + (default-units (gethash + standard-units + math-default-units-table))) + (if (equal units (car default-units)) + (math-make-unit-string (cadr default-units)) + (math-make-unit-string (car default-units))))) + +(defun math-put-default-units (expr) + "Put the units in EXPR in the default units table." + (let* ((units (math-get-units expr)) + (standard-units (math-get-standard-units expr)) + (default-units (gethash + standard-units + math-default-units-table))) + (cond + ((not default-units) + (puthash standard-units (list units) math-default-units-table)) + ((not (equal units (car default-units))) + (puthash standard-units + (list units (car default-units)) + math-default-units-table))))) + + (defun calc-convert-units (&optional old-units new-units) (interactive) (calc-slow-wrapper (let ((expr (calc-top-n 1)) (uoldname nil) unew - units) + units + defunits) (unless (math-units-in-expr-p expr t) (let ((uold (or old-units (progn @@ -343,16 +402,31 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (error "Bad format in units expression: %s" (nth 1 uold))) (setq expr (math-mul expr uold)))) (unless new-units - (setq new-units (read-string (if uoldname - (concat "Old units: " - uoldname - ", new units: ") - "New units: ")))) + (setq defunits (math-get-default-units expr)) + (setq new-units + (read-string (concat + (if uoldname + (concat "Old units: " + uoldname + ", new units") + "New units") + (if defunits + (concat + " (default " + defunits + "): ") + ": ")))) + + (if (and + (string= new-units "") + defunits) + (setq new-units defunits))) (when (string-match "\\` */" new-units) (setq new-units (concat "1" new-units))) (setq units (math-read-expr new-units)) (when (eq (car-safe units) 'error) (error "Bad format in units expression: %s" (nth 2 units))) + (math-put-default-units units) (let ((unew (math-units-in-expr-p units t)) (std (and (eq (car-safe units) 'var) (assq (nth 1 units) math-standard-units-systems)))) @@ -381,7 +455,8 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (let ((expr (calc-top-n 1)) (uold nil) (uoldname nil) - unew) + unew + defunits) (setq uold (or old-units (let ((units (math-single-units-in-expr-p expr))) (if units @@ -398,18 +473,32 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (error "Bad format in units expression: %s" (nth 2 uold))) (or (math-units-in-expr-p expr nil) (setq expr (math-mul expr uold))) + (setq defunits (math-get-default-units expr)) (setq unew (or new-units (math-read-expr - (read-string (if uoldname - (concat "Old temperature units: " - uoldname - ", new units: ") - "New temperature units: "))))) + (read-string + (concat + (if uoldname + (concat "Old temperature units: " + uoldname + ", new units") + "New temperature units") + (if defunits + (concat " (default " + defunits + "): ") + ": ")))))) (when (eq (car-safe unew) 'error) (error "Bad format in units expression: %s" (nth 2 unew))) - (calc-enter-result 1 "cvtm" (math-simplify-units - (math-convert-temperature expr uold unew - uoldname)))))) + (math-put-default-units unew) + (let ((ntemp (calc-normalize + (math-simplify-units + (math-convert-temperature expr uold unew + uoldname))))) + (if (Math-zerop ntemp) + (setq ntemp (list '* ntemp unew))) + (let ((calc-simplify-mode 'none)) + (calc-enter-result 1 "cvtm" ntemp)))))) (defun calc-remove-units () (interactive) @@ -423,7 +512,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (calc-enter-result 1 "rmun" (math-simplify-units (math-extract-units (calc-top-n 1)))))) -;; The variables calc-num-units and calc-den-units are local to +;; The variables calc-num-units and calc-den-units are local to ;; calc-explain-units, but are used by calc-explain-units-rec, ;; which is called by calc-explain-units. (defvar calc-num-units) @@ -668,7 +757,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (list (cons (car x) 1)))))) combined-units)) (let ((math-units-table tab)) - (mapcar 'math-find-base-units tab)) + (mapc 'math-find-base-units tab)) (message "Building units table...done") (setq math-units-table tab)))) @@ -710,7 +799,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (old (assq (car (car ulist)) math-fbu-base))) (if old (setcdr old (+ (cdr old) p)) - (setq math-fbu-base + (setq math-fbu-base (cons (cons (car (car ulist)) p) math-fbu-base)))) (setq ulist (cdr ulist))))) ((math-scalarp expr)) @@ -904,8 +993,8 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (if (equal (nth 4 math-fcu-u) (nth 4 u2)) (cons expr pow)))))) -;; The variables math-cu-new-units and math-cu-pure are local to -;; math-convert-units, but are used by math-convert-units-rec, +;; The variables math-cu-new-units and math-cu-pure are local to +;; math-convert-units, but are used by math-convert-units-rec, ;; which is called by math-convert-units. (defvar math-cu-new-units) (defvar math-cu-pure) @@ -917,7 +1006,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (if (eq (car-safe (nth 1 unew)) '+) (setq math-cu-new-units (nth 1 unew))))) (math-with-extra-prec 2 - (let ((compat (and (not math-cu-pure) + (let ((compat (and (not math-cu-pure) (math-find-compatible-unit expr math-cu-new-units))) (math-cu-unit-list nil) (math-combining-units nil)) @@ -944,7 +1033,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (defun math-convert-units-rec (expr) (if (math-units-in-expr-p expr nil) - (math-apply-units (math-to-standard-units + (math-apply-units (math-to-standard-units (list '/ expr math-cu-new-units) nil) math-cu-new-units math-cu-unit-list math-cu-pure) (if (Math-primp expr) @@ -971,17 +1060,17 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (symbol-name v))))))) (or (eq (nth 3 uold) (nth 3 unew)) (cond ((eq (nth 3 uold) 'K) - (setq expr (list '- expr '(float 27315 -2))) + (setq expr (list '- expr '(/ 27315 100))) (if (eq (nth 3 unew) 'F) - (setq expr (list '+ (list '* expr '(frac 9 5)) 32)))) + (setq expr (list '+ (list '* expr '(/ 9 5)) 32)))) ((eq (nth 3 uold) 'C) (if (eq (nth 3 unew) 'F) - (setq expr (list '+ (list '* expr '(frac 9 5)) 32)) - (setq expr (list '+ expr '(float 27315 -2))))) + (setq expr (list '+ (list '* expr '(/ 9 5)) 32)) + (setq expr (list '+ expr '(/ 27315 100))))) (t - (setq expr (list '* (list '- expr 32) '(frac 5 9))) + (setq expr (list '* (list '- expr 32) '(/ 5 9))) (if (eq (nth 3 unew) 'K) - (setq expr (list '+ expr '(float 27315 -2))))))) + (setq expr (list '+ expr '(/ 27315 100))))))) (if pure expr (list '* expr new)))) @@ -1009,7 +1098,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (calc-record-why "*Inconsistent units" math-simplify-expr) math-simplify-expr) (list '* (math-add (math-remove-units (nth 1 math-simplify-expr)) - (if (eq (car math-simplify-expr) '-) + (if (eq (car math-simplify-expr) '-) (math-neg ratio) ratio)) units))))) @@ -1103,7 +1192,7 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (math-simplify-units-divisor np (cdr (cdr math-simplify-expr))) (if (eq math-try-cancel-units 0) (let* ((math-simplifying-units nil) - (base (math-simplify + (base (math-simplify (math-to-standard-units math-simplify-expr nil)))) (if (Math-numberp base) (setq math-simplify-expr base)))) @@ -1138,7 +1227,9 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (and un ud (if (and (equal (nth 4 un) (nth 4 ud)) (eq pow1 pow2)) - (math-to-standard-units (list '/ n d) nil) + (if (eq pow1 1) + (math-to-standard-units (list '/ n d) nil) + (list '^ (math-to-standard-units (list '/ n d) nil) pow1)) (let (ud1) (setq un (nth 4 un) ud (nth 4 ud)) @@ -1159,11 +1250,11 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (math-realp (nth 2 math-simplify-expr)) (if (memq (car-safe (nth 1 math-simplify-expr)) '(* /)) (list (car (nth 1 math-simplify-expr)) - (list '^ (nth 1 (nth 1 math-simplify-expr)) + (list '^ (nth 1 (nth 1 math-simplify-expr)) (nth 2 math-simplify-expr)) - (list '^ (nth 2 (nth 1 math-simplify-expr)) + (list '^ (nth 2 (nth 1 math-simplify-expr)) (nth 2 math-simplify-expr))) - (math-simplify-units-pow (nth 1 math-simplify-expr) + (math-simplify-units-pow (nth 1 math-simplify-expr) (nth 2 math-simplify-expr))))) (math-defsimplify calcFunc-sqrt diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index e0f2a86bf29..b869a1e08a8 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -32,6 +32,10 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + + (defun calc-display-strings (n) (interactive "P") (calc-wrapper diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index 89a9f1339b0..41a8d4157c9 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -559,7 +559,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer." (aset str pos ?\,))) (switch-to-buffer calc-original-buffer) (let ((vals (let ((calc-language nil) - (math-expr-opers math-standard-opers)) + (math-expr-opers (math-standard-ops))) (and (string-match "[^\n\t ]" str) (math-read-exprs str))))) (when (eq (car-safe vals) 'error) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index ad514707018..d14f667d752 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -206,6 +206,84 @@ (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-set-language "calc-lang" (lang &optional option no-refresh)) +(declare-function calc-edit-finish "calc-yank" (&optional keep)) +(declare-function calc-edit-cancel "calc-yank" ()) +(declare-function calc-do-quick-calc "calc-aent" ()) +(declare-function calc-do-calc-eval "calc-aent" (str separator args)) +(declare-function calc-do-keypad "calc-keypd" (&optional full-display interactive)) +(declare-function calcFunc-unixtime "calc-forms" (date &optional zone)) +(declare-function math-parse-date "calc-forms" (math-pd-str)) +(declare-function math-lessp "calc-ext" (a b)) +(declare-function calc-embedded-finish-command "calc-embed" ()) +(declare-function calc-embedded-select-buffer "calc-embed" ()) +(declare-function calc-embedded-mode-line-change "calc-embed" ()) +(declare-function calc-push-list-in-macro "calc-prog" (vals m sels)) +(declare-function calc-replace-selections "calc-sel" (n vals m)) +(declare-function calc-record-list "calc-misc" (vals &optional prefix)) +(declare-function calc-normalize-fancy "calc-ext" (val)) +(declare-function calc-do-handle-whys "calc-misc" ()) +(declare-function calc-top-selected "calc-sel" (&optional n m)) +(declare-function calc-sel-error "calc-sel" ()) +(declare-function calc-pop-stack-in-macro "calc-prog" (n mm)) +(declare-function calc-embedded-stack-change "calc-embed" ()) +(declare-function calc-refresh-evaltos "calc-ext" (&optional which-var)) +(declare-function calc-do-refresh "calc-misc" ()) +(declare-function calc-binary-op-fancy "calc-ext" (name func arg ident unary)) +(declare-function calc-unary-op-fancy "calc-ext" (name func arg)) +(declare-function calc-delete-selection "calc-sel" (n)) +(declare-function calc-alg-digit-entry "calc-aent" ()) +(declare-function calc-alg-entry "calc-aent" (&optional initial prompt)) +(declare-function calc-dots "calc-incom" ()) +(declare-function calc-temp-minibuffer-message "calc-misc" (m)) +(declare-function math-read-radix-digit "calc-misc" (dig)) +(declare-function calc-digit-dots "calc-incom" ()) +(declare-function math-normalize-fancy "calc-ext" (a)) +(declare-function math-normalize-nonstandard "calc-ext" ()) +(declare-function math-recompile-eval-rules "calc-alg" ()) +(declare-function math-apply-rewrites "calc-rewr" (expr rules &optional heads math-apply-rw-ruleset)) +(declare-function calc-record-why "calc-misc" (&rest stuff)) +(declare-function math-dimension-error "calc-vec" ()) +(declare-function calc-incomplete-error "calc-incom" (a)) +(declare-function math-float-fancy "calc-arith" (a)) +(declare-function math-neg-fancy "calc-arith" (a)) +(declare-function math-zerop "calc-misc" (a)) +(declare-function calc-add-fractions "calc-frac" (a b)) +(declare-function math-add-objects-fancy "calc-arith" (a b)) +(declare-function math-add-symb-fancy "calc-arith" (a b)) +(declare-function math-mul-zero "calc-arith" (a b)) +(declare-function calc-mul-fractions "calc-frac" (a b)) +(declare-function math-mul-objects-fancy "calc-arith" (a b)) +(declare-function math-mul-symb-fancy "calc-arith" (a b)) +(declare-function math-reject-arg "calc-misc" (&optional a p option)) +(declare-function math-div-by-zero "calc-arith" (a b)) +(declare-function math-div-zero "calc-arith" (a b)) +(declare-function math-make-frac "calc-frac" (num den)) +(declare-function calc-div-fractions "calc-frac" (a b)) +(declare-function math-div-objects-fancy "calc-arith" (a b)) +(declare-function math-div-symb-fancy "calc-arith" (a b)) +(declare-function math-compose-expr "calccomp" (a prec)) +(declare-function math-comp-width "calccomp" (c)) +(declare-function math-composition-to-string "calccomp" (c &optional width)) +(declare-function math-stack-value-offset-fancy "calccomp" ()) +(declare-function math-format-flat-expr-fancy "calc-ext" (a prec)) +(declare-function math-adjust-fraction "calc-ext" (a)) +(declare-function math-format-binary "calc-bin" (a)) +(declare-function math-format-radix "calc-bin" (a)) +(declare-function math-group-float "calc-ext" (str)) +(declare-function math-mod "calc-misc" (a b)) +(declare-function math-format-number-fancy "calc-ext" (a prec)) +(declare-function math-format-bignum-fancy "calc-ext" (a)) +(declare-function math-read-number-fancy "calc-ext" (s)) +(declare-function calc-do-grab-region "calc-yank" (top bot arg)) +(declare-function calc-do-grab-rectangle "calc-yank" (top bot arg &optional reduce)) +(declare-function calc-do-embedded "calc-embed" (calc-embed-arg end obeg oend)) +(declare-function calc-do-embedded-activate "calc-embed" (calc-embed-arg cbuf)) +(declare-function math-do-defmath "calc-prog" (func args body)) +(declare-function calc-load-everything "calc-ext" ()) + + (defgroup calc nil "GNU Calc." :prefix "calc-" @@ -213,7 +291,7 @@ :group 'applications) ;;;###autoload -(defcustom calc-settings-file +(defcustom calc-settings-file (convert-standard-filename "~/.calc.el") "*File in which to record permanent settings." :group 'calc @@ -229,13 +307,14 @@ (c-mode . c) (c++-mode . c) (fortran-mode . fortran) - (f90-mode . fortran)) + (f90-mode . fortran) + (texinfo-mode . calc-normal-language)) "*Alist of major modes with appropriate Calc languages." :group 'calc - :type '(alist :key-type (symbol :tag "Major mode") + :type '(alist :key-type (symbol :tag "Major mode") :value-type (symbol :tag "Calc language"))) -(defcustom calc-embedded-announce-formula +(defcustom calc-embedded-announce-formula "%Embed\n\\(% .*\n\\)*" "*A regular expression which is sure to be followed by a calc-embedded formula." :group 'calc @@ -258,13 +337,13 @@ :type '(alist :key-type (symbol :tag "Major mode") :value-type (regexp :tag "Regexp to announce formula"))) -(defcustom calc-embedded-open-formula +(defcustom calc-embedded-open-formula "\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin[^{].*\n\\|^\\\\begin{.*[^x]}.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n" "*A regular expression for the opening delimiter of a formula used by calc-embedded." :group 'calc :type '(regexp)) -(defcustom calc-embedded-close-formula +(defcustom calc-embedded-close-formula "\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end[^{].*\n\\|^\\\\end{.*[^x]}.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n" "*A regular expression for the closing delimiter of a formula used by calc-embedded." :group 'calc @@ -278,13 +357,13 @@ :value-type (list (regexp :tag "Opening formula delimiter") (regexp :tag "Closing formula delimiter")))) -(defcustom calc-embedded-open-word +(defcustom calc-embedded-open-word "^\\|[^-+0-9.eE]" "*A regular expression for the opening delimiter of a formula used by calc-embedded-word." :group 'calc :type '(regexp)) -(defcustom calc-embedded-close-word +(defcustom calc-embedded-close-word "$\\|[^-+0-9.eE]" "*A regular expression for the closing delimiter of a formula used by calc-embedded-word." :group 'calc @@ -298,7 +377,7 @@ :value-type (list (regexp :tag "Opening word delimiter") (regexp :tag "Closing word delimiter")))) -(defcustom calc-embedded-open-plain +(defcustom calc-embedded-open-plain "%%% " "*A string which is the opening delimiter for a \"plain\" formula. If calc-show-plain mode is enabled, this is inserted at the front of @@ -306,7 +385,7 @@ each formula." :group 'calc :type '(string)) -(defcustom calc-embedded-close-plain +(defcustom calc-embedded-close-plain " %%%\n" "*A string which is the closing delimiter for a \"plain\" formula. See calc-embedded-open-plain." @@ -331,13 +410,13 @@ See calc-embedded-open-plain." :value-type (list (string :tag "Opening \"plain\" delimiter") (string :tag "Closing \"plain\" delimiter")))) -(defcustom calc-embedded-open-new-formula +(defcustom calc-embedded-open-new-formula "\n\n" "*A string which is inserted at front of formula by calc-embedded-new-formula." :group 'calc :type '(string)) -(defcustom calc-embedded-close-new-formula +(defcustom calc-embedded-close-new-formula "\n\n" "*A string which is inserted at end of formula by calc-embedded-new-formula." :group 'calc @@ -351,14 +430,14 @@ See calc-embedded-open-plain." :value-type (list (string :tag "Opening new formula delimiter") (string :tag "Closing new formula delimiter")))) -(defcustom calc-embedded-open-mode +(defcustom calc-embedded-open-mode "% " "*A string which should precede calc-embedded mode annotations. This is not required to be present for user-written mode annotations." :group 'calc :type '(string)) -(defcustom calc-embedded-close-mode +(defcustom calc-embedded-close-mode "\n" "*A string which should follow calc-embedded mode annotations. This is not required to be present for user-written mode annotations." @@ -383,24 +462,31 @@ This is not required to be present for user-written mode annotations." :value-type (list (string :tag "Opening annotation delimiter") (string :tag "Closing annotation delimiter")))) -(defcustom calc-gnuplot-name +(defcustom calc-gnuplot-name "gnuplot" "*Name of GNUPLOT program, for calc-graph features." :group 'calc :type '(string)) -(defcustom calc-gnuplot-plot-command +(defcustom calc-gnuplot-plot-command nil "*Name of command for displaying GNUPLOT output; %s = file name to print." :group 'calc :type '(choice (string) (sexp))) -(defcustom calc-gnuplot-print-command +(defcustom calc-gnuplot-print-command "lp %s" "*Name of command for printing GNUPLOT output; %s = file name to print." :group 'calc :type '(choice (string) (sexp))) +(defcustom calc-multiplication-has-precedence + t + "*If non-nil, multiplication has precedence over division +in normal mode." + :group 'calc + :type 'boolean) + (defvar calc-bug-address "jay.p.belanger@gmail.com" "Address of the maintainer of Calc, for use by `report-calc-bug'.") @@ -512,7 +598,7 @@ This is used only when calc-group-digits mode is on.") (defcalcmodevar calc-point-char "." "The character (in the form of a string) to be used as a decimal point.") - + (defcalcmodevar calc-frac-format '(":" nil) "Format of displayed fractions; a string of one or two of \":\" or \"/\".") @@ -599,6 +685,9 @@ If `C' is present, display outer brackets for matrices (centered).") tex Use TeX notation. latex Use LaTeX notation. eqn Use eqn notation. + yacas Use Yacas notation. + maxima Use Maxima notation. + giac Use Giac notation. math Use Mathematica(tm) notation. maple Use Maple notation.") @@ -702,9 +791,9 @@ If nil, selections displayed but ignored.") "YYddd< hh:mm:ss>")) (defcalcmodevar calc-autorange-units nil) - + (defcalcmodevar calc-was-keypad-mode nil) - + (defcalcmodevar calc-full-mode nil) (defcalcmodevar calc-user-parse-tables nil) @@ -714,7 +803,7 @@ If nil, selections displayed but ignored.") (defcalcmodevar calc-gnuplot-default-output "STDOUT") (defcalcmodevar calc-gnuplot-print-device "postscript") - + (defcalcmodevar calc-gnuplot-print-output "auto") (defcalcmodevar calc-gnuplot-geometry nil) @@ -722,7 +811,7 @@ If nil, selections displayed but ignored.") (defcalcmodevar calc-graph-default-resolution 15) (defcalcmodevar calc-graph-default-resolution-3d 5) - + (defcalcmodevar calc-invocation-macro nil) (defcalcmodevar calc-show-banner t @@ -813,9 +902,6 @@ If nil, selections displayed but ignored.") (defvar calc-embedded-mode-hook nil "Hook run when starting embedded mode.") -;; Verify that Calc is running on the right kind of system. -(defvar calc-emacs-type-lucid (not (not (string-match "Lucid" emacs-version)))) - ;; Set up the autoloading linkage. (let ((name (and (fboundp 'calc-dispatch) (eq (car-safe (symbol-function 'calc-dispatch)) 'autoload) @@ -884,6 +970,18 @@ If nil, selections displayed but ignored.") "Function through which to pass strings before parsing.") (defvar calc-radix-formatter nil "Formatting function used for non-decimal numbers.") +(defvar calc-lang-slash-idiv nil + "A list of languages in which / might represent integer division.") +(defvar calc-lang-allow-underscores nil + "A list of languages which allow underscores in variable names.") +(defvar calc-lang-allow-percentsigns nil + "A list of languages which allow percent signs in variable names.") +(defvar calc-lang-c-type-hex nil + "Languages in which octal and hex numbers are written with leading 0 and 0x,") +(defvar calc-lang-brackets-are-subscripts nil + "Languages in which subscripts are indicated by brackets.") +(defvar calc-lang-parens-are-subscripts nil + "Languages in which subscripts are indicated by parentheses.") (defvar calc-last-kill nil) ; Last number killed in calc-mode. (defvar calc-dollar-values nil) ; Values to be used for '$'. @@ -906,7 +1004,6 @@ If nil, selections displayed but ignored.") (defvar math-eval-rules-cache-tag t) (defvar math-radix-explicit-format t) (defvar math-expr-function-mapping nil) -(defvar math-expr-special-function-mapping nil) (defvar math-expr-variable-mapping nil) (defvar math-read-expr-quotes nil) (defvar math-working-step nil) @@ -918,8 +1015,8 @@ If nil, selections displayed but ignored.") (defvar var-gamma '(special-const (math-gamma-const))) (defvar var-Modes '(special-const (math-get-modes-vec))) -(mapcar (lambda (v) (or (boundp v) (set v nil))) - calc-local-var-list) +(mapc (lambda (v) (or (boundp v) (set v nil))) + calc-local-var-list) (defvar calc-mode-map (let ((map (make-keymap))) @@ -960,7 +1057,7 @@ If nil, selections displayed but ignored.") (defvar calc-digit-map (let ((map (make-keymap))) - (if calc-emacs-type-lucid + (if (featurep 'xemacs) (map-keymap (function (lambda (keys bind) (define-key map keys @@ -975,89 +1072,90 @@ If nil, selections displayed but ignored.") (if (eq (aref cmap i) 'undefined) 'undefined 'calcDigit-nondigit)) (setq i (1+ i))))) - (mapcar (lambda (x) (define-key map (char-to-string x) 'calcDigit-key)) - "_0123456789.e+-:n#@oh'\"mspM") - (mapcar (lambda (x) (define-key map (char-to-string x) 'calcDigit-letter)) + (mapc (lambda (x) (define-key map (char-to-string x) 'calcDigit-key)) + "_0123456789.e+-:n#@oh'\"mspM") + (mapc (lambda (x) (define-key map (char-to-string x) 'calcDigit-letter)) "abcdfgijklqrtuvwxyzABCDEFGHIJKLNOPQRSTUVWXYZ") (define-key map "'" 'calcDigit-algebraic) (define-key map "`" 'calcDigit-edit) (define-key map "\C-g" 'abort-recursive-edit) map)) -(mapcar (lambda (x) - (condition-case err - (progn - (define-key calc-digit-map x 'calcDigit-backspace) - (define-key calc-mode-map x 'calc-pop) - (define-key calc-mode-map - (if (vectorp x) - (if calc-emacs-type-lucid - (if (= (length x) 1) - (vector (if (consp (aref x 0)) - (cons 'meta (aref x 0)) - (list 'meta (aref x 0)))) - "\e\C-d") - (vconcat "\e" x)) - (concat "\e" x)) - 'calc-pop-above)) - (error nil))) - (if calc-scan-for-dels - (append (where-is-internal 'delete-backward-char global-map) - (where-is-internal 'backward-delete-char global-map) - '("\C-d")) - '("\177" "\C-d"))) +(mapc (lambda (x) + (condition-case err + (progn + (define-key calc-digit-map x 'calcDigit-backspace) + (define-key calc-mode-map x 'calc-pop) + (define-key calc-mode-map + (if (vectorp x) + (if (featurep 'xemacs) + (if (= (length x) 1) + (vector (if (consp (aref x 0)) + (cons 'meta (aref x 0)) + (list 'meta (aref x 0)))) + "\e\C-d") + (vconcat "\e" x)) + (concat "\e" x)) + 'calc-pop-above)) + (error nil))) + (if calc-scan-for-dels + (append (where-is-internal 'delete-backward-char global-map) + (where-is-internal 'backward-delete-char global-map) + (where-is-internal 'backward-delete-char-untabify global-map) + '("\C-d")) + '("\177" "\C-d"))) (defvar calc-dispatch-map (let ((map (make-keymap))) - (mapcar (lambda (x) - (define-key map (char-to-string (car x)) (cdr x)) - (when (string-match "abcdefhijklnopqrstuwxyz" - (char-to-string (car x))) - (define-key map (char-to-string (- (car x) ?a -1)) (cdr x))) - (define-key map (format "\e%c" (car x)) (cdr x))) - '( ( ?a . calc-embedded-activate ) - ( ?b . calc-big-or-small ) - ( ?c . calc ) - ( ?d . calc-embedded-duplicate ) - ( ?e . calc-embedded ) - ( ?f . calc-embedded-new-formula ) - ( ?g . calc-grab-region ) - ( ?h . calc-dispatch-help ) - ( ?i . calc-info ) - ( ?j . calc-embedded-select ) - ( ?k . calc-keypad ) - ( ?l . calc-load-everything ) - ( ?m . read-kbd-macro ) - ( ?n . calc-embedded-next ) - ( ?o . calc-other-window ) - ( ?p . calc-embedded-previous ) - ( ?q . quick-calc ) - ( ?r . calc-grab-rectangle ) - ( ?s . calc-info-summary ) - ( ?t . calc-tutorial ) - ( ?u . calc-embedded-update-formula ) - ( ?w . calc-embedded-word ) - ( ?x . calc-quit ) - ( ?y . calc-copy-to-buffer ) - ( ?z . calc-user-invocation ) - ( ?\' . calc-embedded-new-formula ) - ( ?\` . calc-embedded-edit ) - ( ?: . calc-grab-sum-down ) - ( ?_ . calc-grab-sum-across ) - ( ?0 . calc-reset ) - ( ?? . calc-dispatch-help ) - ( ?# . calc-same-interface ) - ( ?& . calc-same-interface ) - ( ?\\ . calc-same-interface ) - ( ?= . calc-same-interface ) - ( ?* . calc-same-interface ) - ( ?/ . calc-same-interface ) - ( ?+ . calc-same-interface ) - ( ?- . calc-same-interface ) )) + (mapc (lambda (x) + (define-key map (char-to-string (car x)) (cdr x)) + (when (string-match "abcdefhijklnopqrstuwxyz" + (char-to-string (car x))) + (define-key map (char-to-string (- (car x) ?a -1)) (cdr x))) + (define-key map (format "\e%c" (car x)) (cdr x))) + '( ( ?a . calc-embedded-activate ) + ( ?b . calc-big-or-small ) + ( ?c . calc ) + ( ?d . calc-embedded-duplicate ) + ( ?e . calc-embedded ) + ( ?f . calc-embedded-new-formula ) + ( ?g . calc-grab-region ) + ( ?h . calc-dispatch-help ) + ( ?i . calc-info ) + ( ?j . calc-embedded-select ) + ( ?k . calc-keypad ) + ( ?l . calc-load-everything ) + ( ?m . read-kbd-macro ) + ( ?n . calc-embedded-next ) + ( ?o . calc-other-window ) + ( ?p . calc-embedded-previous ) + ( ?q . quick-calc ) + ( ?r . calc-grab-rectangle ) + ( ?s . calc-info-summary ) + ( ?t . calc-tutorial ) + ( ?u . calc-embedded-update-formula ) + ( ?w . calc-embedded-word ) + ( ?x . calc-quit ) + ( ?y . calc-copy-to-buffer ) + ( ?z . calc-user-invocation ) + ( ?\' . calc-embedded-new-formula ) + ( ?\` . calc-embedded-edit ) + ( ?: . calc-grab-sum-down ) + ( ?_ . calc-grab-sum-across ) + ( ?0 . calc-reset ) + ( ?? . calc-dispatch-help ) + ( ?# . calc-same-interface ) + ( ?& . calc-same-interface ) + ( ?\\ . calc-same-interface ) + ( ?= . calc-same-interface ) + ( ?* . calc-same-interface ) + ( ?/ . calc-same-interface ) + ( ?+ . calc-same-interface ) + ( ?- . calc-same-interface ) )) map)) ;;;; (Autoloads here) -(mapcar +(mapc (lambda (x) (dolist (func (cdr x)) (autoload func (car x)))) '( @@ -1069,7 +1167,7 @@ If nil, selections displayed but ignored.") ("calc-embed" calc-do-embedded-activate) - ("calc-misc" + ("calc-misc" calc-do-handle-whys calc-do-refresh calc-num-prefix-name calc-record-list calc-record-why calc-report-bug calc-roll-down-stack calc-roll-up-stack calc-temp-minibuffer-message calcFunc-floor @@ -1079,7 +1177,7 @@ If nil, selections displayed but ignored.") math-negp math-posp math-pow math-read-radix-digit math-reject-arg math-trunc math-zerop))) -(mapcar +(mapc (lambda (x) (dolist (cmd (cdr x)) (autoload cmd (car x) nil t))) '( @@ -1087,7 +1185,7 @@ If nil, selections displayed but ignored.") calcDigit-algebraic calcDigit-edit) ("calc-misc" another-calc calc-big-or-small calc-dispatch-help - calc-help calc-info calc-info-goto-node calc-info-summary calc-inv + calc-help calc-info calc-info-goto-node calc-info-summary calc-inv calc-last-args-stub calc-missing-key calc-mod calc-other-window calc-over calc-percent calc-pop-above calc-power calc-roll-down calc-roll-up @@ -1135,7 +1233,7 @@ If nil, selections displayed but ignored.") (let ((prompt2 (format "%s " (key-description (this-command-keys)))) (glob (current-global-map)) (loc (current-local-map))) - (or (input-pending-p) (message prompt)) + (or (input-pending-p) (message "%s" prompt)) (let ((key (calc-read-key t))) (calc-unread-command (cdr key)) (unwind-protect @@ -1151,7 +1249,7 @@ If nil, selections displayed but ignored.") (defun calc-version () "Return version of this version of Calc." (interactive) - (message (concat "Calc version " calc-version))) + (message "Calc version %s" calc-version)) (defun calc-mode () "Calculator major mode. @@ -1185,12 +1283,12 @@ Notations: 3.14e6 3.14 * 10^6 \\{calc-mode-map} " (interactive) - (mapcar (function - (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) + (mapc (function + (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) (kill-all-local-variables) (use-local-map (if (eq calc-algebraic-mode 'total) (progn (require 'calc-ext) calc-alg-map) calc-mode-map)) - (mapcar (function (lambda (v) (make-local-variable v))) calc-local-var-list) + (mapc (function (lambda (v) (make-local-variable v))) calc-local-var-list) (make-local-variable 'overlay-arrow-position) (make-local-variable 'overlay-arrow-string) (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) @@ -1216,6 +1314,7 @@ Notations: 3.14e6 3.14 * 10^6 (string-match "full" (nth 1 p)) (setq calc-standalone-flag t)) (setq p (cdr p)))) + (require 'calc-menu) (run-mode-hooks 'calc-mode-hook) (calc-refresh t) (calc-set-mode-line) @@ -1367,8 +1466,8 @@ commands given here will actually operate on the *Calculator* stack." (calc-create-buffer)) (run-hooks 'calc-end-hook) (setq calc-undo-list nil calc-redo-list nil) - (mapcar (function (lambda (v) (set-default v (symbol-value v)))) - calc-local-var-list) + (mapc (function (lambda (v) (set-default v (symbol-value v)))) + calc-local-var-list) (let ((buf (current-buffer)) (win (get-buffer-window (current-buffer))) (kbuf (get-buffer "*Calc Keypad*"))) @@ -1581,8 +1680,8 @@ See calc-keypad for details." (t (format "Radix%d " calc-number-radix))) (if calc-leading-zeros "Zero " "") (cond ((null calc-language) "") - ((eq calc-language 'tex) "TeX ") - ((eq calc-language 'latex) "LaTeX ") + ((get calc-language 'math-lang-name) + (concat (get calc-language 'math-lang-name) " ")) (t (concat (capitalize (symbol-name calc-language)) " "))) @@ -2101,13 +2200,13 @@ See calc-keypad for details." (calc-prev-char nil) (calc-prev-prev-char nil) (calc-buffer (current-buffer)) - (buf (if calc-emacs-type-lucid + (buf (if (featurep 'xemacs) (catch 'calc-foo (catch 'execute-kbd-macro (throw 'calc-foo (read-from-minibuffer "Calc: " "" calc-digit-map))) - (error "Lucid Emacs requires RET after %s" + (error "XEmacs requires RET after %s" "digit entry in kbd macro")) (let ((old-esc (lookup-key global-map "\e"))) (unwind-protect @@ -2276,7 +2375,21 @@ See calc-keypad for details." +(defconst math-bignum-digit-length + (truncate (/ (log10 (/ most-positive-fixnum 2)) 2)) + "The length of a \"digit\" in Calc bignums. +If a big integer is of the form (bigpos N0 N1 ...), this is the +length of the allowable Emacs integers N0, N1,... +The value of 2*10^(2*MATH-BIGNUM-DIGIT-LENGTH) must be less than the +largest Emacs integer.") + +(defconst math-bignum-digit-size + (expt 10 math-bignum-digit-length) + "An upper bound for the size of the \"digit\"s in Calc bignums.") +(defconst math-small-integer-size + (expt math-bignum-digit-size 2) + "An upper bound for the size of \"small integer\"s in Calc.") ;;;; Arithmetic routines. @@ -2285,11 +2398,17 @@ See calc-keypad for details." ;;; following forms: ;;; ;;; integer An integer. For normalized numbers, this format -;;; is used only for -999999 ... 999999. +;;; is used only for +;;; negative math-small-integer-size + 1 to +;;; math-small-integer-size - 1 ;;; -;;; (bigpos N0 N1 N2 ...) A big positive integer, N0 + N1*1000 + N2*10^6 ... -;;; (bigneg N0 N1 N2 ...) A big negative integer, - N0 - N1*1000 ... -;;; Each digit N is in the range 0 ... 999. +;;; (bigpos N0 N1 N2 ...) A big positive integer, +;;; N0 + N1*math-bignum-digit-size +;;; + N2*(math-bignum-digit-size)^2 ... +;;; (bigneg N0 N1 N2 ...) A big negative integer, +;;; - N0 - N1*math-bignum-digit-size ... +;;; Each digit N is in the range +;;; 0 ... math-bignum-digit-size -1. ;;; Normalized, always at least three N present, ;;; and the most significant N is nonzero. ;;; @@ -2379,13 +2498,14 @@ See calc-keypad for details." (cond ((not (consp math-normalize-a)) (if (integerp math-normalize-a) - (if (or (>= math-normalize-a 1000000) (<= math-normalize-a -1000000)) + (if (or (>= math-normalize-a math-small-integer-size) + (<= math-normalize-a (- math-small-integer-size))) (math-bignum math-normalize-a) math-normalize-a) math-normalize-a)) ((eq (car math-normalize-a) 'bigpos) (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) - (let* ((last (setq math-normalize-a + (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) (digs math-normalize-a)) (while (setq digs (cdr digs)) (or (eq (car digs) 0) (setq last digs))) @@ -2393,13 +2513,14 @@ See calc-keypad for details." (if (cdr (cdr (cdr math-normalize-a))) math-normalize-a (cond - ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) 1000))) + ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) + (* (nth 2 math-normalize-a) + math-bignum-digit-size))) ((cdr math-normalize-a) (nth 1 math-normalize-a)) (t 0)))) ((eq (car math-normalize-a) 'bigneg) (if (eq (nth (1- (length math-normalize-a)) math-normalize-a) 0) - (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) + (let* ((last (setq math-normalize-a (copy-sequence math-normalize-a))) (digs math-normalize-a)) (while (setq digs (cdr digs)) (or (eq (car digs) 0) (setq last digs))) @@ -2407,20 +2528,21 @@ See calc-keypad for details." (if (cdr (cdr (cdr math-normalize-a))) math-normalize-a (cond - ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) 1000)))) + ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) + (* (nth 2 math-normalize-a) + math-bignum-digit-size)))) ((cdr math-normalize-a) (- (nth 1 math-normalize-a))) (t 0)))) ((eq (car math-normalize-a) 'float) - (math-make-float (math-normalize (nth 1 math-normalize-a)) + (math-make-float (math-normalize (nth 1 math-normalize-a)) (nth 2 math-normalize-a))) - ((or (memq (car math-normalize-a) + ((or (memq (car math-normalize-a) '(frac cplx polar hms date mod sdev intv vec var quote special-const calcFunc-if calcFunc-lambda calcFunc-quote calcFunc-condition calcFunc-evalto)) (integerp (car math-normalize-a)) - (and (consp (car math-normalize-a)) + (and (consp (car math-normalize-a)) (not (eq (car (car math-normalize-a)) 'lambda)))) (require 'calc-ext) (math-normalize-fancy math-normalize-a)) @@ -2430,7 +2552,7 @@ See calc-keypad for details." (math-normalize-nonstandard)) (let ((args (mapcar 'math-normalize (cdr math-normalize-a)))) (or (condition-case err - (let ((func + (let ((func (assq (car math-normalize-a) '( ( + . math-add ) ( - . math-sub ) ( * . math-mul ) @@ -2446,7 +2568,7 @@ See calc-keypad for details." (require 'calc-ext) (math-recompile-eval-rules))) (and (or math-eval-rules-cache-other - (assq (car math-normalize-a) + (assq (car math-normalize-a) math-eval-rules-cache)) (math-apply-rewrites (cons (car math-normalize-a) args) @@ -2465,12 +2587,12 @@ See calc-keypad for details." (cons (car math-normalize-a) args)) nil) (wrong-type-argument - (or calc-next-why + (or calc-next-why (calc-record-why "Wrong type of argument" (cons (car math-normalize-a) args))) nil) (args-out-of-range - (calc-record-why "*Argument out of range" + (calc-record-why "*Argument out of range" (cons (car math-normalize-a) args)) nil) (inexact-result @@ -2528,7 +2650,8 @@ See calc-keypad for details." (defun math-bignum-big (a) ; [L s] (if (= a 0) nil - (cons (% a 1000) (math-bignum-big (/ a 1000))))) + (cons (% a math-bignum-digit-size) + (math-bignum-big (/ a math-bignum-digit-size))))) ;;; Build a normalized floating-point number. [F I S] @@ -2545,7 +2668,7 @@ See calc-keypad for details." (progn (while (= (car digs) 0) (setq digs (cdr digs) - exp (+ exp 3))) + exp (+ exp math-bignum-digit-length))) (while (= (% (car digs) 10) 0) (setq digs (math-div10-bignum digs) exp (1+ exp))) @@ -2563,7 +2686,8 @@ See calc-keypad for details." (defun math-div10-bignum (a) ; [l l] (if (cdr a) - (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100)) + (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) + (expt 10 (1- math-bignum-digit-length)))) (math-div10-bignum (cdr a))) (list (/ (car a) 10)))) @@ -2594,7 +2718,7 @@ See calc-keypad for details." (if (cdr a) (let* ((len (1- (length a))) (top (nth len a))) - (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2)))) + (+ (* (1- len) math-bignum-digit-length) (math-numdigs top))) 0) (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3)) ((>= a 10) 2) @@ -2615,24 +2739,24 @@ See calc-keypad for details." a (if (consp a) (cons (car a) (math-scale-left-bignum (cdr a) n)) - (if (>= n 3) - (if (or (>= a 1000) (<= a -1000)) + (if (>= n math-bignum-digit-length) + (if (or (>= a math-bignum-digit-size) + (<= a (- math-bignum-digit-size))) (math-scale-left (math-bignum a) n) - (math-scale-left (* a 1000) (- n 3))) - (if (= n 2) - (if (or (>= a 10000) (<= a -10000)) - (math-scale-left (math-bignum a) 2) - (* a 100)) - (if (or (>= a 100000) (<= a -100000)) - (math-scale-left (math-bignum a) 1) - (* a 10))))))) + (math-scale-left (* a math-bignum-digit-size) + (- n math-bignum-digit-length))) + (let ((sz (expt 10 (- (* 2 math-bignum-digit-length) n)))) + (if (or (>= a sz) (<= a (- sz))) + (math-scale-left (math-bignum a) n) + (* a (expt 10 n)))))))) (defun math-scale-left-bignum (a n) - (if (>= n 3) + (if (>= n math-bignum-digit-length) (while (>= (setq a (cons 0 a) - n (- n 3)) 3))) + n (- n math-bignum-digit-length)) + math-bignum-digit-length))) (if (> n 0) - (math-mul-bignum-digit a (if (= n 2) 100 10) 0) + (math-mul-bignum-digit a (expt 10 n) 0) a)) (defun math-scale-right (a n) ; [i i S] @@ -2644,21 +2768,20 @@ See calc-keypad for details." (if (= a 0) 0 (- (math-scale-right (- a) n))) - (if (>= n 3) - (while (and (> (setq a (/ a 1000)) 0) - (>= (setq n (- n 3)) 3)))) - (if (= n 2) - (/ a 100) - (if (= n 1) - (/ a 10) - a)))))) + (if (>= n math-bignum-digit-length) + (while (and (> (setq a (/ a math-bignum-digit-size)) 0) + (>= (setq n (- n math-bignum-digit-length)) + math-bignum-digit-length)))) + (if (> n 0) + (/ a (expt 10 n)) + a))))) (defun math-scale-right-bignum (a n) ; [L L S; l l S] - (if (>= n 3) - (setq a (nthcdr (/ n 3) a) - n (% n 3))) + (if (>= n math-bignum-digit-length) + (setq a (nthcdr (/ n math-bignum-digit-length) a) + n (% n math-bignum-digit-length))) (if (> n 0) - (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0)) + (cdr (math-mul-bignum-digit a (expt 10 (- math-bignum-digit-length n)) 0)) a)) ;;; Multiply (with rounding) the integer A by 10^N. [I i S] @@ -2668,16 +2791,18 @@ See calc-keypad for details." ((consp a) (math-normalize (cons (car a) - (let ((val (if (< n -3) - (math-scale-right-bignum (cdr a) (- -3 n)) - (if (= n -2) - (math-mul-bignum-digit (cdr a) 10 0) - (if (= n -1) - (math-mul-bignum-digit (cdr a) 100 0) - (cdr a)))))) ; n = -3 - (if (and val (>= (car val) 500)) + (let ((val (if (< n (- math-bignum-digit-length)) + (math-scale-right-bignum + (cdr a) + (- (- math-bignum-digit-length) n)) + (if (< n 0) + (math-mul-bignum-digit + (cdr a) + (expt 10 (+ math-bignum-digit-length n)) 0) + (cdr a))))) ; n = -math-bignum-digit-length + (if (and val (>= (car val) (/ math-bignum-digit-size 2))) (if (cdr val) - (if (eq (car (cdr val)) 999) + (if (eq (car (cdr val)) (1- math-bignum-digit-size)) (math-add-bignum (cdr val) '(1)) (cons (1+ (car (cdr val))) (cdr (cdr val)))) '(1)) @@ -2696,7 +2821,7 @@ See calc-keypad for details." (and (not (or (consp a) (consp b))) (progn (setq a (+ a b)) - (if (or (<= a -1000000) (>= a 1000000)) + (if (or (<= a (- math-small-integer-size)) (>= a math-small-integer-size)) (math-bignum a) a))) (and (Math-zerop a) (not (eq (car-safe a) 'mod)) @@ -2745,21 +2870,22 @@ See calc-keypad for details." (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) (while (and aa b) (if carry - (if (< (setq sum (+ (car aa) (car b))) 999) + (if (< (setq sum (+ (car aa) (car b))) + (1- math-bignum-digit-size)) (progn (setcar aa (1+ sum)) (setq carry nil)) - (setcar aa (+ sum -999))) - (if (< (setq sum (+ (car aa) (car b))) 1000) + (setcar aa (- sum (1- math-bignum-digit-size)))) + (if (< (setq sum (+ (car aa) (car b))) math-bignum-digit-size) (setcar aa sum) - (setcar aa (+ sum -1000)) + (setcar aa (- sum math-bignum-digit-size)) (setq carry t))) (setq aa (cdr aa) b (cdr b))) (if carry (if b (nconc a (math-add-bignum b '(1))) - (while (eq (car aa) 999) + (while (eq (car aa) (1- math-bignum-digit-size)) (setcar aa 0) (setq aa (cdr aa))) (if aa @@ -2783,17 +2909,17 @@ See calc-keypad for details." (progn (setcar aa (1- diff)) (setq borrow nil)) - (setcar aa (+ diff 999))) + (setcar aa (+ diff (1- math-bignum-digit-size)))) (if (>= (setq diff (- (car aa) (car b))) 0) (setcar aa diff) - (setcar aa (+ diff 1000)) + (setcar aa (+ diff math-bignum-digit-size)) (setq borrow t))) (setq aa (cdr aa) b (cdr b))) (if borrow (progn (while (eq (car aa) 0) - (setcar aa 999) + (setcar aa (1- math-bignum-digit-size)) (setq aa (cdr aa))) (if aa (progn @@ -2833,7 +2959,7 @@ See calc-keypad for details." (if (or (consp a) (consp b)) (math-add a (math-neg b)) (setq a (- a b)) - (if (or (<= a -1000000) (>= a 1000000)) + (if (or (<= a (- math-small-integer-size)) (>= a math-small-integer-size)) (math-bignum a) a))) @@ -2860,7 +2986,8 @@ See calc-keypad for details." (defun math-mul (a b) (or (and (not (consp a)) (not (consp b)) - (< a 1000) (> a -1000) (< b 1000) (> b -1000) + (< a math-bignum-digit-size) (> a (- math-bignum-digit-size)) + (< b math-bignum-digit-size) (> b (- math-bignum-digit-size)) (* a b)) (and (Math-zerop a) (not (eq (car-safe b) 'mod)) (if (Math-scalarp b) @@ -2929,14 +3056,14 @@ See calc-keypad for details." aa a) (while (progn (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d)) - c)) 1000)) + c)) math-bignum-digit-size)) (setq aa (cdr aa))) - (setq c (/ prod 1000) + (setq c (/ prod math-bignum-digit-size) ss (or (cdr ss) (setcdr ss (list 0))))) - (if (>= prod 1000) + (if (>= prod math-bignum-digit-size) (if (cdr ss) - (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss)))) - (setcdr ss (list (/ prod 1000)))))) + (setcar (cdr ss) (+ (/ prod math-bignum-digit-size) (car (cdr ss)))) + (setcdr ss (list (/ prod math-bignum-digit-size)))))) sum))) ;;; Multiply digit list A by digit D. [L L D D; l l D D] @@ -2946,12 +3073,14 @@ See calc-keypad for details." (and (= d 1) a) (let* ((a (copy-sequence a)) (aa a) prod) (while (progn - (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000)) + (setcar aa + (% (setq prod (+ (* (car aa) d) c)) + math-bignum-digit-size)) (cdr aa)) (setq aa (cdr aa) - c (/ prod 1000))) - (if (>= prod 1000) - (setcdr aa (list (/ prod 1000)))) + c (/ prod math-bignum-digit-size))) + (if (>= prod math-bignum-digit-size) + (setcdr aa (list (/ prod math-bignum-digit-size)))) a)) (and (> c 0) (list c)))) @@ -2964,7 +3093,7 @@ See calc-keypad for details." (if (eq b 0) (math-reject-arg a "*Division by zero")) (if (or (consp a) (consp b)) - (if (and (natnump b) (< b 1000)) + (if (and (natnump b) (< b math-bignum-digit-size)) (let ((res (math-div-bignum-digit (cdr a) b))) (cons (math-normalize (cons (car a) (car res))) @@ -2983,7 +3112,7 @@ See calc-keypad for details." (if (= b 0) (math-reject-arg a "*Division by zero") (/ a b)) - (if (and (natnump b) (< b 1000)) + (if (and (natnump b) (< b math-bignum-digit-size)) (if (= b 0) (math-reject-arg a "*Division by zero") (math-normalize (cons (car a) @@ -2992,7 +3121,7 @@ See calc-keypad for details." (or (consp b) (setq b (math-bignum b))) (let* ((alen (1- (length a))) (blen (1- (length b))) - (d (/ 1000 (1+ (nth (1- blen) (cdr b))))) + (d (/ math-bignum-digit-size (1+ (nth (1- blen) (cdr b))))) (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0) (math-mul-bignum-digit (cdr b) d 0) alen blen))) @@ -3006,7 +3135,7 @@ See calc-keypad for details." (if (cdr b) (let* ((alen (length a)) (blen (length b)) - (d (/ 1000 (1+ (nth (1- blen) b)))) + (d (/ math-bignum-digit-size (1+ (nth (1- blen) b)))) (res (math-div-bignum-big (math-mul-bignum-digit a d 0) (math-mul-bignum-digit b d 0) alen blen))) @@ -3021,7 +3150,7 @@ See calc-keypad for details." (defun math-div-bignum-digit (a b) (if a (let* ((res (math-div-bignum-digit (cdr a) b)) - (num (+ (* (cdr res) 1000) (car a)))) + (num (+ (* (cdr res) math-bignum-digit-size) (car a)))) (cons (cons (/ num b) (car res)) (% num b))) @@ -3037,10 +3166,11 @@ See calc-keypad for details." (cons (car res2) (car res)) (cdr res2))))) -(defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L] - (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0))) +(defun math-div-bignum-part (a b blen) ; a < b*math-bignum-digit-size [D.l l L] + (let* ((num (+ (* (or (nth blen a) 0) math-bignum-digit-size) + (or (nth (1- blen) a) 0))) (den (nth (1- blen) b)) - (guess (min (/ num den) 999))) + (guess (min (/ num den) (1- math-bignum-digit-size)))) (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess))) (defun math-div-bignum-try (a b c guess) ; [D.l l l D] @@ -3351,15 +3481,22 @@ See calc-keypad for details." (if a (let ((s "")) (while (cdr (cdr a)) - (setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s) + (setq s (concat + (format + (concat "%0" + (number-to-string (* 2 math-bignum-digit-length)) + "d") + (+ (* (nth 1 a) math-bignum-digit-size) (car a))) s) a (cdr (cdr a)))) - (concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s)) + (concat (int-to-string + (+ (* (or (nth 1 a) 0) math-bignum-digit-size) (car a))) s)) "0")) ;;; Parse a simple number in string form. [N X] [Public] (defun math-read-number (s) + "Convert the string S into a Calc number." (math-normalize (cond @@ -3370,7 +3507,7 @@ See calc-keypad for details." (> (length digs) 1) (eq (aref digs 0) ?0)) (math-read-number (concat "8#" digs)) - (if (<= (length digs) 6) + (if (<= (length digs) (* 2 math-bignum-digit-length)) (string-to-number digs) (cons 'bigpos (math-read-bignum digs)))))) @@ -3416,50 +3553,47 @@ See calc-keypad for details." ;; Syntax error! (t nil)))) +;;; Parse a very simple number, keeping all digits. +(defun math-read-number-simple (s) + "Convert the string S into a Calc number. +S is assumed to be a simple number (integer or float without an exponent) +and all digits are kept, regardless of Calc's current precision." + (cond + ;; Integer + ((string-match "^[0-9]+$" s) + (if (string-match "^\\(0+\\)" s) + (setq s (substring s (match-end 0)))) + (if (<= (length s) (* 2 math-bignum-digit-length)) + (string-to-number s) + (cons 'bigpos (math-read-bignum s)))) + ;; Minus sign + ((string-match "^-[0-9]+$" s) + (if (<= (length s) (1+ (* 2 math-bignum-digit-length))) + (string-to-number s) + (cons 'bigneg (math-read-bignum (substring s 1))))) + ;; Decimal point + ((string-match "^\\(-?[0-9]*\\)\\.\\([0-9]*\\)$" s) + (let ((int (math-match-substring s 1)) + (frac (math-match-substring s 2))) + (list 'float (math-read-number-simple (concat int frac)) + (- (length frac))))) + ;; Syntax error! + (t nil))) + (defun math-match-substring (s n) (if (match-beginning n) (substring s (match-beginning n) (match-end n)) "")) (defun math-read-bignum (s) ; [l X] - (if (> (length s) 3) - (cons (string-to-number (substring s -3)) - (math-read-bignum (substring s 0 -3))) + (if (> (length s) math-bignum-digit-length) + (cons (string-to-number (substring s (- math-bignum-digit-length))) + (math-read-bignum (substring s 0 (- math-bignum-digit-length)))) (list (string-to-number s)))) - -(defconst math-tex-ignore-words - '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") - ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") - ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") - ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") - ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") - ("\\rm") ("\\bf") ("\\it") ("\\sl") - ("\\roman") ("\\bold") ("\\italic") ("\\slanted") - ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") - ("\\evalto") - ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) - ("\\begin" begenv) - ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") - ("\\{" punc "[") ("\\}" punc "]"))) - -(defconst math-latex-ignore-words - (append math-tex-ignore-words - '(("\\begin" begenv)))) - -(defconst math-eqn-ignore-words - '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") - ("left" ("floor") ("ceil")) - ("right" ("floor") ("ceil")) - ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) - ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) - ("above" punc ","))) - (defconst math-standard-opers '( ( "_" calcFunc-subscr 1200 1201 ) ( "%" calcFunc-percent 1100 -1 ) - ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 197 ) ( "u!" calcFunc-lnot -1 1000 ) ( "mod" mod 400 400 185 ) ( "+/-" sdev 300 300 185 ) @@ -3467,8 +3601,8 @@ See calc-keypad for details." ( "!" calcFunc-fact 210 -1 ) ( "^" ^ 201 200 ) ( "**" ^ 201 200 ) - ( "*" * 196 195 ) - ( "2x" * 196 195 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "/" / 190 191 ) ( "%" % 190 191 ) ( "\\" calcFunc-idiv 190 191 ) @@ -3492,7 +3626,31 @@ See calc-keypad for details." ( "::" calcFunc-condition 45 46 ) ( "=>" calcFunc-evalto 40 41 ) ( "=>" calcFunc-evalto 40 -1 ))) -(defvar math-expr-opers math-standard-opers) + +(defun math-standard-ops () + (if calc-multiplication-has-precedence + (cons + '( "*" * 196 195 ) + (cons + '( "2x" * 196 195 ) + math-standard-opers)) + (cons + '( "*" * 190 191 ) + (cons + '( "2x" * 190 191 ) + math-standard-opers)))) + +(defvar math-expr-opers (math-standard-ops)) + +(defun math-standard-ops-p () + (let ((meo (caar math-expr-opers))) + (and (stringp meo) + (string= meo "*")))) + +(defun math-expr-ops () + (if (math-standard-ops-p) + (math-standard-ops) + math-expr-opers)) ;;;###autoload (defun calc-grab-region (top bot arg) @@ -3551,7 +3709,7 @@ Also looks for the equivalent TeX words, \\gets and \\evalto." ;;; Functions needed for Lucid Emacs support. (defun calc-read-key (&optional optkey) - (cond (calc-emacs-type-lucid + (cond ((featurep 'xemacs) (let ((event (next-command-event))) (let ((key (event-to-character event t t))) (or key optkey (error "Expected a plain keystroke")) @@ -3569,7 +3727,7 @@ Also looks for the equivalent TeX words, \\gets and \\evalto." (defun calc-clear-unread-commands () (if (featurep 'xemacs) - (calc-emacs-type-lucid (setq unread-command-event nil)) + (setq unread-command-event nil) (setq unread-command-events nil))) (when calc-always-load-extensions diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el index b836a7d0cf0..c348e18937c 100644 --- a/lisp/calc/calcalg2.el +++ b/lisp/calc/calcalg2.el @@ -746,7 +746,7 @@ (setq math-integ-msg (format "Working... Integrating %s" (math-format-flat-expr expr 0))) - (message math-integ-msg))) + (message "%s" math-integ-msg))) (if math-cur-record (setcar (cdr math-cur-record) (if same-as-above (vector simp) 'busy)) @@ -773,7 +773,7 @@ "simplification...\n") (setq val (math-integral simp 'no t)))))))) (if (eq calc-display-working-message 'lots) - (message math-integ-msg))) + (message "%s" math-integ-msg))) (setcar (cdr math-cur-record) (or val (if (or math-enable-subst (not math-any-substs)) diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el index a7b70643b63..7a5f28c13a3 100644 --- a/lisp/calc/calcalg3.el +++ b/lisp/calc/calcalg3.el @@ -32,6 +32,24 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-fit-s-shaped-logistic-curve "calc-nlfit" (arg)) +(declare-function calc-fit-bell-shaped-logistic-curve "calc-nlfit" (arg)) +(declare-function calc-fit-hubbert-linear-curve "calc-nlfit" (&optional sdv)) +(declare-function calc-graph-add-curve "calc-graph" (xdata ydata &optional zdata)) +(declare-function calc-graph-lookup "calc-graph" (thing)) +(declare-function calc-graph-set-styles "calc-graph" (lines points &optional yerr)) +(declare-function math-min-list "calc-arith" (a b)) +(declare-function math-max-list "calc-arith" (a b)) + + +(defun math-map-binop (binop args1 args2) + "Apply BINOP to the elements of the lists ARGS1 and ARGS2" + (if args1 + (cons + (funcall binop (car args1) (car args2)) + (funcall 'math-map-binop binop (cdr args1) (cdr args2))))) + (defun calc-find-root (var) (interactive "sVariable(s) to solve for: ") (calc-slow-wrapper @@ -115,6 +133,8 @@ (if (calc-is-hyperbolic) 'calcFunc-efit 'calcFunc-fit))) key (which 0) + (nonlinear nil) + (plot nil) n calc-curve-nvars temp data (homog nil) (msgs '( "(Press ? for help)" @@ -125,12 +145,18 @@ "E = a 10^(b x), X = 10^(a + b x), L = a + b log10(x)" "q = a + b (x-c)^2" "g = (a/b sqrt(2 pi)) exp(-0.5*((x-c)/b)^2)" + "s = a/(1 + exp(b (x - c)))" + "b = a exp(b (x - c))/(1 + exp(b (x - c)))^2" + "o = (y/x) = a (1 - x/b)" "h prefix = homogeneous model (no constant term)" + "P prefix = plot result" "' = alg entry, $ = stack, u = Model1, U = Model2"))) (while (not calc-curve-model) - (message "Fit to model: %s:%s" - (nth which msgs) - (if homog " h" "")) + (message + "Fit to model: %s:%s%s" + (nth which msgs) + (if plot "P" " ") + (if homog "h" "")) (setq key (read-char)) (cond ((= key ?\C-g) (keyboard-quit)) @@ -138,6 +164,16 @@ (setq which (% (1+ which) (length msgs)))) ((memq key '(?h ?H)) (setq homog (not homog))) + ((= key ?P) + (if plot + (setq plot nil) + (let ((data (calc-top 1))) + (if (or + (calc-is-hyperbolic) + (calc-is-inverse) + (not (= (length data) 3))) + (setq plot "Can't plot") + (setq plot data))))) ((progn (if (eq key ?\$) (setq n 1) @@ -164,8 +200,9 @@ ((= key ?1) ; linear or multilinear (calc-get-fit-variables calc-curve-nvars (1+ calc-curve-nvars) (and homog 0)) - (setq calc-curve-model (math-mul calc-curve-coefnames - (cons 'vec (cons 1 (cdr calc-curve-varnames)))))) + (setq calc-curve-model + (math-mul calc-curve-coefnames + (cons 'vec (cons 1 (cdr calc-curve-varnames)))))) ((and (>= key ?2) (<= key ?9)) ; polynomial (calc-get-fit-variables 1 (- key ?0 -1) (and homog 0)) (setq calc-curve-model @@ -180,58 +217,88 @@ ((= key ?p) ; power law (calc-get-fit-variables calc-curve-nvars (1+ calc-curve-nvars) (and homog 1)) - (setq calc-curve-model (math-mul (nth 1 calc-curve-coefnames) - (calcFunc-reduce - '(var mul var-mul) - (calcFunc-map - '(var pow var-pow) - calc-curve-varnames - (cons 'vec (cdr (cdr calc-curve-coefnames)))))))) + (setq calc-curve-model + (math-mul + (nth 1 calc-curve-coefnames) + (calcFunc-reduce + '(var mul var-mul) + (calcFunc-map + '(var pow var-pow) + calc-curve-varnames + (cons 'vec (cdr (cdr calc-curve-coefnames)))))))) ((= key ?^) ; exponential law (calc-get-fit-variables calc-curve-nvars (1+ calc-curve-nvars) (and homog 1)) - (setq calc-curve-model (math-mul (nth 1 calc-curve-coefnames) - (calcFunc-reduce - '(var mul var-mul) - (calcFunc-map - '(var pow var-pow) - (cons 'vec (cdr (cdr calc-curve-coefnames))) - calc-curve-varnames))))) + (setq calc-curve-model + (math-mul (nth 1 calc-curve-coefnames) + (calcFunc-reduce + '(var mul var-mul) + (calcFunc-map + '(var pow var-pow) + (cons 'vec (cdr (cdr calc-curve-coefnames))) + calc-curve-varnames))))) + ((= key ?s) + (setq nonlinear t) + (setq calc-curve-model t) + (require 'calc-nlfit) + (calc-fit-s-shaped-logistic-curve func)) + ((= key ?b) + (setq nonlinear t) + (setq calc-curve-model t) + (require 'calc-nlfit) + (calc-fit-bell-shaped-logistic-curve func)) + ((= key ?o) + (setq nonlinear t) + (setq calc-curve-model t) + (require 'calc-nlfit) + (if (and plot (not (stringp plot))) + (setq plot + (list 'vec + (nth 1 plot) + (cons + 'vec + (math-map-binop 'calcFunc-div + (cdr (nth 2 plot)) + (cdr (nth 1 plot))))))) + (calc-fit-hubbert-linear-curve func)) ((memq key '(?e ?E)) (calc-get-fit-variables calc-curve-nvars (1+ calc-curve-nvars) (and homog 1)) - (setq calc-curve-model (math-mul (nth 1 calc-curve-coefnames) - (calcFunc-reduce - '(var mul var-mul) - (calcFunc-map - (if (eq key ?e) - '(var exp var-exp) - '(calcFunc-lambda - (var a var-a) - (^ 10 (var a var-a)))) - (calcFunc-map - '(var mul var-mul) - (cons 'vec (cdr (cdr calc-curve-coefnames))) - calc-curve-varnames)))))) + (setq calc-curve-model + (math-mul (nth 1 calc-curve-coefnames) + (calcFunc-reduce + '(var mul var-mul) + (calcFunc-map + (if (eq key ?e) + '(var exp var-exp) + '(calcFunc-lambda + (var a var-a) + (^ 10 (var a var-a)))) + (calcFunc-map + '(var mul var-mul) + (cons 'vec (cdr (cdr calc-curve-coefnames))) + calc-curve-varnames)))))) ((memq key '(?x ?X)) (calc-get-fit-variables calc-curve-nvars (1+ calc-curve-nvars) (and homog 0)) - (setq calc-curve-model (math-mul calc-curve-coefnames - (cons 'vec (cons 1 (cdr calc-curve-varnames))))) + (setq calc-curve-model + (math-mul calc-curve-coefnames + (cons 'vec (cons 1 (cdr calc-curve-varnames))))) (setq calc-curve-model (if (eq key ?x) (list 'calcFunc-exp calc-curve-model) (list '^ 10 calc-curve-model)))) ((memq key '(?l ?L)) (calc-get-fit-variables calc-curve-nvars (1+ calc-curve-nvars) (and homog 0)) - (setq calc-curve-model (math-mul calc-curve-coefnames - (cons 'vec - (cons 1 (cdr (calcFunc-map - (if (eq key ?l) - '(var ln var-ln) - '(var log10 - var-log10)) - calc-curve-varnames))))))) + (setq calc-curve-model + (math-mul calc-curve-coefnames + (cons 'vec + (cons 1 (cdr (calcFunc-map + (if (eq key ?l) + '(var ln var-ln) + '(var log10 + var-log10)) + calc-curve-varnames))))))) ((= key ?q) (calc-get-fit-variables calc-curve-nvars (1+ (* 2 calc-curve-nvars)) (and homog 0)) @@ -247,12 +314,14 @@ (list '- (car v) (nth 1 c)) 2))))))) ((= key ?g) - (setq calc-curve-model - (math-read-expr "(AFit / BFit sqrt(2 pi)) exp(-0.5 * ((XFit - CFit) / BFit)^2)") - calc-curve-varnames '(vec (var XFit var-XFit)) - calc-curve-coefnames '(vec (var AFit var-AFit) - (var BFit var-BFit) - (var CFit var-CFit))) + (setq + calc-curve-model + (math-read-expr + "(AFit / BFit sqrt(2 pi)) exp(-0.5 * ((XFit - CFit) / BFit)^2)") + calc-curve-varnames '(vec (var XFit var-XFit)) + calc-curve-coefnames '(vec (var AFit var-AFit) + (var BFit var-BFit) + (var CFit var-CFit))) (calc-get-fit-variables 1 (1- (length calc-curve-coefnames)) (and homog 1))) ((memq key '(?\$ ?\' ?u ?U)) @@ -262,8 +331,9 @@ (let* ((calc-dollar-values calc-arg-values) (calc-dollar-used 0) (calc-hashes-used 0)) - (setq calc-curve-model (calc-do-alg-entry "" "Model formula: " - nil 'calc-curve-fit-history)) + (setq calc-curve-model + (calc-do-alg-entry "" "Model formula: " + nil 'calc-curve-fit-history)) (if (/= (length calc-curve-model) 1) (error "Bad format")) (setq calc-curve-model (car calc-curve-model) @@ -296,11 +366,13 @@ (or (nth 3 calc-curve-model) (cons 'vec (math-all-vars-but - calc-curve-model calc-curve-varnames))) + calc-curve-model + calc-curve-varnames))) calc-curve-model (nth 1 calc-curve-model)) (error "Incorrect model specifier"))))) (or calc-curve-varnames - (let ((with-y (eq (car-safe calc-curve-model) 'calcFunc-eq))) + (let ((with-y + (eq (car-safe calc-curve-model) 'calcFunc-eq))) (if calc-curve-coefnames (calc-get-fit-variables (if with-y (1+ calc-curve-nvars) calc-curve-nvars) @@ -310,7 +382,10 @@ nil with-y) (let* ((coefs (math-all-vars-but calc-curve-model nil)) (vars nil) - (n (- (length coefs) calc-curve-nvars (if with-y 2 1))) + (n (- + (length coefs) + calc-curve-nvars + (if with-y 2 1))) p) (if (< n 0) (error "Not enough variables in model")) @@ -326,18 +401,43 @@ calc-curve-varnames calc-curve-coefnames) "modl")))) (t (beep)))) - (let ((calc-fit-to-trail t)) - (calc-enter-result n (substring (symbol-name func) 9) - (list func calc-curve-model - (if (= (length calc-curve-varnames) 2) - (nth 1 calc-curve-varnames) - calc-curve-varnames) - (if (= (length calc-curve-coefnames) 2) - (nth 1 calc-curve-coefnames) - calc-curve-coefnames) - data)) - (if (consp calc-fit-to-trail) - (calc-record (calc-normalize calc-fit-to-trail) "parm")))))) + (unless nonlinear + (let ((calc-fit-to-trail t)) + (calc-enter-result n (substring (symbol-name func) 9) + (list func calc-curve-model + (if (= (length calc-curve-varnames) 2) + (nth 1 calc-curve-varnames) + calc-curve-varnames) + (if (= (length calc-curve-coefnames) 2) + (nth 1 calc-curve-coefnames) + calc-curve-coefnames) + data)) + (if (consp calc-fit-to-trail) + (calc-record (calc-normalize calc-fit-to-trail) "parm")))) + (when plot + (if (stringp plot) + (message "%s" plot) + (let ((calc-graph-no-auto-view t)) + (calc-graph-delete t) + (calc-graph-add-curve + (calc-graph-lookup (nth 1 plot)) + (calc-graph-lookup (nth 2 plot))) + (unless (math-contains-sdev-p (nth 2 data)) + (calc-graph-set-styles nil nil) + (calc-graph-point-style nil)) + (setq plot (cdr (nth 1 plot))) + (setq plot + (list 'intv + 3 + (math-sub + (math-min-list (car plot) (cdr plot)) + '(float 5 -1)) + (math-add + '(float 5 -1) + (math-max-list (car plot) (cdr plot))))) + (calc-graph-add-curve (calc-graph-lookup plot) + (calc-graph-lookup (calc-top-n 1))) + (calc-graph-plot nil))))))) (defun calc-invent-independent-variables (n &optional but) (calc-invent-variables n but '(x y z t) "x")) diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 90e431a61e7..d2111131f03 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -32,16 +32,6 @@ (require 'calc-ext) (require 'calc-macs) -(defconst math-eqn-special-funcs - '( calcFunc-log - calcFunc-ln calcFunc-exp - calcFunc-sin calcFunc-cos calcFunc-tan - calcFunc-sec calcFunc-csc calcFunc-cot - calcFunc-sinh calcFunc-cosh calcFunc-tanh - calcFunc-sech calcFunc-csch calcFunc-coth - calcFunc-arcsin calcFunc-arccos calcFunc-arctan - calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)) - ;;; A "composition" has one of the following forms: ;;; ;;; "string" A literal string @@ -80,9 +70,28 @@ (defvar math-comp-right-bracket) (defvar math-comp-comma) +(defun math-compose-var (a) + (let (v sn) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (setq sn (symbol-name (nth 1 a))) + (if (memq calc-language calc-lang-allow-percentsigns) + (setq sn (math-to-percentsigns sn))) + (if (memq calc-language calc-lang-allow-underscores) + (setq sn (math-to-underscores sn))) + sn))) (defun math-compose-expr (a prec) (let ((math-compose-level (1+ math-compose-level)) + (math-expr-opers (math-expr-ops)) spfn) (cond ((or (and (eq a math-comp-selected) a) @@ -93,17 +102,24 @@ (list 'tag a (math-compose-expr a prec)))) ((and (not (consp a)) (not (integerp a))) (concat "'" (prin1-to-string a))) - ((setq spfn (assq (car-safe a) math-expr-special-function-mapping)) + ((setq spfn (assq (car-safe a) + (get calc-language 'math-special-function-table))) (setq spfn (cdr spfn)) - (funcall (car spfn) a spfn)) + (if (consp spfn) + (funcall (car spfn) a spfn) + (funcall spfn a))) ((math-scalarp a) (if (or (eq (car-safe a) 'frac) (and (nth 1 calc-frac-format) (Math-integerp a))) - (if (memq calc-language '(tex latex eqn math maple c fortran pascal)) + (if (and + calc-language + (not (memq calc-language + '(flat big unform)))) (let ((aa (math-adjust-fraction a)) (calc-frac-format nil)) (math-compose-expr (list '/ - (if (memq calc-language '(c fortran)) + (if (memq calc-language + calc-lang-slash-idiv) (math-float (nth 1 aa)) (nth 1 aa)) (nth 2 aa)) prec)) @@ -267,59 +283,25 @@ (cdr a) (if full rows 3) t))))) (if (or calc-full-vectors (< (length a) 7)) - (if (and (eq calc-language 'tex) - (math-matrixp a)) - (if (and (integerp calc-language-option) - (or (= calc-language-option 0) - (> calc-language-option 1) - (< calc-language-option -1))) - (append '(vleft 0 "\\matrix{") - (math-compose-tex-matrix (cdr a)) - '("}")) - (append '(horiz "\\matrix{ ") - (math-compose-tex-matrix (cdr a)) - '(" }"))) - (if (and (eq calc-language 'latex) - (math-matrixp a)) - (if (and (integerp calc-language-option) - (or (= calc-language-option 0) - (> calc-language-option 1) - (< calc-language-option -1))) - (append '(vleft 0 "\\begin{pmatrix}") - (math-compose-tex-matrix (cdr a) t) - '("\\end{pmatrix}")) - (append '(horiz "\\begin{pmatrix} ") - (math-compose-tex-matrix (cdr a) t) - '(" \\end{pmatrix}"))) - (if (and (eq calc-language 'eqn) - (math-matrixp a)) - (append '(horiz "matrix { ") - (math-compose-eqn-matrix - (cdr (math-transpose a))) - '("}")) - (if (and (eq calc-language 'maple) - (math-matrixp a)) - (list 'horiz - "matrix(" - math-comp-left-bracket - (math-compose-vector (cdr a) - (concat math-comp-comma " ") - math-comp-vector-prec) - math-comp-right-bracket - ")") - (list 'horiz - math-comp-left-bracket - (math-compose-vector (cdr a) - (concat math-comp-comma " ") - math-comp-vector-prec) - math-comp-right-bracket))))) + (if (and + (setq spfn (get calc-language 'math-matrix-formatter)) + (math-matrixp a)) + (funcall spfn a) + (list 'horiz + math-comp-left-bracket + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + math-comp-right-bracket)) (list 'horiz math-comp-left-bracket (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a)) (concat math-comp-comma " ") math-comp-vector-prec) - math-comp-comma (if (memq calc-language '(tex latex)) - " \\ldots" " ...") + math-comp-comma + (if (setq spfn (get calc-language 'math-dots)) + (concat " " spfn) + " ...") math-comp-comma " " (list 'break math-compose-level) (math-compose-expr (nth (1- (length a)) a) @@ -353,62 +335,23 @@ (let ((v (rassq (nth 2 a) math-expr-variable-mapping))) (if v (symbol-name (car v)) - (if (and (memq calc-language '(tex latex)) - calc-language-option - (not (= calc-language-option 0)) - (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" - (symbol-name (nth 1 a)))) - (if (eq calc-language 'latex) - (format "\\text{%s}" (symbol-name (nth 1 a))) - (format "\\hbox{%s}" (symbol-name (nth 1 a)))) - (if (and math-compose-hash-args - (let ((p calc-arg-values)) - (setq v 1) - (while (and p (not (equal (car p) a))) - (setq p (and (eq math-compose-hash-args t) (cdr p)) - v (1+ v))) - p)) - (if (eq math-compose-hash-args 1) - "#" - (format "#%d" v)) - (if (memq calc-language '(c fortran pascal maple)) - (math-to-underscores (symbol-name (nth 1 a))) - (if (and (eq calc-language 'eqn) - (string-match ".'\\'" (symbol-name (nth 2 a)))) - (math-compose-expr - (list 'calcFunc-Prime - (list - 'var - (intern (substring (symbol-name (nth 1 a)) 0 -1)) - (intern (substring (symbol-name (nth 2 a)) 0 -1)))) - prec) - (symbol-name (nth 1 a))))))))) + (if (setq spfn (get calc-language 'math-var-formatter)) + (funcall spfn a prec) + (math-compose-var a))))) ((eq (car a) 'intv) (list 'horiz - (if (eq calc-language 'maple) "" - (if (memq (nth 1 a) '(0 1)) "(" "[")) + (if (memq (nth 1 a) '(0 1)) "(" "[") (math-compose-expr (nth 2 a) 0) - (if (memq calc-language '(tex latex)) " \\ldots " - (if (eq calc-language 'eqn) " ... " " .. ")) + " .. " (math-compose-expr (nth 3 a) 0) - (if (eq calc-language 'maple) "" - (if (memq (nth 1 a) '(0 2)) ")" "]")))) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) ((eq (car a) 'date) (if (eq (car calc-date-format) 'X) (math-format-date a) (concat "<" (math-format-date a) ">"))) - ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a)) - (memq calc-language '(c pascal fortran maple))) - (let ((args (cdr (cdr a)))) - (while (and (memq calc-language '(pascal fortran)) - (eq (car-safe (nth 1 a)) 'calcFunc-subscr)) - (setq args (append (cdr (cdr (nth 1 a))) args) - a (nth 1 a))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - (if (eq calc-language 'fortran) "(" "[") - (math-compose-vector args ", " 0) - (if (eq calc-language 'fortran) ")" "]")))) + ((and (eq (car a) 'calcFunc-subscr) + (setq spfn (get calc-language 'math-compose-subscr))) + (funcall spfn a)) ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) (eq calc-language 'big)) (let* ((a1 (math-compose-expr (nth 1 a) 1000)) @@ -425,25 +368,6 @@ ", " a2)) (list 'subscr a1 a2)))) - ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) - (eq calc-language 'math)) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[[" - (math-compose-expr (nth 2 a) 0) - "]]")) - ((and (eq (car a) 'calcFunc-sqrt) - (memq calc-language '(tex latex))) - (list 'horiz - "\\sqrt{" - (math-compose-expr (nth 1 a) 0) - "}")) - ((and nil (eq (car a) 'calcFunc-sqrt) - (eq calc-language 'eqn)) - (list 'horiz - "sqrt {" - (math-compose-expr (nth 1 a) -1) - "}")) ((and (eq (car a) '^) (eq calc-language 'big)) (list 'supscr @@ -468,14 +392,6 @@ (list 'vcent (math-comp-height a1) a1 '(rule ?-) a2))) - ((and (memq (car a) '(calcFunc-sum calcFunc-prod)) - (memq calc-language '(tex latex)) - (= (length a) 5)) - (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod") - "_{" (math-compose-expr (nth 2 a) 0) - "=" (math-compose-expr (nth 3 a) 0) - "}^{" (math-compose-expr (nth 4 a) 0) - "}{" (math-compose-expr (nth 1 a) 0) "}")) ((and (eq (car a) 'calcFunc-lambda) (> (length a) 2) (memq calc-language '(nil flat big))) @@ -524,11 +440,9 @@ (integerp (nth 2 a))) (let ((c (math-compose-expr (nth 1 a) -1))) (if (> prec (nth 2 a)) - (if (memq calc-language '(tex latex)) - (list 'horiz "\\left( " c " \\right)") - (if (eq calc-language 'eqn) - (list 'horiz "{left ( " c " right )}") - (list 'horiz "(" c ")"))) + (if (setq spfn (get calc-language 'math-big-parens)) + (list 'horiz (car spfn) c (cdr spfn)) + (list 'horiz "(" c ")")) c))) ((and (eq (car a) 'calcFunc-choriz) (not (eq calc-language 'unform)) @@ -662,13 +576,13 @@ (make-list (nth 1 a) c)))))) ((and (eq (car a) 'calcFunc-evalto) (setq calc-any-evaltos t) - (memq calc-language '(tex latex eqn)) + (setq spfn (get calc-language 'math-evalto)) (= math-compose-level (if math-comp-tagged 2 1)) (= (length a) 3)) (list 'horiz - (if (memq calc-language '(tex latex)) "\\evalto " "evalto ") + (car spfn) (math-compose-expr (nth 1 a) 0) - (if (memq calc-language '(tex latex)) " \\to " " -> ") + (cdr spfn) (math-compose-expr (nth 2 a) 0))) (t (let ((op (and (not (eq calc-language 'unform)) @@ -867,6 +781,9 @@ ( tex . math-compose-tex ) ( latex . math-compose-latex ) ( eqn . math-compose-eqn ) + ( yacas . math-compose-yacas ) + ( maxima . math-compose-maxima ) + ( giac . math-compose-giac ) ( math . math-compose-math ) ( maple . math-compose-maple )))) (setq op (get (car a) (cdr op))) @@ -894,56 +811,16 @@ (symbol-name func)) (math-match-substring (symbol-name func) 1) (symbol-name func)))) - (if (memq calc-language '(c fortran pascal maple)) + (if (memq calc-language calc-lang-allow-percentsigns) + (setq func (math-to-percentsigns func))) + (if (memq calc-language calc-lang-allow-underscores) (setq func (math-to-underscores func))) - (if (and (memq calc-language '(tex latex)) - calc-language-option - (not (= calc-language-option 0)) - (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) - (if (< (prefix-numeric-value calc-language-option) 0) - (setq func (format "\\%s" func)) - (setq func (if (eq calc-language 'latex) - (format "\\text{%s}" func) - (format "\\hbox{%s}" func))))) - (if (and (eq calc-language 'eqn) - (string-match "[^']'+\\'" func)) - (let ((n (- (length func) (match-beginning 0) 1))) - (setq func (substring func 0 (- n))) - (while (>= (setq n (1- n)) 0) - (setq func (concat func " prime"))))) - (cond ((and (memq calc-language '(tex latex)) - (or (> (length a) 2) - (not (math-tex-expr-is-flat (nth 1 a))))) - (setq left "\\left( " - right " \\right)")) - ((and (eq calc-language 'eqn) - (or (> (length a) 2) - (not (math-tex-expr-is-flat (nth 1 a))))) - (setq left "{left ( " - right " right )}")) - ((and (or (and (memq calc-language '(tex latex)) - (eq (aref func 0) ?\\)) - (and (eq calc-language 'eqn) - (memq (car a) math-eqn-special-funcs))) - (not (or - (string-match "\\hbox{" func) - (string-match "\\text{" func))) - (= (length a) 2) - (or (Math-realp (nth 1 a)) - (memq (car (nth 1 a)) '(var *)))) - (setq left (if (eq calc-language 'eqn) "~{" "{") - right "}")) - ((eq calc-language 'eqn) - (setq left " ( " - right " )")) - (t (setq left calc-function-open - right calc-function-close))) - (list 'horiz func left - (math-compose-vector (cdr a) - (if (eq calc-language 'eqn) - " , " ", ") - 0) - right))))))))) + (if (setq spfn (get calc-language 'math-func-formatter)) + (funcall spfn func a) + + (list 'horiz func calc-function-open + (math-compose-vector (cdr a) ", " 0) + calc-function-close)))))))))) (defun math-prod-first-term (x) @@ -1002,8 +879,12 @@ (if (<= count 0) (if (< count 0) (math-compose-rows (cdr a) -1 nil) - (cons (concat (if (memq calc-language '(tex latex)) " \\ldots" " ...") - math-comp-comma) + (cons (concat + (let ((mdots (get calc-language 'math-dots))) + (if mdots + (concat " " mdots) + " ...")) + math-comp-comma) (math-compose-rows (cdr a) -1 nil))) (cons (list 'horiz (if first (concat math-comp-left-bracket " ") " ") @@ -1015,31 +896,6 @@ (math-compose-expr (car a) math-comp-vector-prec) (concat " " math-comp-right-bracket))))) -(defun math-compose-tex-matrix (a &optional ltx) - (if (cdr a) - (cons (append (math-compose-vector (cdr (car a)) " & " 0) - (if ltx '(" \\\\ ") '(" \\cr "))) - (math-compose-tex-matrix (cdr a) ltx)) - (list (math-compose-vector (cdr (car a)) " & " 0)))) - -(defun math-compose-eqn-matrix (a) - (if a - (cons - (cond ((eq calc-matrix-just 'right) "rcol ") - ((eq calc-matrix-just 'center) "ccol ") - (t "lcol ")) - (cons - (list 'break math-compose-level) - (cons - "{ " - (cons - (let ((math-compose-level (1+ math-compose-level))) - (math-compose-vector (cdr (car a)) " above " 1000)) - (cons - " } " - (math-compose-eqn-matrix (cdr a))))))) - nil)) - (defun math-vector-is-string (a) (while (and (setq a (cdr a)) (or (and (natnump (car a)) @@ -1091,6 +947,12 @@ (concat (math-match-substring x 1) "_" (math-match-substring x 2))) x)) +(defun math-to-percentsigns (x) + (if (string-match "\\`\\(.*\\)o'o\\(.*\\)\\'" x) + (math-to-underscores + (concat (math-match-substring x 1) "%" (math-match-substring x 2))) + x)) + (defun math-tex-expr-is-flat (a) (or (Math-integerp a) (memq (car a) '(float var)) |