diff options
Diffstat (limited to 'lisp/calc/calc.el')
| -rw-r--r-- | lisp/calc/calc.el | 258 |
1 files changed, 176 insertions, 82 deletions
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 5f95deb3c64..755834f913c 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -401,6 +401,13 @@ This is not required to be present for user-written mode annotations." :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'.") @@ -2276,7 +2283,21 @@ See calc-keypad for details." +(defconst math-bignum-digit-length 4 +; (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 +2306,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,7 +2406,8 @@ 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)) @@ -2394,7 +2422,8 @@ See calc-keypad for details." math-normalize-a (cond ((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) 1000))) + (* (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) @@ -2408,7 +2437,8 @@ See calc-keypad for details." math-normalize-a (cond ((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a) - (* (nth 2 math-normalize-a) 1000)))) + (* (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) @@ -2528,7 +2558,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 +2576,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 +2594,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 +2626,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 +2647,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 +2676,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 +2699,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 +2729,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 +2778,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 +2817,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 +2867,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 +2894,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 +2964,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 +2981,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 +3001,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 +3020,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 +3029,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 +3043,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 +3058,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 +3074,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 +3389,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 +3415,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,15 +3461,42 @@ 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)))) @@ -3467,8 +3539,6 @@ See calc-keypad for details." ( "!" calcFunc-fact 210 -1 ) ( "^" ^ 201 200 ) ( "**" ^ 201 200 ) - ( "*" * 196 195 ) - ( "2x" * 196 195 ) ( "/" / 190 191 ) ( "%" % 190 191 ) ( "\\" calcFunc-idiv 190 191 ) @@ -3492,7 +3562,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) |