diff options
Diffstat (limited to 'lisp/calc')
45 files changed, 842 insertions, 495 deletions
diff --git a/lisp/calc/README b/lisp/calc/README index 308b5115aa2..638b482a60a 100644 --- a/lisp/calc/README +++ b/lisp/calc/README @@ -1,11 +1,11 @@ -Copyright (C) 2001-2011 Free Software Foundation, Inc. +Copyright (C) 2001-2012 Free Software Foundation, Inc. See the end of the file for license conditions. This directory contains Calc, an advanced desk calculator for GNU Emacs. -"Calc" Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +"Calc" Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. Written by: Dave Gillespie @@ -70,6 +70,19 @@ opinions. Summary of changes to "Calc" ------- -- ------- -- ---- +Emacs 24.4 + +* The date forms use the Gregorian calendar for all dates. + (Previously they were a combination of Julian and Gregorian + dates.) This can be configured with the customizable variable + `calc-gregorian-switch'. + +Emacs 24.3 + +* Algebraic simplification mode is now the default. + To restrict to the limited simplifications given by the former + default simplification mode, use `m I'. + Emacs 24.1 * Support for musical notes added. diff --git a/lisp/calc/README.prev b/lisp/calc/README.prev index 69da211efc2..bc1189a7065 100644 --- a/lisp/calc/README.prev +++ b/lisp/calc/README.prev @@ -1,4 +1,4 @@ -Copyright (C) 2001-2011 Free Software Foundation, Inc. +Copyright (C) 2001-2012 Free Software Foundation, Inc. See the end of the file for license conditions. diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index 00e07aba6a5..4cca7fb7e7f 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -1,6 +1,6 @@ ;;; calc-aent.el --- algebraic entry functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -286,8 +286,7 @@ The value t means abort and give an error message.") ;;;###autoload (defun calc-alg-entry (&optional initial prompt) - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (calc-plain-entry t) diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el index 5ad1e58b45c..3182e85a8c6 100644 --- a/lisp/calc/calc-alg.el +++ b/lisp/calc/calc-alg.el @@ -1,6 +1,6 @@ ;;; calc-alg.el --- algebraic functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -356,6 +356,8 @@ ;; math-simplify-step, which is called by math-simplify. (defvar math-top-only) +;; math-normalize-error is declared in calc.el. +(defvar math-normalize-error) (defun math-simplify (top-expr) (let ((math-simplifying t) (math-top-only (consp calc-simplify-mode)) @@ -383,10 +385,12 @@ (calc-with-default-simplification (while (let ((r simp-rules)) (setq res (math-normalize top-expr)) - (while r - (setq res (math-rewrite res (car r)) - r (cdr r))) - (not (equal top-expr (setq res (math-simplify-step res))))) + (if (not math-normalize-error) + (progn + (while r + (setq res (math-rewrite res (car r)) + r (cdr r))) + (not (equal top-expr (setq res (math-simplify-step res))))))) (setq top-expr res))))) top-expr) @@ -530,7 +534,10 @@ (not (Math-realp (nth 1 math-simplify-expr)))) (math-common-constant-factor (nth 1 math-simplify-expr)))) (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n)) - (progn + (unless (and (eq (car-safe math-simplify-expr) 'calcFunc-eq) + (eq (car-safe (nth 1 math-simplify-expr)) 'var) + (not (math-expr-contains (nth 2 math-simplify-expr) + (nth 1 math-simplify-expr)))) (setcar (cdr math-simplify-expr) (math-mul (nth 2 nn) (nth 1 math-simplify-expr))) (setcar (cdr (cdr math-simplify-expr)) diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el index a557e5fb92d..ad807e9a2de 100644 --- a/lisp/calc/calc-arith.el +++ b/lisp/calc/calc-arith.el @@ -1,6 +1,6 @@ ;;; calc-arith.el --- arithmetic functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el index 44354f0822f..7e1c69ffcfa 100644 --- a/lisp/calc/calc-bin.el +++ b/lisp/calc/calc-bin.el @@ -1,6 +1,6 @@ ;;; calc-bin.el --- binary functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index da5bae69803..431ea18f580 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -1,6 +1,6 @@ ;;; calc-comb.el --- combinatoric functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -77,7 +77,7 @@ 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 5003]) -;; The variable math-prime-factors-finished is set by calcFunc-prfac to +;; The variable math-prime-factors-finished is set by calcFunc-prfac to ;; indicate whether factoring is complete, and used by calcFunc-factors, ;; calcFunc-totient and calcFunc-moebius. (defvar math-prime-factors-finished) @@ -510,8 +510,8 @@ (while (<= (length math-stirling-local-cache) n) (let ((i (1- (length math-stirling-local-cache))) row) - (setq math-stirling-local-cache - (vconcat math-stirling-local-cache + (setq math-stirling-local-cache + (vconcat math-stirling-local-cache (make-vector (length math-stirling-local-cache) nil))) (aset math-stirling-cache k math-stirling-local-cache) (while (< (setq i (1+ i)) (length math-stirling-local-cache)) @@ -572,7 +572,6 @@ (let ((i 200)) (while (> (setq i (1- i)) 0) (math-random-base)))) - (random t) (setq var-RandSeed nil math-random-cache nil math-random-shift -4) ; assume RAND_MAX >= 16383 @@ -629,7 +628,7 @@ (i (/ (+ n slop) 3)) (rnum 0)) (while (> i 0) - (setq rnum + (setq rnum (math-add (math-random-three-digit-number) (math-mul rnum 1000))) @@ -823,11 +822,11 @@ (setq sum (% (+ sum - (calcFunc-mod + (calcFunc-mod q 1000000)) 111111)) - (setq q - (math-quotient + (setq q + (math-quotient q 1000000))) (cond ((= (% sum 3) 0) '(nil 3)) ((= (% sum 7) 0) '(nil 7)) diff --git a/lisp/calc/calc-cplx.el b/lisp/calc/calc-cplx.el index f2e0c493144..e05204764bc 100644 --- a/lisp/calc/calc-cplx.el +++ b/lisp/calc/calc-cplx.el @@ -1,6 +1,6 @@ ;;; calc-cplx.el --- Complex number functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index f1f79252857..954e5d0b72f 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el @@ -1,6 +1,6 @@ ;;; calc-embed.el --- embed Calc in a buffer -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 5429509af86..c7d93530fd7 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1,6 +1,6 @@ ;;; calc-ext.el --- various extension functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -61,7 +61,7 @@ (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-compose-expr "calccomp" (a prec &optional div)) (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)) @@ -460,6 +460,7 @@ (define-key calc-mode-map "mD" 'calc-default-simplify-mode) (define-key calc-mode-map "mE" 'calc-ext-simplify-mode) (define-key calc-mode-map "mF" 'calc-settings-file-name) + (define-key calc-mode-map "mI" 'calc-basic-simplify-mode) (define-key calc-mode-map "mM" 'calc-more-recursion-depth) (define-key calc-mode-map "mN" 'calc-num-simplify-mode) (define-key calc-mode-map "mO" 'calc-no-simplify-mode) @@ -1095,11 +1096,11 @@ calc-tan calc-tanh calc-to-degrees calc-to-radians) ("calc-mode" calc-alg-simplify-mode calc-algebraic-mode calc-always-load-extensions calc-auto-recompute calc-auto-why -calc-bin-simplify-mode calc-break-vectors calc-center-justify -calc-default-simplify-mode calc-display-raw calc-eng-notation -calc-ext-simplify-mode calc-fix-notation calc-full-trail-vectors -calc-full-vectors calc-get-modes calc-group-char calc-group-digits -calc-infinite-mode calc-left-justify calc-left-label +calc-basic-simplify-mode calc-bin-simplify-mode calc-break-vectors +calc-center-justify calc-default-simplify-mode calc-display-raw +calc-eng-notation calc-ext-simplify-mode calc-fix-notation +calc-full-trail-vectors calc-full-vectors calc-get-modes calc-group-char +calc-group-digits calc-infinite-mode calc-left-justify calc-left-label calc-line-breaking calc-line-numbering calc-matrix-brackets calc-matrix-center-justify calc-matrix-left-justify calc-matrix-mode calc-matrix-right-justify calc-mode-record-mode calc-no-simplify-mode @@ -1996,51 +1997,36 @@ calc-kill calc-kill-region calc-yank)))) (cache-val (intern (concat (symbol-name name) "-cache"))) (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-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 - (list 'cons - (list 'quote cache-prec) - (list 'cons - (list 'quote last-prec) - 'math-cache-list))) - (list 'defun - name () - (list 'or - (list '= last-prec 'calc-internal-prec) - (list 'setq - last-val - (list 'math-normalize - (list 'progn - (list 'or - (list '>= cache-prec - 'calc-internal-prec) - (list 'setq - cache-val - (list 'let - '((calc-internal-prec - (+ calc-internal-prec - 4))) - form) - cache-prec - '(+ calc-internal-prec 2))) - cache-val)) - last-prec 'calc-internal-prec)) - last-val)))) + `(progn +; (defvar ,cache-prec ,(if init (math-numdigs (nth 1 init)) -100)) + (defvar ,cache-prec (cond + ((consp ,init) (math-numdigs (nth 1 ,init))) + (,init + (nth 1 (math-numdigs (eval ,init)))) + (t + -100))) + (defvar ,cache-val (cond ((consp ,init) ,init) + (,init (eval ,init)) + (t ,init))) + (defvar ,last-prec -100) + (defvar ,last-val nil) + (setq math-cache-list + (cons ',cache-prec + (cons ',last-prec + math-cache-list))) + (defun ,name () + (or (= ,last-prec calc-internal-prec) + (setq ,last-val + (math-normalize + (progn (or (>= ,cache-prec calc-internal-prec) + (setq ,cache-val + (let ((calc-internal-prec + (+ calc-internal-prec 4))) + ,form) + ,cache-prec (+ calc-internal-prec 2))) + ,cache-val)) + ,last-prec calc-internal-prec)) + ,last-val)))) (put 'math-defcache 'lisp-indent-hook 2) ;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] @@ -3497,7 +3483,7 @@ If X is not an error form, return 1." (substring str i)))) str)) -;;; Users can redefine this in their .emacs files. +;;; Users can redefine this in their init files. (defvar calc-keypad-user-menu nil "If non-nil, this describes an additional menu for calc-keypad. It should contain a list of three rows. diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el index 2e1d072dfb8..36165eaab63 100644 --- a/lisp/calc/calc-fin.el +++ b/lisp/calc/calc-fin.el @@ -1,6 +1,6 @@ ;;; calc-fin.el --- financial functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 912bbc7f78d..98b22550f75 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -1,6 +1,6 @@ ;;; calc-forms.el --- data format conversion functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -369,17 +369,68 @@ ;;; Some of these functions are adapted from Edward Reingold's "calendar.el". ;;; These versions are rewritten to use arbitrary-size integers. -;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian -;;; calendar is used; the first day after 9/2/1752 is 9/14/1752. ;;; A numerical date is the number of days since midnight on -;;; the morning of January 1, 1 A.D. If the date is a non-integer, -;;; it represents a specific date and time. +;;; the morning of December 31, 1 B.C. (Gregorian) or January 2, 1 A.D. (Julian). +;;; Emacs's calendar refers to such a date as an absolute date, some Calc function +;;; names also use that terminology. If the date is a non-integer, it represents +;;; a specific date and time. ;;; A "dt" is a list of the form, (year month day), corresponding to ;;; an integer code, or (year month day hour minute second), corresponding ;;; to a non-integer code. +(defun math-date-to-gregorian-dt (date) + "Return the day (YEAR MONTH DAY) in the Gregorian calendar. +DATE is the number of days since December 31, -1 in the Gregorian calendar." + (let* ((month 1) + day + (year (math-quotient (math-add date (if (Math-lessp date 711859) + 365 ; for speed, we take + -108)) ; >1950 as a special case + (if (math-negp date) 366 365))) + ; this result may be an overestimate + temp) + (while (Math-lessp date (setq temp (math-absolute-from-gregorian-dt year 1 1))) + (setq year (math-add year -1))) + (if (eq year 0) (setq year -1)) + (setq date (1+ (math-sub date temp))) + (setq temp + (if (math-leap-year-p year) + [1 32 61 92 122 153 183 214 245 275 306 336 999] + [1 32 60 91 121 152 182 213 244 274 305 335 999])) + (while (>= date (aref temp month)) + (setq month (1+ month))) + (setq day (1+ (- date (aref temp (1- month))))) + (list year month day))) + +(defun math-date-to-julian-dt (date) + "Return the day (YEAR MONTH DAY) in the Julian calendar. +DATE is the number of days since December 31, -1 in the Gregorian calendar." + (let* ((month 1) + day + (year (math-quotient (math-add date (if (Math-lessp date 711859) + 367 ; for speed, we take + -106)) ; >1950 as a special case + (if (math-negp date) 366 365))) + ; this result may be an overestimate + temp) + (while (Math-lessp date (setq temp (math-absolute-from-julian-dt year 1 1))) + (setq year (math-add year -1))) + (if (eq year 0) (setq year -1)) + (setq date (1+ (math-sub date temp))) + (setq temp + (if (math-leap-year-p year t) + [1 32 61 92 122 153 183 214 245 275 306 336 999] + [1 32 60 91 121 152 182 213 244 274 305 335 999])) + (while (>= date (aref temp month)) + (setq month (1+ month))) + (setq day (1+ (- date (aref temp (1- month))))) + (list year month day))) + (defun math-date-to-dt (value) + "Return the day and time of VALUE. +The integer part of VALUE is the number of days since Dec 31, -1 +in the Gregorian calendar and the remaining part determines the time." (if (eq (car-safe value) 'date) (setq value (nth 1 value))) (or (math-realp value) @@ -387,32 +438,21 @@ (let* ((parts (math-date-parts value)) (date (car parts)) (time (nth 1 parts)) - (month 1) - day - (year (math-quotient (math-add date (if (Math-lessp date 711859) - 365 ; for speed, we take - -108)) ; >1950 as a special case - (if (math-negp value) 366 365))) - ; this result may be an overestimate - temp) - (while (Math-lessp date (setq temp (math-absolute-from-date year 1 1))) - (setq year (math-add year -1))) - (if (eq year 0) (setq year -1)) - (setq date (1+ (math-sub date temp))) - (and (eq year 1752) (>= date 247) - (setq date (+ date 11))) - (setq temp (if (math-leap-year-p year) - [1 32 61 92 122 153 183 214 245 275 306 336 999] - [1 32 60 91 121 152 182 213 244 274 305 335 999])) - (while (>= date (aref temp month)) - (setq month (1+ month))) - (setq day (1+ (- date (aref temp (1- month))))) + (dt (if (and calc-gregorian-switch + (Math-lessp value + (or + (nth 3 calc-gregorian-switch) + (apply 'math-absolute-from-gregorian-dt calc-gregorian-switch)) +)) + (math-date-to-julian-dt date) + (math-date-to-gregorian-dt date)))) (if (math-integerp value) - (list year month day) - (list year month day - (/ time 3600) - (% (/ time 60) 60) - (math-add (% time 60) (nth 2 parts)))))) + dt + (append dt + (list + (/ time 3600) + (% (/ time 60) 60) + (math-add (% time 60) (nth 2 parts))))))) (defun math-dt-to-date (dt) (or (integerp (nth 1 dt)) @@ -423,7 +463,7 @@ (math-reject-arg (nth 2 dt) 'fixnump)) (if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31)) (math-reject-arg (nth 2 dt) "Day value is out of range")) - (let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt)))) + (let ((date (math-absolute-from-dt (car dt) (nth 1 dt) (nth 2 dt)))) (if (nth 3 dt) (math-add (math-float date) (math-div (math-add (+ (* (nth 3 dt) 3600) @@ -444,13 +484,19 @@ (defun math-this-year () - (string-to-number (substring (current-time-string) -4))) - -(defun math-leap-year-p (year) - (if (Math-lessp year 1752) + (nth 5 (decode-time))) + +(defun math-leap-year-p (year &optional julian) + "Non-nil if YEAR is a leap year. +If JULIAN is non-nil, then use the criterion for leap years +in the Julian calendar, otherwise use the criterion in the +Gregorian calendar." + (if julian (if (math-negp year) (= (math-imod (math-neg year) 4) 1) (= (math-imod year 4) 0)) + (if (math-negp year) + (setq year (math-sub -1 year))) (setq year (math-imod year 400)) (or (and (= (% year 4) 0) (/= (% year 100) 0)) (= year 0)))) @@ -460,41 +506,106 @@ 29 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) -(defun math-day-number (year month day) +(defun math-day-in-year (year month day &optional julian) + "Return the number of days of the year up to YEAR MONTH DAY. +The count includes the given date. +If JULIAN is non-nil, use the Julian calendar, otherwise +use the Gregorian calendar." (let ((day-of-year (+ day (* 31 (1- month))))) (if (> month 2) (progn (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) - (if (math-leap-year-p year) + (if (math-leap-year-p year julian) (setq day-of-year (1+ day-of-year))))) - (and (eq year 1752) - (or (> month 9) - (and (= month 9) (>= day 14))) - (setq day-of-year (- day-of-year 11))) day-of-year)) -(defun math-absolute-from-date (year month day) +(defun math-day-number (year month day) + "Return the number of days of the year up to YEAR MONTH DAY. +The count includes the given date." + (if calc-gregorian-switch + (cond ((eq year (nth 0 calc-gregorian-switch)) + (1+ + (- (math-absolute-from-dt year month day) + (math-absolute-from-dt year 1 1)))) + ((Math-lessp year (nth 0 calc-gregorian-switch)) + (math-day-in-year year month day t)) + (t + (math-day-in-year year month day))) + (math-day-in-year year month day))) + +(defun math-dt-before-p (dt1 dt2) + "Non-nil if DT1 occurs before DT2. +A DT is a list of the form (YEAR MONTH DAY)." + (or (Math-lessp (nth 0 dt1) (nth 0 dt2)) + (and (equal (nth 0 dt1) (nth 0 dt2)) + (or (< (nth 1 dt1) (nth 1 dt2)) + (and (= (nth 1 dt1) (nth 1 dt2)) + (< (nth 2 dt1) (nth 2 dt2))))))) + +(defun math-absolute-from-gregorian-dt (year month day) + "Return the DATE of the day given by the Gregorian day YEAR MONTH DAY. +Recall that DATE is the number of days since December 31, -1 +in the Gregorian calendar." + (if (eq year 0) (setq year -1)) + (let ((yearm1 (math-sub year 1))) + (math-sub + ;; Add the number of days of the year and the numbers of days + ;; in the previous years (leap year days to be added separately) + (math-add (math-day-in-year year month day) + (math-add (math-mul 365 yearm1) + ;; Add the number of Julian leap years + (if (math-posp year) + (math-quotient yearm1 4) + (math-sub 365 + (math-quotient (math-sub 3 year) + 4))))) + ;; Subtract the number of Julian leap years which are not + ;; Gregorian leap years. In C=4N+r centuries, there will + ;; be 3N+r of these days. The following will compute + ;; 3N+r. + (let* ((correction (math-mul (math-quotient yearm1 100) 3)) + (res (math-idivmod correction 4))) + (math-add (if (= (cdr res) 0) + 0 + 1) + (car res)))))) + +(defun math-absolute-from-julian-dt (year month day) + "Return the DATE of the day given by the Julian day YEAR MONTH DAY. +Recall that DATE is the number of days since December 31, -1 +in the Gregorian calendar." (if (eq year 0) (setq year -1)) (let ((yearm1 (math-sub year 1))) - (math-sub (math-add (math-day-number year month day) - (math-add (math-mul 365 yearm1) - (if (math-posp year) - (math-quotient yearm1 4) - (math-sub 365 - (math-quotient (math-sub 3 year) - 4))))) - (if (or (Math-lessp year 1753) - (and (eq year 1752) (<= month 9))) - 1 - (let ((correction (math-mul (math-quotient yearm1 100) 3))) - (let ((res (math-idivmod correction 4))) - (math-add (if (= (cdr res) 0) - -1 - 0) - (car res)))))))) - - -;;; It is safe to redefine these in your .emacs file to use a different + (math-sub + ;; Add the number of days of the year and the numbers of days + ;; in the previous years (leap year days to be added separately) + (math-add (math-day-in-year year month day) + (math-add (math-mul 365 yearm1) + ;; Add the number of Julian leap years + (if (math-posp year) + (math-quotient yearm1 4) + (math-sub 365 + (math-quotient (math-sub 3 year) + 4))))) + ;; Adjustment, since January 1, 1 (Julian) is absolute day -1 + 2))) + +;; calc-gregorian-switch is a customizable variable defined in calc.el +(defvar calc-gregorian-switch) + + +(defun math-absolute-from-dt (year month day) + "Return the DATE of the day given by the day YEAR MONTH DAY. +Recall that DATE is the number of days since December 31, -1 +in the Gregorian calendar." + (if (and calc-gregorian-switch + ;; The next few lines determine if the given date + ;; occurs before the switch to the Gregorian calendar. + (math-dt-before-p (list year month day) calc-gregorian-switch)) + (math-absolute-from-julian-dt year month day) + (math-absolute-from-gregorian-dt year month day))) + +;;; It is safe to redefine these in your init file to use a different ;;; language. (defvar math-long-weekday-names '( "Sunday" "Monday" "Tuesday" "Wednesday" @@ -548,13 +659,13 @@ (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 '(float 17214225 -1) + "The beginning of the Julian date calendar, +as measured in the number of days before December 31, 1 BC (Gregorian).") -(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.") +(defconst math-julian-date-beginning-int 1721423 + "The beginning of the Julian date calendar, +as measured in the integer number of days before December 31, 1 BC (Gregorian).") (defun math-format-date-part (x) (cond ((stringp x) @@ -585,8 +696,7 @@ as measured in the integer number of days before January 1 of the year 1AD.") math-fd-year (car math-fd-dt) math-fd-month (nth 1 math-fd-dt) math-fd-day (nth 2 math-fd-dt) - math-fd-weekday (math-mod - (math-add (math-floor math-fd-date) 6) 7) + math-fd-weekday (math-mod (math-floor math-fd-date) 7) math-fd-hour (nth 3 math-fd-dt) math-fd-minute (nth 4 math-fd-dt) math-fd-second (nth 5 math-fd-dt)) @@ -1098,7 +1208,7 @@ as measured in the integer number of days before January 1 of the year 1AD.") (setq date (nth 1 date))) (or (math-realp date) (math-reject-arg date 'datep)) - (math-mod (math-add (math-floor date) 6) 7)) + (math-mod (math-floor date) 7)) (defun calcFunc-yearday (date) (let ((dt (math-date-to-dt date))) @@ -1298,7 +1408,7 @@ second, the number of seconds offset for daylight savings." 0))) (rounded-abs-date (+ - (calendar-absolute-from-gregorian + (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) @@ -1434,28 +1544,100 @@ and ends on the last Sunday of October at 2 a.m." (and (math-messy-integerp day) (setq day (math-trunc day))) (or (integerp day) (math-reject-arg day 'fixnump)) (and (or (< day 0) (> day 31)) (math-reject-arg day 'range)) - (let ((dt (math-date-to-dt date))) - (if (or (= day 0) (> day (math-days-in-month (car dt) (nth 1 dt)))) - (setq day (math-days-in-month (car dt) (nth 1 dt)))) - (and (eq (car dt) 1752) (= (nth 1 dt) 9) - (if (>= day 14) (setq day (- day 11)))) - (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) - (1- day))))) + (let* ((dt (math-date-to-dt date)) + (dim (math-days-in-month (car dt) (nth 1 dt))) + (julian (if calc-gregorian-switch + (math-date-to-dt (math-sub + (or (nth 3 calc-gregorian-switch) + (apply 'math-absolute-from-gregorian-dt calc-gregorian-switch)) + 1))))) + (if (or (= day 0) (> day dim)) + (setq day (1- dim)) + (setq day (1- day))) + ;; Adjust if this occurs near the switch to the Gregorian calendar + (if calc-gregorian-switch + (cond + ((and (math-dt-before-p (list (car dt) (nth 1 dt) 1) calc-gregorian-switch) + (math-dt-before-p julian (list (car dt) (nth 1 dt) 1))) + ;; In this case, CALC-GREGORIAN-SWITCH is the first day of the month + (list 'date + (math-dt-to-date (list (car calc-gregorian-switch) + (nth 1 calc-gregorian-switch) + (if (> (+ (nth 2 calc-gregorian-switch) day) dim) + dim + (+ (nth 2 calc-gregorian-switch) day)))))) + ((and (eq (car dt) (car calc-gregorian-switch)) + (= (nth 1 dt) (nth 1 calc-gregorian-switch))) + ;; In this case, the switch to the Gregorian calendar occurs in the given month + (if (< (+ (nth 2 julian) day) (nth 2 calc-gregorian-switch)) + ;; If the DAYth day occurs before the switch, use it + (list 'date (math-dt-to-date (list (car dt) (nth 1 dt) (1+ day)))) + ;; Otherwise do some computations + (let ((tm (+ day (- (nth 2 calc-gregorian-switch) (nth 2 julian))))) + (list 'date (math-dt-to-date + (list (car dt) + (nth 1 dt) + ;; + (if (> tm dim) dim tm))))))) + ((and (eq (car dt) (car julian)) + (= (nth 1 dt) (nth 1 julian))) + ;; In this case, the current month is truncated because of the switch + ;; to the Gregorian calendar + (list 'date (math-dt-to-date + (list (car dt) + (nth 1 dt) + (if (>= day (nth 2 julian)) + (nth 2 julian) + (1+ day)))))) + (t + ;; The default + (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) day)))) + (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) day))))) (defun calcFunc-newyear (date &optional day) + (if (eq (car-safe date) 'date) (setq date (nth 1 date))) (or day (setq day 1)) (and (math-messy-integerp day) (setq day (math-trunc day))) (or (integerp day) (math-reject-arg day 'fixnump)) - (let ((dt (math-date-to-dt date))) + (let* ((dt (math-date-to-dt date)) + (gregbeg (if calc-gregorian-switch + (or (nth 3 calc-gregorian-switch) + (apply 'math-absolute-from-gregorian-dt calc-gregorian-switch)))) + (julianend (if calc-gregorian-switch (math-sub gregbeg 1))) + (julian (if calc-gregorian-switch + (math-date-to-dt julianend)))) (if (and (>= day 0) (<= day 366)) - (let ((max (if (eq (car dt) 1752) 355 - (if (math-leap-year-p (car dt)) 366 365)))) + (let ((max (if (math-leap-year-p (car dt)) 366 365))) (if (or (= day 0) (> day max)) (setq day max)) - (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) - (1- day)))) + (if calc-gregorian-switch + ;; Now to break this down into cases + (cond + ((and (math-dt-before-p (list (car dt) 1 1) calc-gregorian-switch) + (math-dt-before-p julian (list (car dt) 1 1))) + ;; In this case, CALC-GREGORIAN-SWITCH is the first day of the year + (list 'date (math-min (math-add gregbeg (1- day)) + (math-dt-to-date (list (car calc-gregorian-switch) 12 31))))) + ((eq (car dt) (car julian)) + ;; In this case, the switch to the Gregorian calendar occurs in the given year + (if (Math-lessp (car julian) (car calc-gregorian-switch)) + ;; Here, the last Julian day is the last day of the year. + (list 'date (math-min (math-add (math-dt-to-date (list (car dt) 1 1)) (1- day)) + julianend)) + ;; Otherwise, just make sure the date doesn't go past the end of the year + (list 'date (math-min (math-add (math-dt-to-date (list (car dt) 1 1)) (1- day)) + (math-dt-to-date (list (car dt) 12 31)))))) + (t + (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) + (1- day))))) + (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) + (1- day))))) (if (and (>= day -12) (<= day -1)) - (list 'date (math-dt-to-date (list (car dt) (- day) 1))) - (math-reject-arg day 'range))))) + (if (and calc-gregorian-switch + (math-dt-before-p (list (car dt) (- day) 1) calc-gregorian-switch) + (math-dt-before-p julian (list (car dt) (- day) 1))) + (list 'date gregbeg) + (list 'date (math-dt-to-date (list (car dt) (- day) 1)))) + (math-reject-arg day 'range))))) (defun calcFunc-incmonth (date &optional step) (or step (setq step 1)) diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el index 30894b406b5..5b7c2cb3366 100644 --- a/lisp/calc/calc-frac.el +++ b/lisp/calc/calc-frac.el @@ -1,6 +1,6 @@ ;;; calc-frac.el --- fraction functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el index e065493562e..b5857a8bbbf 100644 --- a/lisp/calc/calc-funcs.el +++ b/lisp/calc/calc-funcs.el @@ -1,6 +1,6 @@ ;;; calc-funcs.el --- well-known functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 4fd5045f54b..c127b70a80d 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -1,6 +1,6 @@ ;;; calc-graph.el --- graph output functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index 66e9c002a47..b17c6b4e3b8 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -1,6 +1,6 @@ ;;; calc-help.el --- help display functions for Calc, -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -642,7 +642,7 @@ C-w Describe how there is no warranty for Calc." '("Deg, Rad, HMS; Frac; Polar; Inf; Alg, Total; Symb; Vec/mat" "Working; Xtensions; Mode-save; preserve Embedded modes" "SHIFT + Shifted-prefixes, mode-Filename; Record; reCompute" - "SHIFT + simplify: Off, Num, Default, Bin, Alg, Ext, Units") + "SHIFT + simplify: Off, Num, basIc, Algebraic, Bin, Ext, Units") "mode" ?m)) diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el index a9cf89e6058..f39bf291613 100644 --- a/lisp/calc/calc-incom.el +++ b/lisp/calc/calc-incom.el @@ -1,6 +1,6 @@ ;;; calc-incom.el --- complex data type input functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el index cc10d9e993c..3a59f6927a6 100644 --- a/lisp/calc/calc-keypd.el +++ b/lisp/calc/calc-keypd.el @@ -1,6 +1,6 @@ ;;; calc-keypd.el --- mouse-capable keypad input for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index 7e3a08a1459..ec4c497a1c6 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -1,6 +1,6 @@ ;;; calc-lang.el --- calc language functions -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -133,8 +133,39 @@ ( asin . calcFunc-arcsin ) ( asinh . calcFunc-arcsinh ) ( atan . calcFunc-arctan ) - ( atan2 . calcFunc-arctan2 ) - ( atanh . calcFunc-arctanh ))) + ( atan2 . calcFunc-arctan2 ) + ( atanh . calcFunc-arctanh ) + ( fma . (math-C-parse-fma)) + ( fmax . calcFunc-max ) + ( j0 . (math-C-parse-bess)) + ( jn . calcFunc-besJ ) + ( j1 . (math-C-parse-bess)) + ( yn . calcFunc-besY ) + ( y0 . (math-C-parse-bess)) + ( y1 . (math-C-parse-bess)) + ( tgamma . calcFunc-gamma ))) + +(defun math-C-parse-bess (f val) + "Parse C's j0, j1, y0, y1 functions." + (let ((args (math-read-expr-list))) + (math-read-token) + (append + (cond ((eq val 'j0) '(calcFunc-besJ 0)) + ((eq val 'j1) '(calcFunc-besJ 1)) + ((eq val 'y0) '(calcFunc-besY 0)) + ((eq val 'y1) '(calcFunc-besY 1))) + args))) + +(defun math-C-parse-fma (f val) + "Parse C's fma function fma(x,y,z) => (x * y + z)." + (let ((args (math-read-expr-list))) + (math-read-token) + (list 'calcFunc-add + (list 'calcFunc-mul + (nth 0 args) + (nth 1 args)) + (nth 2 args)))) + (put 'c 'math-variable-table '( ( M_PI . var-pi ) diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index f922687e7fa..7f3ff9f012e 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -1,6 +1,6 @@ ;;; calc-macs.el --- important macros for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el index 2ea4de20293..9276e1a7832 100644 --- a/lisp/calc/calc-map.el +++ b/lisp/calc/calc-map.el @@ -1,6 +1,6 @@ ;;; calc-map.el --- higher-order functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -32,8 +32,7 @@ (defun calc-apply (&optional oper) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (oper (or oper (calc-get-operator "Apply" @@ -53,11 +52,10 @@ (defun calc-reduce (&optional oper accum) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (nest (calc-is-hyperbolic)) + (let* ((nest (calc-is-hyperbolic)) (rev (calc-is-inverse)) (nargs (if (and nest (not rev)) 2 1)) - (calc-dollar-values (mapcar 'calc-get-stack-element + (calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (calc-mapping-dir (and (not accum) (not nest) "")) @@ -99,8 +97,7 @@ (defun calc-map (&optional oper) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (calc-mapping-dir "") @@ -120,8 +117,7 @@ (defun calc-map-equation (&optional oper) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (oper (or oper (calc-get-operator "Map-equation"))) @@ -152,8 +148,7 @@ (defun calc-outer-product (&optional oper) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (oper (or oper (calc-get-operator "Outer" 2)))) @@ -170,8 +165,7 @@ (defun calc-inner-product (&optional mul-oper add-oper) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2))) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 076dab31fd9..d5a341ee482 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -1,6 +1,6 @@ ;;; calc-math.el --- mathematical functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el index d8c01656784..9437c8bc105 100644 --- a/lisp/calc/calc-menu.el +++ b/lisp/calc/calc-menu.el @@ -1,6 +1,6 @@ ;;; calc-menu.el --- a menu for Calc -;; Copyright (C) 2007-2011 Free Software Foundation, Inc. +;; Copyright (C) 2007-2012 Free Software Foundation, Inc. ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -1201,6 +1201,63 @@ :keys "v ." :style toggle :selected (not calc-full-vectors)] + (list "Simplification" + ["No simplification mode" + (progn + (require 'calc-mode) + (calc-no-simplify-mode t)) + :keys "m O" + :style radio + :selected (eq calc-simplify-mode 'none) + :help "No simplifications are done automatically"] + ["Numeric simplification mode" + (progn + (require 'calc-mode) + (calc-num-simplify-mode t)) + :keys "m N" + :style radio + :selected (eq calc-simplify-mode 'num) + :help "Only numeric simplifications are done automatically"] + ["Basic simplification mode" + (progn + (require 'calc-mode) + (calc-basic-simplify-mode t)) + :keys "m I" + :style radio + :selected (eq calc-simplify-mode nil) + :help "Only basic simplifications are done automatically"] + ["Binary simplification mode" + (progn + (require 'calc-mode) + (calc-bin-simplify-mode t)) + :keys "m B" + :style radio + :selected (eq calc-simplify-mode 'binary) + :help "Basic simplifications with binary clipping are done automatically"] + ["Algebraic simplification mode" + (progn + (require 'calc-mode) + (calc-alg-simplify-mode t)) + :keys "m A" + :style radio + :selected (eq calc-simplify-mode 'alg) + :help "Standard algebraic simplifications are done automatically"] + ["Extended simplification mode" + (progn + (require 'calc-mode) + (calc-ext-simplify-mode t)) + :keys "m E" + :style radio + :selected (eq calc-simplify-mode 'ext) + :help "Extended (unsafe) simplifications are done automatically"] + ["Units simplification mode" + (progn + (require 'calc-mode) + (calc-units-simplify-mode t)) + :keys "m U" + :style radio + :selected (eq calc-simplify-mode 'units) + :help "Algebraic and unit simplifications are done automatically"]) (list "Angle Measure" ["Radians" (progn @@ -1412,6 +1469,45 @@ :style radio :selected (eq calc-algebraic-mode 'total) :help "All regular letters and punctuation begin algebraic entry"]) + (list "Matrix" + ["Off" + (progn + (require 'calc-mode) + (calc-matrix-mode -1)) + :style radio + :selected (eq calc-matrix-mode nil) + :help "Variables are not assumed to be matrix or scalar"] + ["Matrix mode" + (progn + (require 'calc-mode) + (calc-matrix-mode -2)) + :style radio + :selected (eq calc-matrix-mode 'matrix) + :help "Variables are assumed to be matrices"] + ["Square matrix mode" + (progn + (require 'calc-mode) + (calc-matrix-mode '(4))) + :style radio + :selected (eq calc-matrix-mode 'sqmatrix) + :help "Variables are assumed to be square matrices"] + ["Dimensioned matrix mode" + (let ((dim (string-to-number (read-from-minibuffer "Dimension: ")))) + (if (natnump dim) + (progn + (require 'calc-mode) + (calc-matrix-mode dim)) + (error "The dimension must be a positive integer"))) + :style radio + :selected (and (integerp calc-matrix-mode) (> calc-matrix-mode 0)) + :help "Variables are assumed to be NxN matrices"] + ["Scalar mode" + (progn + (require 'calc-mode) + (calc-matrix-mode 0)) + :style radio + :selected (eq calc-matrix-mode 'scalar) + :help "Variables are assumed to be scalars"]) (list "Language" ["Normal" (progn diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index d8bdc614e67..1d9c02a47a5 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -1,6 +1,6 @@ ;;; calc-misc.el --- miscellaneous functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -305,7 +305,8 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C). (string-match "\\`\\*" (car stuff))) (setq stuff (cons '* (cons (substring (car stuff) 1) (cdr stuff))))))) - (setq calc-next-why (cons stuff calc-next-why)) + (unless (member stuff calc-next-why) + (setq calc-next-why (cons stuff calc-next-why))) nil) ;; True if A is a constant or vector of constants. [P x] [Public] diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index 856dfad882d..f64e37dc0bf 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -1,6 +1,6 @@ ;;; calc-mode.el --- calculator modes for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -497,37 +497,40 @@ (defun calc-set-simplify-mode (mode arg msg) (calc-change-mode 'calc-simplify-mode - (if arg - (and (> (prefix-numeric-value arg) 0) - mode) - (and (not (eq calc-simplify-mode mode)) - mode))) + (cond + (arg mode) + ((eq calc-simplify-mode mode) + 'alg) + (t mode))) (message "%s" (if (eq calc-simplify-mode mode) msg - "Default simplifications enabled"))) + "Algebraic simplification occurs by default"))) (defun calc-no-simplify-mode (arg) (interactive "P") (calc-wrapper (calc-set-simplify-mode 'none arg - "All default simplifications are disabled"))) + "Simplification is disabled"))) (defun calc-num-simplify-mode (arg) (interactive "P") (calc-wrapper (calc-set-simplify-mode 'num arg - "Default simplifications apply only if arguments are numeric"))) + "Basic simplifications apply only if arguments are numeric"))) (defun calc-default-simplify-mode (arg) - (interactive "p") - (cond ((= arg 1) + (interactive "P") + (cond ((or (not arg) (= arg 3)) + (calc-wrapper + (calc-set-simplify-mode + 'alg nil "Algebraic simplification occurs by default"))) + ((= arg 1) (calc-wrapper (calc-set-simplify-mode - nil nil "Usual default simplifications are enabled"))) + nil nil "Only basic simplifications occur by default"))) ((= arg 0) (calc-num-simplify-mode 1)) ((< arg 0) (calc-no-simplify-mode 1)) ((= arg 2) (calc-bin-simplify-mode 1)) - ((= arg 3) (calc-alg-simplify-mode 1)) ((= arg 4) (calc-ext-simplify-mode 1)) ((= arg 5) (calc-units-simplify-mode 1)) (t (error "Prefix argument out of range")))) @@ -539,6 +542,12 @@ (format "Binary simplification occurs by default (word size=%d)" calc-word-size)))) +(defun calc-basic-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode nil arg + "Only basic simplifications occur by default"))) + (defun calc-alg-simplify-mode (arg) (interactive "P") (calc-wrapper diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el index 5ec15005b48..6fc2d9463d4 100644 --- a/lisp/calc/calc-mtx.el +++ b/lisp/calc/calc-mtx.el @@ -1,6 +1,6 @@ ;;; calc-mtx.el --- matrix functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el index bd162866c31..937d0177259 100644 --- a/lisp/calc/calc-nlfit.el +++ b/lisp/calc/calc-nlfit.el @@ -1,6 +1,6 @@ ;;; calc-nlfit.el --- nonlinear curve fitting for Calc -;; Copyright (C) 2007-2011 Free Software Foundation, Inc. +;; Copyright (C) 2007-2012 Free Software Foundation, Inc. ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el index e21a095c821..f106e8310a2 100644 --- a/lisp/calc/calc-poly.el +++ b/lisp/calc/calc-poly.el @@ -1,6 +1,6 @@ ;;; calc-poly.el --- polynomial functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index 0d3fbe8586a..411f55a24e6 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -1,6 +1,6 @@ ;;; calc-prog.el --- user programmability functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -1792,89 +1792,63 @@ Redefine the corresponding command." (defun math-do-defmath (func args body) (require 'calc-macs) (let* ((fname (intern (concat "calcFunc-" (symbol-name func)))) - (doc (if (stringp (car body)) (list (car body)))) + (doc (if (stringp (car body)) + (prog1 (list (car body)) + (setq body (cdr body))))) (clargs (mapcar 'math-clean-arg args)) - (body (math-define-function-body - (if (stringp (car body)) (cdr body) body) - clargs))) - (list 'progn - (if (and (consp (car body)) - (eq (car (car body)) 'interactive)) - (let ((inter (car body))) - (setq body (cdr body)) - (if (or (> (length inter) 2) - (integerp (nth 1 inter))) - (let ((hasprefix nil) (hasmulti nil)) - (if (stringp (nth 1 inter)) - (progn - (cond ((equal (nth 1 inter) "p") - (setq hasprefix t)) - ((equal (nth 1 inter) "m") - (setq hasmulti t)) - (t (error - "Can't handle interactive code string \"%s\"" - (nth 1 inter)))) - (setq inter (cdr inter)))) - (if (not (integerp (nth 1 inter))) - (error - "Expected an integer in interactive specification")) - (append (list 'defun - (intern (concat "calc-" - (symbol-name func))) - (if (or hasprefix hasmulti) - '(&optional n) - ())) - doc - (if (or hasprefix hasmulti) - '((interactive "P")) - '((interactive))) - (list - (append - '(calc-slow-wrapper) - (and hasmulti - (list - (list 'setq - 'n - (list 'if - 'n - (list 'prefix-numeric-value - 'n) - (nth 1 inter))))) - (list - (list 'calc-enter-result - (if hasmulti 'n (nth 1 inter)) - (nth 2 inter) - (if hasprefix - (list 'append - (list 'quote (list fname)) - (list 'calc-top-list-n - (nth 1 inter)) - (list 'and - 'n - (list - 'list - (list - 'math-normalize - (list - 'prefix-numeric-value - 'n))))) - (list 'cons - (list 'quote fname) - (list 'calc-top-list-n - (if hasmulti - 'n - (nth 1 inter))))))))))) - (append (list 'defun - (intern (concat "calc-" (symbol-name func))) - args) - doc - (list - inter - (cons 'calc-wrapper body)))))) - (append (list 'defun fname clargs) - doc - (math-do-arg-list-check args nil nil) - body)))) + (inter (if (and (consp (car body)) + (eq (car (car body)) 'interactive)) + (prog1 (car body) + (setq body (cdr body)))))) + (setq body (math-define-function-body body clargs)) + `(progn + ,(if inter + (if (or (> (length inter) 2) + (integerp (nth 1 inter))) + (let ((hasprefix nil) (hasmulti nil)) + (when (stringp (nth 1 inter)) + (cond ((equal (nth 1 inter) "p") + (setq hasprefix t)) + ((equal (nth 1 inter) "m") + (setq hasmulti t)) + (t (error + "Can't handle interactive code string \"%s\"" + (nth 1 inter)))) + (setq inter (cdr inter))) + (unless (integerp (nth 1 inter)) + (error "Expected an integer in interactive specification")) + `(defun ,(intern (concat "calc-" (symbol-name func))) + ,(if (or hasprefix hasmulti) '(&optional n) ()) + ,@doc + (interactive ,@(if (or hasprefix hasmulti) '("P"))) + (calc-slow-wrapper + ,@(if hasmulti + `((setq n (if n + (prefix-numeric-value n) + ,(nth 1 inter))))) + (calc-enter-result + ,(if hasmulti 'n (nth 1 inter)) + ,(nth 2 inter) + ,(if hasprefix + `(append '(,fname) + (calc-top-list-n ,(nth 1 inter)) + (and n + (list + (math-normalize + (prefix-numeric-value n))))) + `(cons ',fname + (calc-top-list-n + ,(if hasmulti + 'n + (nth 1 inter))))))))) + `(defun ,(intern (concat "calc-" (symbol-name func))) ,clargs + ,@doc + ,inter + (calc-wrapper ,@body)))) + (defun ,fname ,clargs + ,@doc + ,@(math-do-arg-list-check args nil nil) + ,@body)))) (defun math-clean-arg (arg) (if (consp arg) @@ -1887,56 +1861,42 @@ Redefine the corresponding command." (list (cons 'and (cons var (if (cdr chk) - (setq chk (list (cons 'progn chk))) + `((progn ,@chk)) chk))))) - (and (consp arg) - (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest)) - (qual (car arg)) - (qqual (list 'quote qual)) - (qual-name (symbol-name qual)) - (chk (intern (concat "math-check-" qual-name)))) - (if (fboundp chk) - (append rest - (list + (when (consp arg) + (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest)) + (qual (car arg)) + (qual-name (symbol-name qual)) + (chk (intern (concat "math-check-" qual-name)))) + (if (fboundp chk) + (append rest + (if is-rest + `((setq ,var (mapcar ',chk ,var))) + `((setq ,var (,chk ,var))))) + (if (fboundp (setq chk (intern (concat "math-" qual-name)))) + (append rest + (if is-rest + `((mapcar #'(lambda (x) + (or (,chk x) + (math-reject-arg x ',qual))) + ,var)) + `((or (,chk ,var) + (math-reject-arg ,var ',qual))))) + (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name) + (fboundp (setq chk (intern + (concat "math-" + (math-match-substring + qual-name 1)))))) + (append rest (if is-rest - (list 'setq var - (list 'mapcar (list 'quote chk) var)) - (list 'setq var (list chk var))))) - (if (fboundp (setq chk (intern (concat "math-" qual-name)))) - (append rest - (list - (if is-rest - (list 'mapcar - (list 'function - (list 'lambda '(x) - (list 'or - (list chk 'x) - (list 'math-reject-arg - 'x qqual)))) - var) - (list 'or - (list chk var) - (list 'math-reject-arg var qqual))))) - (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name) - (fboundp (setq chk (intern - (concat "math-" - (math-match-substring - qual-name 1)))))) - (append rest - (list - (if is-rest - (list 'mapcar - (list 'function - (list 'lambda '(x) - (list 'and - (list chk 'x) - (list 'math-reject-arg - 'x qqual)))) - var) - (list 'and - (list chk var) - (list 'math-reject-arg var qqual))))) - (error "Unknown qualifier `%s'" qual-name)))))))) + `((mapcar #'(lambda (x) + (and (,chk x) + (math-reject-arg x ',qual))) + ,var)) + `((and + (,chk ,var) + (math-reject-arg ,var ',qual))))) + (error "Unknown qualifier `%s'" qual-name)))))))) (defun math-do-arg-list-check (args is-opt is-rest) (cond ((null args) nil) @@ -1980,7 +1940,7 @@ Redefine the corresponding command." (defun math-define-function-body (body env) (let ((body (math-define-body body env))) (if (math-body-refers-to body 'math-return) - (list (cons 'catch (cons '(quote math-return) body))) + `((catch 'math-return ,@body)) body))) ;; The variable math-exp-env is local to math-define-body, but is diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el index 1498b622e1f..eed8a756e8e 100644 --- a/lisp/calc/calc-rewr.el +++ b/lisp/calc/calc-rewr.el @@ -1,6 +1,6 @@ ;;; calc-rewr.el --- rewriting functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -1439,21 +1439,19 @@ (put 'calcFunc-vxor 'math-rewrite-default '(vec)) (defmacro math-rwfail (&optional back) - (list 'setq 'pc - (list 'and - (if back - '(setq btrack (cdr btrack)) - 'btrack) - ''((backtrack))))) + `(setq pc (and ,(if back + '(setq btrack (cdr btrack)) + 'btrack) + '((backtrack))))) ;; This monstrosity is necessary because the use of static vectors of ;; registers makes rewrite rules non-reentrant. Yucko! (defmacro math-rweval (form) - (list 'let '((orig (car rules))) - '(setcar rules (quote (nil nil nil no-phase))) - (list 'unwind-protect - form - '(setcar rules orig)))) + `(let ((orig (car rules))) + (setcar rules '(nil nil nil no-phase)) + (unwind-protect + ,form + (setcar rules orig)))) (defvar math-rewrite-phase 1) diff --git a/lisp/calc/calc-rules.el b/lisp/calc/calc-rules.el index fa57a350729..4332753c228 100644 --- a/lisp/calc/calc-rules.el +++ b/lisp/calc/calc-rules.el @@ -1,6 +1,6 @@ ;;; calc-rules.el --- rules for simplifying algebraic expressions in Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el index 26834a44598..bdacf65603c 100644 --- a/lisp/calc/calc-sel.el +++ b/lisp/calc/calc-sel.el @@ -1,6 +1,6 @@ ;;; calc-sel.el --- data selection functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-stat.el b/lisp/calc/calc-stat.el index 83ce71a2376..04b0298dc88 100644 --- a/lisp/calc/calc-stat.el +++ b/lisp/calc/calc-stat.el @@ -1,6 +1,6 @@ ;;; calc-stat.el --- statistical functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index 2da551ee215..64df10a40ca 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -1,6 +1,6 @@ ;;; calc-store.el --- value storage functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -235,8 +235,7 @@ (defun calc-store-map (&optional oper var) (interactive) (calc-wrapper - (let* ((sel-mode nil) - (calc-dollar-values (mapcar 'calc-get-stack-element + (let* ((calc-dollar-values (mapcar #'calc-get-stack-element (nthcdr calc-stack-top calc-stack))) (calc-dollar-used 0) (oper (or oper (calc-get-operator "Store Mapping"))) diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el index 0558d8d2285..591bd89c3b8 100644 --- a/lisp/calc/calc-stuff.el +++ b/lisp/calc/calc-stuff.el @@ -1,6 +1,6 @@ ;;; calc-stuff.el --- miscellaneous functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el index eec4cd2af58..4e513b8241f 100644 --- a/lisp/calc/calc-trail.el +++ b/lisp/calc/calc-trail.el @@ -1,6 +1,6 @@ ;;; calc-trail.el --- functions for manipulating the Calc "trail" -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-undo.el b/lisp/calc/calc-undo.el index 9168d9b0947..6f69f99b5a2 100644 --- a/lisp/calc/calc-undo.el +++ b/lisp/calc/calc-undo.el @@ -1,6 +1,6 @@ ;;; calc-undo.el --- undo functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 86e8cbbc73a..58646ea114c 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -1,6 +1,6 @@ ;;; calc-units.el --- unit conversion functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -302,7 +302,7 @@ (defvar math-additional-units nil - "*Additional units table for user-defined units. + "Additional units table for user-defined units. Must be formatted like `math-standard-units'. If you change this, be sure to set `math-units-table' to nil to ensure that the combined units table will be rebuilt.") @@ -356,6 +356,8 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (math-to-standard-units (calc-top-n 1) nil)))))) +(defvar calc-ensure-consistent-units) + (defun calc-quick-units () (interactive) (calc-slow-wrapper @@ -370,8 +372,11 @@ Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") (unless (< pos (length units)) (error "Unit number %d not defined" pos)) (if (math-units-in-expr-p expr nil) - (calc-enter-result 1 (format "cun%d" num) - (math-convert-units expr (nth pos units))) + (progn + (if calc-ensure-consistent-units + (math-check-unit-consistency expr (nth pos units))) + (calc-enter-result 1 (format "cun%d" num) + (math-convert-units expr (nth pos units)))) (calc-enter-result 1 (format "*un%d" num) (math-simplify-units (math-mul expr (nth pos units)))))))) @@ -399,7 +404,7 @@ If EXPR is nil, return nil." (math-composition-to-string cexpr)))))) (defvar math-default-units-table - (make-hash-table :test 'equal) + #s(hash-table test equal data (1 (1))) "A table storing previously converted units.") (defun math-get-default-units (expr) @@ -413,21 +418,24 @@ If EXPR is nil, return nil." (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 math-put-default-units (expr &optional comp std) + "Put the units in EXPR in the default units table. +If COMP or STD is non-nil, put that in the units table instead." + (let* ((new-units (or comp std (math-get-units expr))) + (standard-units (math-get-standard-units + (cond + (comp (math-simplify-units expr)) + (std expr) + (t new-units)))) + (default-units (gethash standard-units math-default-units-table))) + (unless (eq standard-units 1) + (cond + ((not default-units) + (puthash standard-units (list new-units) math-default-units-table)) + ((not (equal new-units (car default-units))) + (puthash standard-units + (list new-units (car default-units)) + math-default-units-table)))))) (defun calc-convert-units (&optional old-units new-units) (interactive) @@ -451,45 +459,48 @@ If EXPR is nil, return nil." (when (eq (car-safe uold) 'error) (error "Bad format in units expression: %s" (nth 1 uold))) (setq expr (math-mul expr uold)))) - (unless 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)))) - (if std - (calc-enter-result 1 "cvun" (math-simplify-units - (math-to-standard-units expr - (nth 1 std)))) - (unless unew + (setq defunits (math-get-default-units expr)) + (if (equal defunits "1") + (progn + (calc-enter-result 1 "cvun" (math-simplify-units expr)) + (message "All units in expression cancel")) + (unless new-units + (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))) + (if calc-ensure-consistent-units + (math-check-unit-consistency expr 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))) + (comp (eq (car-safe units) '+))) + (unless (or unew std) (error "No units specified")) - (calc-enter-result 1 "cvun" - (math-convert-units - expr units - (and uoldname (not (equal uoldname "1")))))))))) + (let ((res + (if std + (math-simplify-units (math-to-standard-units expr (nth 1 std))) + (math-convert-units expr units (and uoldname (not (equal uoldname "1"))))))) + (math-put-default-units res (if comp units)) + (calc-enter-result 1 "cvun" res))))))) (defun calc-autorange-units (arg) (interactive "P") @@ -559,7 +570,7 @@ If EXPR is nil, return nil." (defun calc-extract-units () (interactive) (calc-slow-wrapper - (calc-enter-result 1 "rmun" (math-simplify-units + (calc-enter-result 1 "exun" (math-simplify-units (math-extract-units (calc-top-n 1)))))) ;; The variables calc-num-units and calc-den-units are local to @@ -913,6 +924,20 @@ If EXPR is nil, return nil." (math-single-units-in-expr-p (nth 1 expr)))) (t 'wrong))) +(defun math-consistent-units-p (expr newunits) + "Non-nil if EXPR and NEWUNITS have consistent units." + (or + (and (eq (car-safe newunits) 'var) + (assq (nth 1 newunits) math-standard-units-systems)) + (math-numberp (math-get-units (list '/ expr newunits))))) + +(defun math-check-unit-consistency (expr units) + "Give an error if EXPR and UNITS do not have consistent units." + (unless (math-consistent-units-p expr units) + (error "New units (%s) are inconsistent with current units (%s)" + (math-format-value units) + (math-format-value (math-get-units expr))))) + (defun math-check-unit-name (v) (and (eq (car-safe v) 'var) (or (assq (nth 1 v) (or math-units-table (math-build-units-table))) @@ -1456,10 +1481,16 @@ If EXPR is nil, return nil." (mapcar 'math-remove-units (cdr expr)))))) (defun math-extract-units (expr) - (if (memq (car-safe expr) '(* /)) - (cons (car expr) - (mapcar 'math-extract-units (cdr expr))) - (if (math-check-unit-name expr) expr 1))) + (cond + ((memq (car-safe expr) '(* /)) + (cons (car expr) + (mapcar 'math-extract-units (cdr expr)))) + ((and + (eq (car-safe expr) '^) + (math-check-unit-name (nth 1 expr))) + expr) + ((math-check-unit-name expr) expr) + (t 1))) (defun math-build-units-table-buffer (enter-buffer) (if (not (and math-units-table math-units-table-buffer-valid diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index 47ef3241b3e..d117cd6c19a 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -1,6 +1,6 @@ ;;; calc-vec.el --- vector functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index 135ea0bae40..1a6c53351f2 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -1,6 +1,6 @@ ;;; calc-yank.el --- kill-ring functionality for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 23f955afe7c..58eabf9bcec 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1,6 +1,6 @@ ;;; calc.el --- the GNU Emacs calculator -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -199,7 +199,7 @@ (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-compose-expr "calccomp" (a prec &optional div)) (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" ()) @@ -222,7 +222,7 @@ (defgroup calc nil - "GNU Calc." + "Advanced desk calculator and mathematical tool." :prefix "calc-" :tag "Calc" :group 'applications) @@ -418,6 +418,14 @@ in normal mode." :group 'calc :type 'boolean) +(defcustom calc-ensure-consistent-units + nil + "If non-nil, make sure new units are consistent with current units +when converting units." + :group 'calc + :version "24.3" + :type 'boolean) + (defcustom calc-undo-length 100 "The number of undo steps that will be preserved when Calc is quit." @@ -431,27 +439,33 @@ If `calc-show-selections' is non-nil, then selected sub-formulas are shown by displaying the rest of the formula in `calc-nonselected-face'. If `calc-show-selections' is nil, then selected sub-formulas are shown by displaying the sub-formula in `calc-selected-face'." + :version "24.1" :group 'calc :type 'boolean) (defcustom calc-lu-field-reference "20 uPa" "The default reference level for logarithmic units (field)." + :version "24.1" :group 'calc :type '(string)) (defcustom calc-lu-power-reference "mW" "The default reference level for logarithmic units (power)." + :version "24.1" :group 'calc :type '(string)) (defcustom calc-note-threshold "1" "The number of cents that a frequency should be near a note to be identified as that note." + :version "24.1" :type 'string :group 'calc) +(defvar math-format-date-cache) ; calc-forms.el + (defface calc-nonselected-face '((t :inherit shadow :slant italic)) @@ -687,11 +701,11 @@ If `C' is present, display outer brackets for matrices (centered).") (defcalcmodevar calc-previous-modulo nil "Most recently used value of M in a modulo form.") -(defcalcmodevar calc-simplify-mode nil +(defcalcmodevar calc-simplify-mode 'alg "Type of simplification applied to results. If `none', results are not simplified when pushed on the stack. If `num', functions are simplified only when args are constant. -If nil, only fast simplifications are applied. +If nil, only limited simplifications are applied. If `binary', `math-clip' is applied if appropriate. If `alg', `math-simplify' is applied. If `ext', `math-simplify-extended' is applied. @@ -813,7 +827,7 @@ If nil, selections displayed but ignored.") Used by `calc-user-invocation'.") (defcalcmodevar calc-show-banner t - "*If non-nil, show a friendly greeting above the stack.") + "If non-nil, show a friendly greeting above the stack.") (defconst calc-local-var-list '(calc-stack calc-stack-top @@ -901,35 +915,6 @@ Used by `calc-user-invocation'.") (defvar calc-embedded-mode-hook nil "Hook run when starting embedded mode.") -;; Set up the autoloading linkage. -(let ((name (and (fboundp 'calc-dispatch) - (eq (car-safe (symbol-function 'calc-dispatch)) 'autoload) - (nth 1 (symbol-function 'calc-dispatch)))) - (p load-path)) - - ;; If Calc files exist on the load-path, we're all set. - (while (and p (not (file-exists-p - (expand-file-name "calc-misc.elc" (car p))))) - (setq p (cdr p))) - (or p - - ;; If Calc is autoloaded using a path name, look there for Calc files. - ;; This works for both relative ("calc/calc.elc") and absolute paths. - (and name (file-name-directory name) - (let ((p2 load-path) - (name2 (concat (file-name-directory name) - "calc-misc.elc"))) - (while (and p2 (not (file-exists-p - (expand-file-name name2 (car p2))))) - (setq p2 (cdr p2))) - (when p2 - (setq load-path (nconc load-path - (list - (directory-file-name - (file-name-directory - (expand-file-name - name (car p2)))))))))))) - ;; The following modes use specially-formatted data. (put 'calc-mode 'mode-class 'special) (put 'calc-trail-mode 'mode-class 'special) @@ -1342,12 +1327,12 @@ Notations: 3.14e6 3.14 * 10^6 \\{calc-mode-map} " (interactive) - (mapc (function + (mapc (function ;FIXME: Why (set-default v (symbol-value v)) ?!?!? (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)) - (mapc (function (lambda (v) (make-local-variable v))) calc-local-var-list) + (mapc #'make-local-variable 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) @@ -1384,7 +1369,7 @@ Notations: 3.14e6 3.14 * 10^6 (if calc-buffer-list (setq calc-stack (copy-sequence calc-stack))) (add-to-list 'calc-buffer-list (current-buffer) t)) -(defvar calc-check-defines 'calc-check-defines) ; suitable for run-hooks +(defvar calc-check-defines 'calc-check-defines) ; Suitable for run-hooks. (defun calc-check-defines () (if (symbol-plist 'calc-define) (let ((plist (copy-sequence (symbol-plist 'calc-define)))) @@ -1746,10 +1731,10 @@ See calc-keypad for details." ((eq calc-simplify-mode 'num) "NumSimp ") ((eq calc-simplify-mode 'binary) (format "BinSimp%d " calc-word-size)) - ((eq calc-simplify-mode 'alg) "AlgSimp ") + ((eq calc-simplify-mode 'alg) "") ((eq calc-simplify-mode 'ext) "ExtSimp ") ((eq calc-simplify-mode 'units) "UnitSimp ") - (t "")) + (t "BasicSimp ")) ;; Display modes (cond ((= calc-number-radix 10) "") @@ -1932,8 +1917,7 @@ See calc-keypad for details." (delete-region (point) (point-max)))) (calc-set-command-flag 'renum-stack)))))) -(defvar sel-mode) -(defun calc-get-stack-element (x) +(defun calc-get-stack-element (x &optional sel-mode) (cond ((eq sel-mode 'entry) x) ((eq sel-mode 'sel) @@ -1950,9 +1934,9 @@ See calc-keypad for details." (defun calc-top (&optional n sel-mode) (or n (setq n 1)) (calc-check-stack n) - (calc-get-stack-element (nth (+ n calc-stack-top -1) calc-stack))) + (calc-get-stack-element (nth (+ n calc-stack-top -1) calc-stack) sel-mode)) -(defun calc-top-n (&optional n sel-mode) ; in case precision has changed +(defun calc-top-n (&optional n sel-mode) ; In case precision has changed. (math-check-complete (calc-normalize (calc-top n sel-mode)))) (defun calc-top-list (&optional n m sel-mode) @@ -1963,7 +1947,8 @@ See calc-keypad for details." (let ((top (copy-sequence (nthcdr (+ m calc-stack-top -1) calc-stack)))) (setcdr (nthcdr (1- n) top) nil) - (nreverse (mapcar 'calc-get-stack-element top))))) + (nreverse + (mapcar (lambda (x) (calc-get-stack-element x sel-mode)) top))))) (defun calc-top-list-n (&optional n m sel-mode) (mapcar 'math-check-complete @@ -2037,6 +2022,50 @@ See calc-keypad for details." (calc-refresh align))) (setq calc-refresh-count (1+ calc-refresh-count))) +;; Dates that are built-in options for `calc-gregorian-switch' should be +;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. +(defcustom calc-gregorian-switch nil + "The first day the Gregorian calendar is used by Calc's date forms. +This is `nil' (the default) if the Gregorian calendar is the only one used. +Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use +the Gregorian calendar; Calc will use the Julian calendar for earlier dates. +The dates in which different regions of the world began to use the +Gregorian calendar vary quite a bit, even within a single country. +If you want Calc's date forms to switch between the Julian and +Gregorian calendar, you can specify the date or choose from several +common choices. Some of these choices should be taken with a grain +of salt; for example different parts of France changed calendars at +different times, and Sweden's change to the Gregorian calendar was +complicated. Also, the boundaries of the countries were different at +the times of the calendar changes than they are now. +The Vatican decided that the Gregorian calendar should take effect +on 15 October 1582 (Gregorian), and many Catholic countries made +the change then. Great Britain and its colonies had the Gregorian +calendar take effect on 14 September 1752 (Gregorian); this includes +the United States." + :group 'calc + :version "24.4" + :type '(choice (const :tag "Always use the Gregorian calendar" nil) + (const :tag "1582-10-15 - Italy, Poland, Portugal, Spain" (1582 10 15 577736)) + (const :tag "1582-12-20 - France" (1582 12 20 577802)) + (const :tag "1582-12-25 - Luxemburg" (1582 12 25 577807)) + (const :tag "1584-01-17 - Bohemia and Moravia" (1584 1 17 578195)) + (const :tag "1587-11-01 - Hungary" (1587 11 1 579579)) + (const :tag "1700-03-01 - Denmark" (1700 3 1 620607)) + (const :tag "1701-01-12 - Protestant Switzerland" (1701 1 12 620924)) + (const :tag "1752-09-14 - Great Britain and dominions" (1752 9 14 639797)) + (const :tag "1753-03-01 - Sweden" (1753 3 1 639965)) + (const :tag "1918-02-14 - Russia" (1918 2 14 700214)) + (const :tag "1919-04-14 - Romania" (1919 4 14 700638)) + (list :tag "(YEAR MONTH DAY)" + (integer :tag "Year") + (integer :tag "Month (integer)") + (integer :tag "Day"))) + :set (lambda (symbol value) + (set-default symbol value) + (setq math-format-date-cache nil) + (calc-refresh))) + ;;;; The Calc Trail buffer. (defun calc-check-trail-aligned () @@ -2572,7 +2601,11 @@ largest Emacs integer.") ;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] (defvar math-normalize-a) +(defvar math-normalize-error nil + "Non-nil if the last call the `math-normalize' returned an error.") + (defun math-normalize (math-normalize-a) + (setq math-normalize-error nil) (cond ((not (consp math-normalize-a)) (if (integerp math-normalize-a) @@ -2661,31 +2694,38 @@ largest Emacs integer.") (fboundp (car math-normalize-a)))) (apply (car math-normalize-a) args))))) (wrong-number-of-arguments + (setq math-normalize-error t) (calc-record-why "*Wrong number of arguments" (cons (car math-normalize-a) args)) nil) (wrong-type-argument + (setq math-normalize-error t) (or calc-next-why (calc-record-why "Wrong type of argument" (cons (car math-normalize-a) args))) nil) (args-out-of-range + (setq math-normalize-error t) (calc-record-why "*Argument out of range" (cons (car math-normalize-a) args)) nil) (inexact-result + (setq math-normalize-error t) (calc-record-why "No exact representation for result" (cons (car math-normalize-a) args)) nil) (math-overflow + (setq math-normalize-error t) (calc-record-why "*Floating-point overflow occurred" (cons (car math-normalize-a) args)) nil) (math-underflow + (setq math-normalize-error t) (calc-record-why "*Floating-point underflow occurred" (cons (car math-normalize-a) args)) nil) (void-variable + (setq math-normalize-error t) (if (eq (nth 1 err) 'var-EvalRules) (progn (setq var-EvalRules nil) diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el index 25b51fc89f6..5fd5b35654c 100644 --- a/lisp/calc/calcalg2.el +++ b/lisp/calc/calcalg2.el @@ -1,6 +1,6 @@ ;;; calcalg2.el --- more algebraic functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -667,21 +667,18 @@ (defvar math-integral-limit) (defmacro math-tracing-integral (&rest parts) - (list 'and - 'trace-buffer - (list 'with-current-buffer - 'trace-buffer - '(goto-char (point-max)) - (list 'and - '(bolp) - '(insert (make-string (- math-integral-limit - math-integ-level) 32) - (format "%2d " math-integ-depth) - (make-string math-integ-level 32))) - ;;(list 'condition-case 'err - (cons 'insert parts) - ;; '(error (insert (prin1-to-string err)))) - '(sit-for 0)))) + `(and trace-buffer + (with-current-buffer trace-buffer + (goto-char (point-max)) + (and (bolp) + (insert (make-string (- math-integral-limit + math-integ-level) 32) + (format "%2d " math-integ-depth) + (make-string math-integ-level 32))) + ;;(condition-case err + (insert ,@parts) + ;; (error (insert (prin1-to-string err)))) + (sit-for 0)))) ;;; The following wrapper caches results and avoids infinite recursion. ;;; Each cache entry is: ( A B ) Integral of A is B; diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el index a9118964b46..9e6cdda057f 100644 --- a/lisp/calc/calcalg3.el +++ b/lisp/calc/calcalg3.el @@ -1,6 +1,6 @@ ;;; calcalg3.el --- more algebraic functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 906517ac503..2f1c95b7668 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -1,6 +1,6 @@ ;;; calccomp.el --- composition functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> @@ -86,8 +86,11 @@ (setq sn (math-to-underscores sn))) sn))) -(defun math-compose-expr (a prec) - (let ((math-compose-level (1+ math-compose-level)) +;;; Give multiplication precedence when composing to avoid +;;; writing a*(b c) instead of a b c +(defun math-compose-expr (a prec &optional div) + (let ((calc-multiplication-has-precedence t) + (math-compose-level (1+ math-compose-level)) (math-expr-opers (math-expr-ops)) spfn) (cond @@ -591,7 +594,9 @@ (or (= (length a) 3) (eq (car a) 'calcFunc-if)) (/= (nth 3 op) -1)) (cond - ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op)))) + ((or + (> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op)))) + (and div (eq (car a) '*))) (if (and (memq calc-language '(tex latex)) (not (math-tex-expr-is-flat a))) (if (eq (car-safe a) '/) @@ -631,7 +636,7 @@ nil) math-compose-level)) (lhs (math-compose-expr (nth 1 a) (nth 2 op))) - (rhs (math-compose-expr (nth 2 a) (nth 3 op)))) + (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/)))) (and (equal (car op) "^") (eq (math-comp-first-char lhs) ?-) (setq lhs (list 'horiz "(" lhs ")"))) diff --git a/lisp/calc/calcsel2.el b/lisp/calc/calcsel2.el index f44da07763f..770420f8deb 100644 --- a/lisp/calc/calcsel2.el +++ b/lisp/calc/calcsel2.el @@ -1,6 +1,6 @@ ;;; calcsel2.el --- selection functions for Calc -;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc. ;; Author: David Gillespie <daveg@synaptics.com> ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> |