mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-22 10:26:20 +00:00
Code Issues Releases Activity

Style cleanup; don't put closing parens on their

Browse Source 
own line, add "foo.el ends here" to each file, and update
copyright date.
This commit is contained in:
Colin Walters 2001-11-14 09:09:09 +00:00
parent c9aef71977
commit bf77c646a5
34 changed files with 1579 additions and 3119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

173
lisp/calc/calc-comb.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-comb.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -34,52 +34,44 @@
(defun calc-gcd (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op "gcd" 'calcFunc-gcd arg))
)
(calc-binary-op "gcd" 'calcFunc-gcd arg)))
(defun calc-lcm (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op "lcm" 'calcFunc-lcm arg))
)
(calc-binary-op "lcm" 'calcFunc-lcm arg)))
(defun calc-extended-gcd ()
(interactive)
(calc-slow-wrapper
(calc-enter-result 2 "egcd" (cons 'calcFunc-egcd (calc-top-list-n 2))))
)
(calc-enter-result 2 "egcd" (cons 'calcFunc-egcd (calc-top-list-n 2)))))
(defun calc-factorial (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "fact" 'calcFunc-fact arg))
)
(calc-unary-op "fact" 'calcFunc-fact arg)))
(defun calc-gamma (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "gmma" 'calcFunc-gamma arg))
)
(calc-unary-op "gmma" 'calcFunc-gamma arg)))
(defun calc-double-factorial (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "dfac" 'calcFunc-dfact arg))
)
(calc-unary-op "dfac" 'calcFunc-dfact arg)))
(defun calc-choose (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-binary-op "perm" 'calcFunc-perm arg)
(calc-binary-op "chos" 'calcFunc-choose arg)))
)
(calc-binary-op "chos" 'calcFunc-choose arg))))
(defun calc-perm (arg)
(interactive "P")
(calc-hyperbolic-func)
(calc-choose arg)
)
(calc-choose arg))
(defvar calc-last-random-limit '(float 1 0))
(defun calc-random (n)
@ -91,29 +83,25 @@
(prefix-numeric-value n))))
(calc-enter-result 1 "rand" (list 'calcFunc-random
(calc-get-random-limit
(calc-top-n 1))))))
)
(calc-top-n 1)))))))
(defun calc-get-random-limit (val)
(if (eq val 0)
calc-last-random-limit
(setq calc-last-random-limit val))
)
(setq calc-last-random-limit val)))
(defun calc-rrandom ()
(interactive)
(calc-slow-wrapper
(setq calc-last-random-limit '(float 1 0))
(calc-enter-result 0 "rand" (list 'calcFunc-random '(float 1 0))))
)
(calc-enter-result 0 "rand" (list 'calcFunc-random '(float 1 0)))))
(defun calc-random-again (arg)
(interactive "p")
(calc-slow-wrapper
(while (>= (setq arg (1- arg)) 0)
(calc-enter-result 0 "rand" (list 'calcFunc-random
calc-last-random-limit))))
)
calc-last-random-limit)))))
(defun calc-shuffle (n)
(interactive "P")
@ -126,8 +114,7 @@
(calc-enter-result 2 "shuf" (list 'calcFunc-shuffle
(calc-top-n 1)
(calc-get-random-limit
(calc-top-n 2))))))
)
(calc-top-n 2)))))))
(defun calc-report-prime-test (res)
(cond ((eq (car res) t)
@ -146,16 +133,14 @@
"prim" "Probably prime (%d iters; %s%% chance of error)"
(nth 1 res)
(let ((calc-float-format '(fix 2)))
(math-format-number (nth 2 res))))))
)
(math-format-number (nth 2 res)))))))
(defun calc-prime-test (iters)
(interactive "p")
(calc-slow-wrapper
(let* ((n (calc-top-n 1))
(res (math-prime-test n iters)))
(calc-report-prime-test res)))
)
(calc-report-prime-test res))))
(defun calc-next-prime (iters)
(interactive "p")
@ -165,14 +150,12 @@
(calc-enter-result 1 "prvp" (list 'calcFunc-prevprime
(calc-top-n 1) (math-abs iters)))
(calc-enter-result 1 "nxtp" (list 'calcFunc-nextprime
(calc-top-n 1) (math-abs iters))))))
)
(calc-top-n 1) (math-abs iters)))))))
(defun calc-prev-prime (iters)
(interactive "p")
(calc-invert-func)
(calc-next-prime iters)
)
(calc-next-prime iters))
(defun calc-prime-factors (iters)
(interactive "p")
@ -180,23 +163,17 @@
(let ((res (calcFunc-prfac (calc-top-n 1))))
(if (not math-prime-factors-finished)
(calc-record-message "pfac" "Warning: May not be fully factored"))
(calc-enter-result 1 "pfac" res)))
)
(calc-enter-result 1 "pfac" res))))
(defun calc-totient (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "phi" 'calcFunc-totient arg))
)
(calc-unary-op "phi" 'calcFunc-totient arg)))
(defun calc-moebius (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "mu" 'calcFunc-moebius arg))
)
(calc-unary-op "mu" 'calcFunc-moebius arg)))
(defun calcFunc-gcd (a b)
@ -224,15 +201,13 @@
(list 'calcFunc-gcd a b))
(t
(calc-record-why 'integerp b)
(list 'calcFunc-gcd a b)))
)
(list 'calcFunc-gcd a b))))
(defun calcFunc-lcm (a b)
(let ((g (calcFunc-gcd a b)))
(if (Math-numberp g)
(math-div (math-mul a b) g)
(list 'calcFunc-lcm a b)))
)
(list 'calcFunc-lcm a b))))
(defun calcFunc-egcd (a b) ; Knuth section 4.5.2
(cond
@ -256,8 +231,7 @@
t2 (math-sub u2 (math-mul v2 (car q)))
u1 v1 u2 v2 u3 v3
v1 t1 v2 t2 v3 (cdr q)))
(list 'vec u3 u1 u2))))
)
(list 'vec u3 u1 u2)))))
;;; Factorial and related functions.
@ -318,8 +292,7 @@
(math-gammap1-raw (math-float n)))))))
((equal n '(var inf var-inf)) n)
(t (calc-record-why 'numberp n)
(list 'calcFunc-fact n))))
)
(list 'calcFunc-fact n)))))
(math-defcache math-gamma-1q nil
(math-with-extra-prec 3
@ -334,8 +307,7 @@
(math-working (format "factorial(%d)" (1- n)) f))
(if (> count 0)
(math-factorial-iter (1- count) (1+ n) (math-mul n f))
f)
)
f))
(defun calcFunc-dfact (n) ; [I I] [F F] [Public]
(cond ((Math-integer-negp n)
@ -364,16 +336,14 @@
(list 'calcFunc-dfact max))))
((equal n '(var inf var-inf)) n)
(t (calc-record-why 'natnump n)
(list 'calcFunc-dfact n)))
)
(list 'calcFunc-dfact n))))
(defun math-double-factorial-iter (max n f step)
(if (< (% n 12) step)
(math-working (format "dfact(%d)" (- n step)) f))
(if (<= n max)
(math-double-factorial-iter max (+ n step) (math-mul n f) step)
f)
)
f))
(defun calcFunc-perm (n m) ; [I I I] [F F F] [Public]
(cond ((and (integerp n) (integerp m) (<= m n) (>= m 0))
@ -397,8 +367,7 @@
(or (integerp tm) (math-reject-arg tm 'fixnump))
(or (and (<= tm tn) (>= tm 0)) (math-reject-arg tm 'range))
(math-with-extra-prec 1
(math-factorial-iter tm (1+ (- tn tm)) '(float 1 0))))))
)
(math-factorial-iter tm (1+ (- tn tm)) '(float 1 0)))))))
(defun calcFunc-choose (n m) ; [I I I] [F F F] [Public]
(cond ((and (integerp n) (integerp m) (<= m n) (>= m 0))
@ -434,8 +403,7 @@
(calcFunc-fact (math-float
(math-sub n m)))))
(math-with-extra-prec 1
(math-choose-float-iter tm n 1 1))))))
)
(math-choose-float-iter tm n 1 1)))))))
(defun math-choose-iter (m n i c)
(if (and (= (% i 5) 1) (> i 5))
@ -443,8 +411,7 @@
(if (<= i m)
(math-choose-iter m (1- n) (1+ i)
(math-quotient (math-mul c n) i))
c)
)
c))
(defun math-choose-float-iter (count n i c)
(if (= (% i 5) 1)
@ -452,19 +419,16 @@
(if (> count 0)
(math-choose-float-iter (1- count) (math-sub n 1) (1+ i)
(math-div (math-mul c n) i))
c)
)
c))
;;; Stirling numbers.
(defun calcFunc-stir1 (n m)
(math-stirling-number n m 1)
)
(math-stirling-number n m 1))
(defun calcFunc-stir2 (n m)
(math-stirling-number n m 0)
)
(math-stirling-number n m 0))
(defun math-stirling-number (n m k)
(or (math-num-natnump n) (math-reject-arg n 'natnump))
@ -487,23 +451,20 @@
(aset row i 1))))
(if (= k 1)
(math-stirling-1 n m)
(math-stirling-2 n m))))
)
(math-stirling-2 n m)))))
(setq math-stirling-cache (vector [[1]] [[1]]))
(defun math-stirling-1 (n m)
(or (aref (aref cache n) m)
(aset (aref cache n) m
(math-add (math-stirling-1 (1- n) (1- m))
(math-mul (- 1 n) (math-stirling-1 (1- n) m)))))
)
(math-mul (- 1 n) (math-stirling-1 (1- n) m))))))
(defun math-stirling-2 (n m)
(or (aref (aref cache n) m)
(aset (aref cache n) m
(math-add (math-stirling-2 (1- n) (1- m))
(math-mul m (math-stirling-2 (1- n) m)))))
)
(math-mul m (math-stirling-2 (1- n) m))))))
;;; Produce a random 10-bit integer, with (random) if no seed provided,
@ -544,8 +505,7 @@
(if (> (lsh (math-abs (random)) math-random-shift) 4095)
(setq math-random-shift (1- math-random-shift)))))
(setq math-last-RandSeed var-RandSeed
math-gaussian-cache nil)
)
math-gaussian-cache nil))
(defun math-random-base ()
(if var-RandSeed
@ -558,8 +518,7 @@
(logand (- (car math-random-ptr1)
(car math-random-ptr2)) 524287))
-6) 1023))
(logand (lsh (random) math-random-shift) 1023))
)
(logand (lsh (random) math-random-shift) 1023)))
(setq math-random-table nil)
(setq math-last-RandSeed nil)
(setq math-random-ptr1 nil)
@ -586,8 +545,7 @@
math-random-last (aref math-random-cache i))
(aset math-random-cache i (math-random-base))
(>= math-random-last 1000)))
math-random-last)
)
math-random-last))
(setq math-random-cache nil)
;;; Produce an N-digit random integer.
@ -602,14 +560,12 @@
(setq digs (cons (math-random-digit) digs)
i (1- i)))
(math-normalize (math-scale-right (cons 'bigpos digs)
slop)))))
)
slop))))))
;;; Produce a uniformly-distributed random float 0 <= N < 1.
(defun math-random-float ()
(math-make-float (math-random-digits calc-internal-prec)
(- calc-internal-prec))
)
(- calc-internal-prec)))
;;; Produce a Gaussian-distributed random float with mean=0, sigma=1.
(defun math-gaussian-float ()
@ -629,8 +585,7 @@
(let ((fac (math-sqrt (math-mul (math-div (calcFunc-ln r) r) -2))))
(setq math-gaussian-cache (cons calc-internal-prec
(math-mul v1 fac)))
(math-mul v2 fac)))))
)
(math-mul v2 fac))))))
(setq math-gaussian-cache nil)
;;; Produce a random integer or real 0 <= N < MAX.
@ -668,8 +623,7 @@
(math-reject-arg max "*Empty list")))
((and (eq (car max) 'sdev) (math-constp max) (Math-realp (nth 1 max)))
(math-add (math-mul (math-gaussian-float) (nth 2 max)) (nth 1 max)))
(t (math-reject-arg max 'realp)))
)
(t (math-reject-arg max 'realp))))
;;; Choose N objects at random from the set MAX without duplicates.
(defun calcFunc-shuffle (n &optional max)
@ -724,8 +678,7 @@
(if (math-posp max)
(calcFunc-shuffle n (list 'intv 2 0 max))
(calcFunc-shuffle n (list 'intv 1 max 0))))
(t (math-reject-arg max 'realp)))
)
(t (math-reject-arg max 'realp))))
(defun math-simple-shuffle (n max)
(let ((vec nil)
@ -733,8 +686,7 @@
(while (>= (setq n (1- n)) 0)
(while (math-member (setq val (calcFunc-random max)) vec))
(setq vec (cons val vec)))
(cons 'vec vec))
)
(cons 'vec vec)))
(defun math-shuffle-list (n size vec)
(let ((j size)
@ -746,14 +698,12 @@
temp (nth k p))
(setcar (nthcdr k p) (car p))
(setcar p temp))
(cons 'vec (nthcdr (- size n -1) vec)))
)
(cons 'vec (nthcdr (- size n -1) vec))))
(defun math-member (x list)
(while (and list (not (equal x (car list))))
(setq list (cdr list)))
list
)
list)
;;; Check if the integer N is prime. [X I]
@ -845,8 +795,7 @@
iters (if (eq (car res) 'maybe)
(1- iters)
0)))
res)
)
res))
(defvar math-prime-test-cache '(-1))
(defun calcFunc-prime (n &optional iters)
@ -854,8 +803,7 @@
(or (not iters) (math-num-integerp iters) (math-reject-arg iters 'integerp))
(if (car (math-prime-test (math-trunc n) (math-trunc (or iters 1))))
1
0)
)
0))
;;; Theory: summing base-10^6 digits modulo 111111 is "casting out 999999s".
;;; Initial probability that N is prime is 1/ln(N) = log10(e)/log10(N).
@ -897,8 +845,7 @@
(list 'vec n)
(cons 'vec (cons -1 (cdr (calcFunc-prfac (math-neg n))))))
(calc-record-why 'integerp n)
(list 'calcFunc-prfac n)))
)
(list 'calcFunc-prfac n))))
(defun calcFunc-totient (n)
(if (Math-messy-integerp n)
@ -921,8 +868,7 @@
(calc-record-why "*Number too big to factor" n)
(list 'calcFunc-totient n))))
(calc-record-why 'natnump n)
(list 'calcFunc-totient n))
)
(list 'calcFunc-totient n)))
(defun calcFunc-moebius (n)
(if (Math-messy-integerp n)
@ -944,8 +890,7 @@
(calc-record-why "Number too big to factor" n)
(list 'calcFunc-moebius n))))
(calc-record-why 'posintp n)
(list 'calcFunc-moebius n))
)
(list 'calcFunc-moebius n)))
(defun calcFunc-nextprime (n &optional iters)
@ -966,8 +911,7 @@
n))
(if (Math-realp n)
(calcFunc-nextprime (math-trunc n) iters)
(math-reject-arg n 'integerp)))
)
(math-reject-arg n 'integerp))))
(setq calc-verbose-nextprime nil)
(defun calcFunc-prevprime (n &optional iters)
@ -986,8 +930,7 @@
n)
(if (Math-realp n)
(calcFunc-prevprime (math-ceiling n) iters)
(math-reject-arg n 'integerp)))
)
(math-reject-arg n 'integerp))))
(defun math-next-small-prime (n)
(if (and (integerp n) (> n 2))
@ -1000,8 +943,7 @@
(setq lo mid)
(setq hi mid)))
(aref math-primes-table hi))
2)
)
2))
(defconst math-primes-table
[2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89
@ -1052,5 +994,4 @@
4987 4993 4999 5003])
;;; calc-comb.el ends here

68
lisp/calc/calc-cplx.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-cplx.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -32,20 +32,17 @@
(defun calc-argument (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "arg" 'calcFunc-arg arg))
)
(calc-unary-op "arg" 'calcFunc-arg arg)))
(defun calc-re (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "re" 'calcFunc-re arg))
)
(calc-unary-op "re" 'calcFunc-re arg)))
(defun calc-im (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "im" 'calcFunc-im arg))
)
(calc-unary-op "im" 'calcFunc-im arg)))
(defun calc-polar ()
@ -55,8 +52,7 @@
(if (or (calc-is-inverse)
(eq (car-safe arg) 'polar))
(calc-enter-result 1 "p-r" (list 'calcFunc-rect arg))
(calc-enter-result 1 "r-p" (list 'calcFunc-polar arg)))))
)
(calc-enter-result 1 "r-p" (list 'calcFunc-polar arg))))))
@ -65,22 +61,19 @@
(interactive)
(calc-wrapper
(calc-change-mode 'calc-complex-format nil t)
(message "Displaying complex numbers in (X,Y) format."))
)
(message "Displaying complex numbers in (X,Y) format.")))
(defun calc-i-notation ()
(interactive)
(calc-wrapper
(calc-change-mode 'calc-complex-format 'i t)
(message "Displaying complex numbers in X+Yi format."))
)
(message "Displaying complex numbers in X+Yi format.")))
(defun calc-j-notation ()
(interactive)
(calc-wrapper
(calc-change-mode 'calc-complex-format 'j t)
(message "Displaying complex numbers in X+Yj format."))
)
(message "Displaying complex numbers in X+Yj format.")))
(defun calc-polar-mode (n)
@ -93,8 +86,7 @@
(calc-change-mode 'calc-complex-mode 'polar)
(message "Preferred complex form is polar."))
(calc-change-mode 'calc-complex-mode 'cplx)
(message "Preferred complex form is rectangular.")))
)
(message "Preferred complex form is rectangular."))))
;;;; Complex numbers.
@ -113,8 +105,7 @@
((math-negp r)
(math-neg (list 'polar (math-neg r) th)))
(t
(list 'polar r th))))
)
(list 'polar r th)))))
;;; Coerce A to be complex (rectangular form). [c N]
@ -127,8 +118,7 @@
(list 'cplx
(math-mul (nth 1 a) (nth 1 sc))
(math-mul (nth 1 a) (nth 2 sc))))))
(t (list 'cplx a 0)))
)
(t (list 'cplx a 0))))
;;; Coerce A to be complex (polar form). [c N]
(defun math-polar (a)
@ -137,8 +127,7 @@
(t
(list 'polar
(math-abs a)
(calcFunc-arg a))))
)
(calcFunc-arg a)))))
;;; Multiply A by the imaginary constant i. [N N] [Public]
(defun math-imaginary (a)
@ -150,8 +139,7 @@
(eq calc-complex-mode 'polar)))
(list 'polar 1 (math-quarter-circle nil))
'(cplx 0 1)))
(math-mul a '(var i var-i)))
)
(math-mul a '(var i var-i))))
@ -169,8 +157,7 @@
t)
((eq (car-safe b) 'cplx)
nil)
(t (eq calc-complex-mode 'polar)))
)
(t (eq calc-complex-mode 'polar))))
;;; Force A to be in the (-pi,pi] or (-180,180] range.
(defun math-fix-circular (a &optional dir) ; [R R]
@ -194,8 +181,7 @@
((or (Math-lessp '(float -18 1) a) (eq dir -1))
a)
(t
(math-fix-circular (math-add a '(float 36 1)) 1)))))
)
(math-fix-circular (math-add a '(float 36 1)) 1))))))
;;;; Complex numbers.
@ -206,8 +192,7 @@
((Math-realp a) a)
((Math-numberp a)
(math-normalize (math-polar a)))
(t (list 'calcFunc-polar a)))
)
(t (list 'calcFunc-polar a))))
(defun calcFunc-rect (a) ; [N N] [Public]
(cond ((Math-vectorp a)
@ -215,8 +200,7 @@
((Math-realp a) a)
((Math-numberp a)
(math-normalize (math-complex a)))
(t (list 'calcFunc-rect a)))
)
(t (list 'calcFunc-rect a))))
;;; Compute the complex conjugate of A. [O O] [Public]
(defun calcFunc-conj (a)
@ -255,8 +239,7 @@
(and inf
(math-mul (calcFunc-conj (math-infinite-dir a inf)) inf))))
(t (calc-record-why 'numberp a)
(list 'calcFunc-conj a))))
)
(list 'calcFunc-conj a)))))
;;; Compute the complex argument of A. [F N] [Public]
@ -284,8 +267,7 @@
'(var nan var-nan)
(calcFunc-arg (math-infinite-dir a))))
(t (calc-record-why 'numvecp a)
(list 'calcFunc-arg a)))
)
(list 'calcFunc-arg a))))
(defun math-imaginary-i ()
(let ((val (calc-var-value 'var-i)))
@ -293,8 +275,7 @@
(equal val '(cplx 0 1))
(and (eq (car-safe val) 'polar)
(eq (nth 1 val) 0)
(Math-equal (nth 1 val) (math-quarter-circle nil)))))
)
(Math-equal (nth 1 val) (math-quarter-circle nil))))))
;;; Extract the real or complex part of a complex number. [R N] [Public]
;;; Also extracts the real part of a modulo form.
@ -332,8 +313,7 @@
((eq (car a) 'neg)
(math-neg (calcFunc-re (nth 1 a))))
(t (calc-record-why 'numberp a)
(list 'calcFunc-re a))))
)
(list 'calcFunc-re a)))))
(defun calcFunc-im (a)
(let (aa bb)
@ -370,8 +350,6 @@
((eq (car a) 'neg)
(math-neg (calcFunc-im (nth 1 a))))
(t (calc-record-why 'numberp a)
(list 'calcFunc-im a))))
)
(list 'calcFunc-im a)))))
;;; calc-cplx.el ends here

121
lisp/calc/calc-embed.el
View File

@ -35,8 +35,7 @@
(calc-set-command-flag 'renum-stack)
(message (if (calc-change-mode 'calc-show-plain n nil t)
"Including \"plain\" formulas in Calc Embedded mode."
"Omitting \"plain\" formulas in Calc Embedded mode.")))
)
"Omitting \"plain\" formulas in Calc Embedded mode."))))
@ -251,8 +250,7 @@ This is not required to be present for user-written mode annotations.")
(if calc-embedded-quiet
"Type `M-# x'"
"Give this command again")))))
(scroll-down 0) ; fix a bug which occurs when truncate-lines is changed.
)
(scroll-down 0)) ; fix a bug which occurs when truncate-lines is changed.
(setq calc-embedded-quiet nil)
@ -267,8 +265,7 @@ This is not required to be present for user-written mode annotations.")
(and (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-evalto)
(eq (car-safe (nth 1 (aref calc-embedded-info 8)))
'calcFunc-assign)))
(calc-select-part 2))
)
(calc-select-part 2)))
(defun calc-embedded-update-formula (arg)
@ -294,8 +291,7 @@ This is not required to be present for user-written mode annotations.")
(progn
(save-excursion
(calc-embedded-update info 14 'eval t))
(goto-char (+ (aref info 4) pt)))))))
)
(goto-char (+ (aref info 4) pt))))))))
(defun calc-embedded-edit (arg)
@ -311,8 +307,7 @@ This is not required to be present for user-written mode annotations.")
(math-format-nice-expr (aref info 8) (frame-width))))
(calc-edit-mode (list 'calc-embedded-finish-edit info))
(insert str "\n")))
(calc-show-edit-buffer)
)
(calc-show-edit-buffer))
(defun calc-embedded-finish-edit (info)
(let ((buf (current-buffer))
@ -332,8 +327,7 @@ This is not required to be present for user-written mode annotations.")
(error (nth 2 val))))
(calc-embedded-original-buffer t info)
(aset info 8 val)
(calc-embedded-update info 14 t t)))
)
(calc-embedded-update info 14 t t))))
(defun calc-do-embedded-activate (arg cbuf)
(calc-plain-buffer-only)
@ -362,13 +356,11 @@ This is not required to be present for user-written mode annotations.")
(or (eq (car-safe (aref info 8)) 'error)
(goto-char (aref info 5))))))
(message "Activating %s for Calc Embedded mode...done" (buffer-name)))
(calc-embedded-active-state t)
)
(calc-embedded-active-state t))
(defun calc-plain-buffer-only ()
(if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode))
(error "This command should be used in a normal editing buffer"))
)
(error "This command should be used in a normal editing buffer")))
(defun calc-embedded-active-state (state)
(or (assq 'calc-embedded-all-active minor-mode-alist)
@ -382,8 +374,7 @@ This is not required to be present for user-written mode annotations.")
(and (eq state 'more) calc-embedded-all-active (setq state t))
(setq calc-embedded-all-active (eq state t)
calc-embedded-some-active (not (memq state '(nil t))))
(set-buffer-modified-p (buffer-modified-p))
)
(set-buffer-modified-p (buffer-modified-p)))
(defun calc-embedded-original-buffer (switch &optional info)
@ -392,13 +383,11 @@ This is not required to be present for user-written mode annotations.")
(progn
(error "Calc embedded mode: Original buffer has been killed")))
(if switch
(set-buffer (aref info 0)))
)
(set-buffer (aref info 0))))
(defun calc-embedded-word ()
(interactive)
(calc-embedded '(4))
)
(calc-embedded '(4)))
(defun calc-embedded-mark-formula (&optional body-only)
"Put point at the beginning of this Calc formula, mark at the end.
@ -411,8 +400,7 @@ With any prefix argument, marks only the formula itself."
(save-excursion
(calc-embedded-find-bounds body-only))
(push-mark (if body-only bot outer-bot) t)
(goto-char (if body-only top outer-top)))
)
(goto-char (if body-only top outer-top))))
(defun calc-embedded-find-bounds (&optional plain)
;; (while (and (bolp) (eq (following-char) ?\n))
@ -453,8 +441,7 @@ With any prefix argument, marks only the formula itself."
(or (eolp)
(while (eq (preceding-char) ?\ )
(backward-char 1)))
(setq bot (point)))
)
(setq bot (point))))
(defun calc-embedded-kill-formula ()
"Kill the formula surrounding point.
@ -466,8 +453,7 @@ The command \\[yank] can retrieve it from there."
(calc-embedded nil))
(calc-embedded-mark-formula)
(kill-region (point) (mark))
(pop-mark)
)
(pop-mark))
(defun calc-embedded-copy-formula-as-kill ()
"Save the formula surrounding point as if killed, but don't kill it."
@ -475,8 +461,7 @@ The command \\[yank] can retrieve it from there."
(save-excursion
(calc-embedded-mark-formula)
(copy-region-as-kill (point) (mark))
(pop-mark))
)
(pop-mark)))
(defun calc-embedded-duplicate ()
(interactive)
@ -499,8 +484,7 @@ The command \\[yank] can retrieve it from there."
(calc-embedded (+ new-top (- top outer-top))
(+ new-top (- bot outer-top))
new-top
(+ new-top (- outer-bot outer-top)))))
)
(+ new-top (- outer-bot outer-top))))))
(defun calc-embedded-next (arg)
(interactive "P")
@ -527,13 +511,11 @@ The command \\[yank] can retrieve it from there."
(setq p (cdr p)))
(while (> (setq arg (1- arg)) 0)
(setq p (if p (cdr p) (cdr active))))
(goto-char (aref (car (or p active)) 2)))))
)
(goto-char (aref (car (or p active)) 2))))))
(defun calc-embedded-previous (arg)
(interactive "p")
(calc-embedded-next (- (prefix-numeric-value arg)))
)
(calc-embedded-next (- (prefix-numeric-value arg))))
(defun calc-embedded-new-formula ()
(interactive)
@ -560,15 +542,13 @@ The command \\[yank] can retrieve it from there."
(setq outer-bot (point))
(goto-char top)
(let ((calc-embedded-quiet 'x))
(calc-embedded top bot outer-top outer-bot)))
)
(calc-embedded top bot outer-top outer-bot))))
(defun calc-embedded-forget ()
(interactive)
(setq calc-embedded-active (delq (assq (current-buffer) calc-embedded-active)
calc-embedded-active))
(calc-embedded-active-state nil)
)
(calc-embedded-active-state nil))
(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp)
@ -630,14 +610,12 @@ The command \\[yank] can retrieve it from there."
(car calc-float-format))
0))
(calc-refresh)))
changed)
)
changed))
(defun calc-embedded-language ()
(if calc-language-option
(list calc-language calc-language-option)
calc-language)
)
calc-language))
(defun calc-embedded-set-language (lang)
(let ((option nil))
@ -646,22 +624,19 @@ The command \\[yank] can retrieve it from there."
lang (car lang)))
(or (and (eq lang calc-language)
(equal option calc-language-option))
(calc-set-language lang option t)))
)
(calc-set-language lang option t))))
(defun calc-embedded-justify ()
(if calc-display-origin
(list calc-display-just calc-display-origin)
calc-display-just)
)
calc-display-just))
(defun calc-embedded-set-justify (just)
(if (consp just)
(setq calc-display-origin (nth 1 just)
calc-display-just (car just))
(setq calc-display-just just
calc-display-origin nil))
)
calc-display-origin nil)))
(defun calc-find-globals ()
@ -686,8 +661,7 @@ The command \\[yank] can retrieve it from there."
(match-end 2)))))
modes)))))
(setq calc-embedded-globals (cons t modes))
(goto-char save-pt))
)
(goto-char save-pt)))
(defun calc-embedded-find-modes ()
(let ((case-fold-search nil)
@ -736,8 +710,7 @@ The command \\[yank] can retrieve it from there."
(setq no-defaults nil)))
(backward-char 6))
(goto-char save-pt)
(list modes emodes pmodes))
)
(list modes emodes pmodes)))
(defun calc-embedded-make-info (point cbuf fresh &optional
@ -851,8 +824,7 @@ The command \\[yank] can retrieve it from there."
(progn
(setcdr found (cons info (cdr found)))
(calc-embedded-active-state 'more)))
info)
)
info))
(defun calc-embedded-find-vars (x)
(cond ((Math-primp x)
@ -870,8 +842,7 @@ The command \\[yank] can retrieve it from there."
(not (assoc x vars-used))
(setq vars-used (cons (list x) vars-used)))
(while (setq x (cdr x))
(calc-embedded-find-vars (car x)))))
)
(calc-embedded-find-vars (car x))))))
(defun calc-embedded-evaluate-expr (x)
@ -891,8 +862,7 @@ The command \\[yank] can retrieve it from there."
(calc-embedded-eval-get-var (car (car vars-used)) active)
(setq vars-used (cdr vars-used))))
(calc-embedded-subst x))
(calc-normalize (math-evaluate-expr-rec x))))
)
(calc-normalize (math-evaluate-expr-rec x)))))
(defun calc-embedded-subst (x)
(if (and (eq (car-safe x) 'calcFunc-evalto) (cdr x))
@ -904,8 +874,7 @@ The command \\[yank] can retrieve it from there."
(list 'calcFunc-assign
(nth 1 x)
(calc-embedded-subst (nth 2 x)))
(calc-normalize (math-evaluate-expr-rec (math-multi-subst-rec x)))))
)
(calc-normalize (math-evaluate-expr-rec (math-multi-subst-rec x))))))
(defun calc-embedded-eval-get-var (var base)
(let ((entry base)
@ -934,8 +903,7 @@ The command \\[yank] can retrieve it from there."
(setq val (nth 2 val)))
(setq args (cons (cons var val) args)))
(calc-embedded-activate)
(calc-embedded-eval-get-var var base)))))
)
(calc-embedded-eval-get-var var base))))))
(defun calc-embedded-update (info which need-eval need-display
@ -1027,8 +995,7 @@ The command \\[yank] can retrieve it from there."
(calc-embedded-set-justify (cdr (car prev-modes)))))
(t
(set (car (car prev-modes)) (cdr (car prev-modes)))))
(setq prev-modes (cdr prev-modes)))))
)
(setq prev-modes (cdr prev-modes))))))
@ -1063,8 +1030,7 @@ The command \\[yank] can retrieve it from there."
(forward-line vert))
(forward-char (min horiz
(- (point-max) (point)))))
(calc-select-buffer))
)
(calc-select-buffer)))
(setq calc-embedded-no-reselect nil)
(defun calc-embedded-finish-command ()
@ -1095,8 +1061,7 @@ The command \\[yank] can retrieve it from there."
(if (> vert 0)
(forward-line vert))
(forward-char (max horiz 0))
(set-buffer buf))))
)
(set-buffer buf)))))
(defun calc-embedded-stack-change ()
(or calc-executing-macro
@ -1128,16 +1093,14 @@ The command \\[yank] can retrieve it from there."
pos (1+ pos))))))
(calc-embedded-original-buffer t)
(aset info 8 (car entry))
(calc-embedded-update info 13 nil t str entry old-val))))
)
(calc-embedded-update info 13 nil t str entry old-val)))))
(defun calc-embedded-mode-line-change ()
(let ((str mode-line-buffer-identification))
(save-excursion
(calc-embedded-original-buffer t)
(setq mode-line-buffer-identification str)
(set-buffer-modified-p (buffer-modified-p))))
)
(set-buffer-modified-p (buffer-modified-p)))))
(defun calc-embedded-modes-change (vars)
(if (eq (car vars) 'calc-language) (setq vars '(the-language)))
@ -1203,8 +1166,7 @@ The command \\[yank] can retrieve it from there."
(prin1-to-string (car values)) "]"
calc-embedded-close-mode))))
(setq vars (cdr vars)
values (cdr values)))))))
)
values (cdr values))))))))
(defun calc-embedded-var-change (var &optional buf)
(if (symbolp var)
@ -1247,10 +1209,9 @@ The command \\[yank] can retrieve it from there."
"(Tried to recompute but formula was changed or missing.)"))))
(setq p (cdr p))))
(setq bp (if buf nil (cdr bp))))
(or first calc-embedded-quiet (message ""))))
)
(or first calc-embedded-quiet (message "")))))
;;; calc-embed.el ends here

122
lisp/calc/calc-fin.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-fin.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -38,16 +38,14 @@
(calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3)))
(if (calc-is-inverse)
(calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3)))
(calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3))))))
)
(calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))))
(defun calc-fin-npv (arg)
(interactive "p")
(calc-slow-wrapper
(if (calc-is-inverse)
(calc-vector-op "npvb" 'calcFunc-npvb (1+ arg))
(calc-vector-op "npv" 'calcFunc-npv (1+ arg))))
)
(calc-vector-op "npv" 'calcFunc-npv (1+ arg)))))
(defun calc-fin-fv ()
(interactive)
@ -56,8 +54,7 @@
(calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
(if (calc-is-inverse)
(calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3)))
(calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3))))))
)
(calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3)))))))
(defun calc-fin-pmt ()
(interactive)
@ -66,8 +63,7 @@
(calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
(if (calc-is-inverse)
(calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3)))
(calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3))))))
)
(calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3)))))))
(defun calc-fin-nper ()
(interactive)
@ -78,8 +74,7 @@
(calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
(calc-top-list-n 3)))
(calc-enter-result 3 "nper" (cons 'calcFunc-nper
(calc-top-list-n 3))))))
)
(calc-top-list-n 3)))))))
(defun calc-fin-rate ()
(interactive)
@ -92,34 +87,29 @@
(cons (if (calc-is-hyperbolic) 'calcFunc-ratel
(if (calc-is-hyperbolic) 'calcFunc-rateb
'calcFunc-rate))
(calc-top-list-n 3))))))
)
(calc-top-list-n 3)))))))
(defun calc-fin-irr (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-inverse)
(calc-vector-op "irrb" 'calcFunc-irrb arg)
(calc-vector-op "irr" 'calcFunc-irr arg)))
)
(calc-vector-op "irr" 'calcFunc-irr arg))))
(defun calc-fin-sln ()
(interactive)
(calc-slow-wrapper
(calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3))))
)
(calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3)))))
(defun calc-fin-syd ()
(interactive)
(calc-slow-wrapper
(calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4))))
)
(calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4)))))
(defun calc-fin-ddb ()
(interactive)
(calc-slow-wrapper
(calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4))))
)
(calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4)))))
(defun calc-to-percentage (x)
@ -130,24 +120,18 @@
(list 'calcFunc-percent x))
((Math-vectorp x)
(cons 'vec (mapcar 'calc-to-percentage (cdr x))))
(t x))
)
(t x)))
(defun calc-convert-percent ()
(interactive)
(calc-slow-wrapper
(calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1))))
)
(calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))))
(defun calc-percent-change ()
(interactive)
(calc-slow-wrapper
(let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2)))))
(calc-pop-push-record 2 "%ch" (calc-to-percentage res))))
)
(calc-pop-push-record 2 "%ch" (calc-to-percentage res)))))
;;; Financial functions.
@ -159,13 +143,11 @@
(math-add (math-mul amount
(math-div (math-sub 1 (math-div 1 p))
rate))
(math-div (or lump 0) p))))
)
(math-div (or lump 0) p)))))
(put 'calcFunc-pv 'math-expandable t)
(defun calcFunc-pvl (rate num amount)
(calcFunc-pv rate num 0 amount)
)
(calcFunc-pv rate num 0 amount))
(put 'calcFunc-pvl 'math-expandable t)
(defun calcFunc-pvb (rate num amount &optional lump)
@ -176,8 +158,7 @@
(math-div (math-mul (math-sub 1 (math-div 1 p))
(math-add 1 rate))
rate))
(math-div (or lump 0) p))))
)
(math-div (or lump 0) p)))))
(put 'calcFunc-pvb 'math-expandable t)
(defun calcFunc-npv (rate &rest flows)
@ -190,8 +171,7 @@
(while (setq flat (cdr flat))
(setq accum (math-add accum (math-div (car flat) p))
p (math-mul p pp)))
accum))
)
accum)))
(put 'calcFunc-npv 'math-expandable t)
(defun calcFunc-npvb (rate &rest flows)
@ -204,8 +184,7 @@
(while (setq flat (cdr flat))
(setq accum (math-add accum (math-div (car flat) p))
p (math-mul p pp)))
accum))
)
accum)))
(put 'calcFunc-npvb 'math-expandable t)
(defun calcFunc-fv (rate num amount &optional initial)
@ -215,13 +194,11 @@
(math-add (math-mul amount
(math-div (math-sub p 1)
rate))
(math-mul (or initial 0) p))))
)
(math-mul (or initial 0) p)))))
(put 'calcFunc-fv 'math-expandable t)
(defun calcFunc-fvl (rate num amount)
(calcFunc-fv rate num 0 amount)
)
(calcFunc-fv rate num 0 amount))
(put 'calcFunc-fvl 'math-expandable t)
(defun calcFunc-fvb (rate num amount &optional initial)
@ -232,8 +209,7 @@
(math-div (math-mul (math-sub p 1)
(math-add 1 rate))
rate))
(math-mul (or initial 0) p))))
)
(math-mul (or initial 0) p)))))
(put 'calcFunc-fvb 'math-expandable t)
(defun calcFunc-pmt (rate num amount &optional lump)
@ -243,8 +219,7 @@
(math-div (math-mul (math-sub amount
(math-div (or lump 0) p))
rate)
(math-sub 1 (math-div 1 p)))))
)
(math-sub 1 (math-div 1 p))))))
(put 'calcFunc-pmt 'math-expandable t)
(defun calcFunc-pmtb (rate num amount &optional lump)
@ -253,23 +228,19 @@
(let ((p (math-pow (math-add 1 rate) num)))
(math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate)
(math-mul (math-sub 1 (math-div 1 p))
(math-add 1 rate)))))
)
(math-add 1 rate))))))
(put 'calcFunc-pmtb 'math-expandable t)
(defun calcFunc-nper (rate pmt amount &optional lump)
(math-compute-nper rate pmt amount lump nil)
)
(math-compute-nper rate pmt amount lump nil))
(put 'calcFunc-nper 'math-expandable t)
(defun calcFunc-nperb (rate pmt amount &optional lump)
(math-compute-nper rate pmt amount lump 'b)
)
(math-compute-nper rate pmt amount lump 'b))
(put 'calcFunc-nperb 'math-expandable t)
(defun calcFunc-nperl (rate pmt amount)
(math-compute-nper rate pmt amount nil 'l)
)
(math-compute-nper rate pmt amount nil 'l))
(put 'calcFunc-nperl 'math-expandable t)
(defun math-compute-nper (rate pmt amount lump bflag)
@ -315,16 +286,13 @@
pmt))))))
(if (or (math-posp temp) math-expand-formulas)
(math-neg (calcFunc-log temp (math-add 1 rate)))
(math-reject-arg pmt "*Payment too small to cover interest rate")))))
)
(math-reject-arg pmt "*Payment too small to cover interest rate"))))))
(defun calcFunc-rate (num pmt amount &optional lump)
(math-compute-rate num pmt amount lump 'calcFunc-pv)
)
(math-compute-rate num pmt amount lump 'calcFunc-pv))
(defun calcFunc-rateb (num pmt amount &optional lump)
(math-compute-rate num pmt amount lump 'calcFunc-pvb)
)
(math-compute-rate num pmt amount lump 'calcFunc-pvb))
(defun math-compute-rate (num pmt amount lump func)
(or (math-objectp num)
@ -348,8 +316,7 @@
t)))
(if (math-vectorp root)
(nth 1 root)
root))
)
root)))
(defun calcFunc-ratel (num pmt amount)
(or (math-objectp num) math-expand-formulas
@ -359,16 +326,13 @@
(or (math-objectp amount) math-expand-formulas
(math-reject-arg amount 'numberp))
(math-with-extra-prec 2
(math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1))
)
(math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)))
(defun calcFunc-irr (&rest vecs)
(math-compute-irr vecs 'calcFunc-npv)
)
(math-compute-irr vecs 'calcFunc-npv))
(defun calcFunc-irrb (&rest vecs)
(math-compute-irr vecs 'calcFunc-npvb)
)
(math-compute-irr vecs 'calcFunc-npvb))
(defun math-compute-irr (vecs func)
(let* ((flat (math-flatten-many-vecs vecs))
@ -380,8 +344,7 @@
t)))
(if (math-vectorp root)
(nth 1 root)
root))
)
root)))
(defun math-check-financial (rate num)
(or (math-objectp rate) math-expand-formulas
@ -389,8 +352,7 @@
(and (math-zerop rate)
(math-reject-arg rate 'nonzerop))
(or (math-objectp num) math-expand-formulas
(math-reject-arg num 'numberp))
)
(math-reject-arg num 'numberp)))
(defun calcFunc-sln (cost salvage life &optional period)
@ -406,8 +368,7 @@
(or (Math-lessp life period) (not (math-posp period)))
(math-reject-arg period 'integerp)))
0
(math-div (math-sub cost salvage) life))
)
(math-div (math-sub cost salvage) life)))
(put 'calcFunc-sln 'math-expandable t)
(defun calcFunc-syd (cost salvage life period)
@ -424,8 +385,7 @@
0
(math-div (math-mul (math-sub cost salvage)
(math-add (math-sub life period) 1))
(math-div (math-mul life (math-add life 1)) 2)))
)
(math-div (math-mul life (math-add life 1)) 2))))
(put 'calcFunc-syd 'math-expandable t)
(defun calcFunc-ddb (cost salvage life period)
@ -445,8 +405,6 @@
(if (Math-lessp book salvage)
(setq res (math-add res (math-sub book salvage))
book salvage)))
res))
)
res)))
;;; calc-fin.el ends here

266
lisp/calc/calc-forms.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-forms.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -39,11 +39,7 @@
(string-to-int (substring time 11 13))
(string-to-int (substring time 14 16))
(string-to-int (substring time 17 19)))
(list 'hms 24 0 0)))))
)
(list 'hms 24 0 0))))))
(defun calc-to-hms (arg)
(interactive "P")
@ -52,14 +48,12 @@
(if (eq calc-angle-mode 'rad)
(calc-unary-op ">rad" 'calcFunc-rad arg)
(calc-unary-op ">deg" 'calcFunc-deg arg))
(calc-unary-op ">hms" 'calcFunc-hms arg)))
)
(calc-unary-op ">hms" 'calcFunc-hms arg))))
(defun calc-from-hms (arg)
(interactive "P")
(calc-invert-func)
(calc-to-hms arg)
)
(calc-to-hms arg))
(defun calc-hms-notation (fmt)
@ -75,8 +69,7 @@
"%s" (math-match-substring fmt 5))
t)
(setq-default calc-hms-format calc-hms-format)) ; for minibuffer
(error "Bad hours-minutes-seconds format.")))
)
(error "Bad hours-minutes-seconds format."))))
(defun calc-date-notation (fmt arg)
(interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP")
@ -154,22 +147,19 @@
(and lfmt (if time
(setq fullfmt (cons (nreverse lfmt) fullfmt))
(setq fullfmt (nconc lfmt fullfmt))))
(calc-change-mode 'calc-date-format (nreverse fullfmt) t)))
)
(calc-change-mode 'calc-date-format (nreverse fullfmt) t))))
(defun calc-hms-mode ()
(interactive)
(calc-wrapper
(calc-change-mode 'calc-angle-mode 'hms)
(message "Angles measured in degrees-minutes-seconds."))
)
(message "Angles measured in degrees-minutes-seconds.")))
(defun calc-now (arg)
(interactive "P")
(calc-date-zero-args "now" 'calcFunc-now arg)
)
(calc-date-zero-args "now" 'calcFunc-now arg))
(defun calc-date-part (arg)
(interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ")
@ -184,31 +174,26 @@
calcFunc-minute calcFunc-second
calcFunc-weekday calcFunc-yearday
calcFunc-time))
(calc-top-n 1))))
)
(calc-top-n 1)))))
(defun calc-date (arg)
(interactive "p")
(if (or (< arg 1) (> arg 6))
(error "Between one and six arguments are allowed"))
(calc-wrapper
(calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg))))
)
(calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg)))))
(defun calc-julian (arg)
(interactive "P")
(calc-date-one-arg "juln" 'calcFunc-julian arg)
)
(calc-date-one-arg "juln" 'calcFunc-julian arg))
(defun calc-unix-time (arg)
(interactive "P")
(calc-date-one-arg "unix" 'calcFunc-unixtime arg)
)
(calc-date-one-arg "unix" 'calcFunc-unixtime arg))
(defun calc-time-zone (arg)
(interactive "P")
(calc-date-zero-args "zone" 'calcFunc-tzone arg)
)
(calc-date-zero-args "zone" 'calcFunc-tzone arg))
(defun calc-convert-time-zones (old &optional new)
(interactive "sFrom time zone: ")
@ -227,40 +212,33 @@
(if (eq (car-safe new) 'error)
(error "Error in expression: " (nth 1 new)))
(calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv
(calc-top-n 1) old new))))
)
(calc-top-n 1) old new)))))
(defun calc-new-week (arg)
(interactive "P")
(calc-date-one-arg "nwwk" 'calcFunc-newweek arg)
)
(calc-date-one-arg "nwwk" 'calcFunc-newweek arg))
(defun calc-new-month (arg)
(interactive "P")
(calc-date-one-arg "nwmn" 'calcFunc-newmonth arg)
)
(calc-date-one-arg "nwmn" 'calcFunc-newmonth arg))
(defun calc-new-year (arg)
(interactive "P")
(calc-date-one-arg "nwyr" 'calcFunc-newyear arg)
)
(calc-date-one-arg "nwyr" 'calcFunc-newyear arg))
(defun calc-inc-month (arg)
(interactive "p")
(calc-date-one-arg "incm" 'calcFunc-incmonth arg)
)
(calc-date-one-arg "incm" 'calcFunc-incmonth arg))
(defun calc-business-days-plus (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "bus+" 'calcFunc-badd arg))
)
(calc-binary-op "bus+" 'calcFunc-badd arg)))
(defun calc-business-days-minus (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "bus-" 'calcFunc-bsub arg))
)
(calc-binary-op "bus-" 'calcFunc-bsub arg)))
(defun calc-date-zero-args (prefix func arg)
(calc-wrapper
@ -268,8 +246,7 @@
(calc-enter-result 1 prefix (list func (calc-top-n 1)))
(calc-enter-result 0 prefix (if arg
(list func (prefix-numeric-value arg))
(list func)))))
)
(list func))))))
(defun calc-date-one-arg (prefix func arg)
(calc-wrapper
@ -278,14 +255,7 @@
(calc-enter-result 1 prefix (if arg
(list func (calc-top-n 1)
(prefix-numeric-value arg))
(list func (calc-top-n 1))))))
)
(list func (calc-top-n 1)))))))
;;;; Hours-minutes-seconds forms.
@ -325,8 +295,7 @@
(<= (+ (math-numdigs (nth 1 s)) (nth 2 s))
(- 2 calc-internal-prec)))
(setq s 0))
(list 'hms h m s))
)
(list 'hms h m s)))
;;; Convert A from ANG or current angular mode to HMS format.
(defun math-to-hms (a &optional ang) ; [X R] [Public]
@ -351,8 +320,7 @@
(list 'hms
(car hmd)
(cdr hmd)
(math-sub b (math-mul hm 60)))))))
)
(math-sub b (math-mul hm 60))))))))
(defun calcFunc-hms (h &optional m s)
(or (Math-realp h) (math-reject-arg h 'realp))
(or m (setq m 0))
@ -366,8 +334,7 @@
(math-to-hms (math-add h
(math-add (math-div (or m 0) 60)
(math-div (or s 0) 3600)))
'deg))
)
'deg)))
;;; Convert A from HMS format to ANG or current angular mode.
(defun math-from-hms (a &optional ang) ; [R X] [Public]
@ -389,10 +356,7 @@
'(float 6 1))
(nth 2 a))
60)
(nth 1 a))))
)
(nth 1 a)))))
;;;; Date forms.
@ -442,8 +406,7 @@
(list year month day
(/ time 3600)
(% (/ time 60) 60)
(math-add (% time 60) (nth 2 parts)))))
)
(math-add (% time 60) (nth 2 parts))))))
(defun math-dt-to-date (dt)
(or (integerp (nth 1 dt))
@ -461,8 +424,7 @@
(* (nth 4 dt) 60))
(nth 5 dt))
'(float 864 2)))
date))
)
date)))
(defun math-date-parts (value &optional offset)
(let* ((date (math-floor value))
@ -472,13 +434,11 @@
(ftime (math-floor time)))
(list date
ftime
(math-sub time ftime)))
)
(math-sub time ftime))))
(defun math-this-year ()
(string-to-int (substring (current-time-string) -4))
)
(string-to-int (substring (current-time-string) -4)))
(defun math-leap-year-p (year)
(if (Math-lessp year 1752)
@ -487,14 +447,12 @@
(= (math-imod year 4) 0))
(setq year (math-imod year 400))
(or (and (= (% year 4) 0) (/= (% year 100) 0))
(= year 0)))
)
(= year 0))))
(defun math-days-in-month (year month)
(if (and (= month 2) (math-leap-year-p year))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))
)
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
(defun math-day-number (year month day)
(let ((day-of-year (+ day (* 31 (1- month)))))
@ -507,8 +465,7 @@
(or (> month 9)
(and (= month 9) (>= day 14)))
(setq day-of-year (- day-of-year 11)))
day-of-year)
)
day-of-year))
(defun math-absolute-from-date (year month day)
(if (eq year 0) (setq year -1))
@ -528,8 +485,7 @@
(math-add (if (= (cdr res) 0)
-1
0)
(car res)))))))
)
(car res))))))))
;;; It is safe to redefine these in your .emacs file to use a different
@ -564,8 +520,7 @@
math-format-date-cache))
(and (setq dt (nthcdr 10 math-format-date-cache))
(setcdr dt nil))
fmt)))
)
fmt))))
(setq math-format-date-cache nil)
(defun math-format-date-part (x)
@ -731,8 +686,7 @@
(let ((calc-float-format
(list 'fix (min (- 12 calc-internal-prec)
0))))
(math-format-number second)))))))
)
(math-format-number second))))))))
(defun math-parse-date (str)
@ -880,8 +834,7 @@
(setq year (math-neg (math-abs year))))
(math-parse-date-validate year bigyear month day
hour minute second))))
)
hour minute second)))))
(defun math-parse-date-validate (year bigyear month day hour minute second)
(and (not bigyear) (natnump year) (< year 100)
@ -901,8 +854,7 @@
(if (or (math-negp second) (not (Math-lessp second 60)))
(throw 'syntax "Seconds value is out of range"))))
(list 'date (math-dt-to-date (append (list year month day)
(and hour (list hour minute second)))))
)
(and hour (list hour minute second))))))
(defun math-parse-date-word (names &optional front)
(let ((n 1))
@ -918,8 +870,7 @@
(setq str (concat (substring str 0 (match-beginning 0))
(if front "" " ")
(substring str (match-end 0))))
n)))
)
n))))
(defun math-parse-standard-date (str with-time)
(let ((case-fold-search t)
@ -1077,8 +1028,7 @@
hour minute second))
(if yearday
(setq day (math-add day (1- yearday))))
day))))
)
day)))))
(defun calcFunc-now (&optional zone)
@ -1091,58 +1041,48 @@
'(float 864 2)))
date)
(calc-record-why "*Unable to interpret current date from system")
(append (list 'calcFunc-now) (and zone (list zone)))))
)
(append (list 'calcFunc-now) (and zone (list zone))))))
(defun calcFunc-year (date)
(car (math-date-to-dt date))
)
(car (math-date-to-dt date)))
(defun calcFunc-month (date)
(nth 1 (math-date-to-dt date))
)
(nth 1 (math-date-to-dt date)))
(defun calcFunc-day (date)
(nth 2 (math-date-to-dt date))
)
(nth 2 (math-date-to-dt date)))
(defun calcFunc-weekday (date)
(if (eq (car-safe date) 'date)
(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-add (math-floor date) 6) 7))
(defun calcFunc-yearday (date)
(let ((dt (math-date-to-dt date)))
(math-day-number (car dt) (nth 1 dt) (nth 2 dt)))
)
(math-day-number (car dt) (nth 1 dt) (nth 2 dt))))
(defun calcFunc-hour (date)
(if (eq (car-safe date) 'hms)
(nth 1 date)
(or (nth 3 (math-date-to-dt date)) 0))
)
(or (nth 3 (math-date-to-dt date)) 0)))
(defun calcFunc-minute (date)
(if (eq (car-safe date) 'hms)
(nth 2 date)
(or (nth 4 (math-date-to-dt date)) 0))
)
(or (nth 4 (math-date-to-dt date)) 0)))
(defun calcFunc-second (date)
(if (eq (car-safe date) 'hms)
(nth 3 date)
(or (nth 5 (math-date-to-dt date)) 0))
)
(or (nth 5 (math-date-to-dt date)) 0)))
(defun calcFunc-time (date)
(let ((dt (math-date-to-dt date)))
(if (nth 3 dt)
(cons 'hms (nthcdr 3 dt))
(list 'hms 0 0 0)))
)
(list 'hms 0 0 0))))
(defun calcFunc-date (date &optional month day hour minute second)
(and (math-messy-integerp month) (setq month (math-trunc month)))
@ -1174,8 +1114,7 @@
(list 'date date)
(if (eq (car date) 'date)
(nth 1 date)
(math-reject-arg date 'datep))))
)
(math-reject-arg date 'datep)))))
(defun calcFunc-julian (date &optional zone)
(if (math-realp date)
@ -1190,8 +1129,7 @@
(math-add '(float (bigpos 235 214 17) -1)
(math-div (calcFunc-tzone zone date)
'(float 864 2)))))
(math-reject-arg date 'datep)))
)
(math-reject-arg date 'datep))))
(defun calcFunc-unixtime (date &optional zone)
(if (math-realp date)
@ -1202,8 +1140,7 @@
(if (eq (car date) 'date)
(math-add (nth 1 (math-date-parts (nth 1 date) 719164))
(calcFunc-tzone zone date))
(math-reject-arg date 'datep)))
)
(math-reject-arg date 'datep))))
(defun calcFunc-tzone (&optional zone date)
(if zone
@ -1281,8 +1218,7 @@
(kill-buffer " *Calc Temporary*")
(setq var-TimeZone tz)
(calc-refresh-evaltos 'var-TimeZone)
(calcFunc-tzone tz date))))
)
(calcFunc-tzone tz date)))))
;;; Note: Longer names must appear before shorter names which are
;;; substrings of them.
@ -1319,8 +1255,7 @@
(setq date (math-float date))
(or dt (setq dt (math-date-to-dt date)))
(and math-daylight-savings-hook
(funcall math-daylight-savings-hook date dt zone bump)))
)
(funcall math-daylight-savings-hook date dt zone bump))))
(defun calcFunc-dsadj (date &optional zone)
(if zone
@ -1336,14 +1271,12 @@
(or zadj (math-reject-arg zone "*Unrecognized time zone name"))
(if (integerp (nth 2 zadj))
(nth 2 zadj)
(math-daylight-savings-adjust date zone)))
)
(math-daylight-savings-adjust date zone))))
(defun calcFunc-tzconv (date z1 z2)
(if (math-realp date)
(nth 1 (calcFunc-tzconv (list 'date date) z1 z2))
(calcFunc-unixtime (calcFunc-unixtime date z1) z2))
)
(calcFunc-unixtime (calcFunc-unixtime date z1) z2)))
(defvar math-daylight-savings-hook 'math-std-daylight-savings)
@ -1366,8 +1299,7 @@ and ends on the last Sunday of October at 2 a.m."
((= (nth 2 dt) sunday)
(if (>= (nth 3 dt) (+ 2 bump)) 0 -1))
(t 0))))
(t 0))
)
(t 0)))
;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given
;;; day of the given month.
@ -1376,8 +1308,7 @@ and ends on the last Sunday of October at 2 a.m."
(if (> day (math-days-in-month (car dt) (nth 1 dt)))
(setq day (math-days-in-month (car dt) (nth 1 dt))))
(let ((zeroth (math-sub (math-floor date) (nth 2 dt))))
(math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth))
)
(math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth)))
(defun calcFunc-pwday (date &optional day weekday)
(if (eq (car-safe date) 'date)
@ -1388,8 +1319,7 @@ and ends on the last Sunday of October at 2 a.m."
(or (integerp day) (math-reject-arg day 'fixnump))
(if (= day 0) (setq day 31))
(and (or (< day 7) (> day 31)) (math-reject-arg day 'range))
(math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0))
)
(math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0)))
(defun calcFunc-newweek (date &optional weekday)
@ -1402,8 +1332,7 @@ and ends on the last Sunday of October at 2 a.m."
(or (integerp weekday) (math-reject-arg weekday 'fixnump))
(and (or (< weekday 0) (> weekday 6)) (math-reject-arg weekday 'range))
(setq date (math-floor date))
(list 'date (math-sub date (calcFunc-weekday (math-sub date weekday))))
)
(list 'date (math-sub date (calcFunc-weekday (math-sub date weekday)))))
(defun calcFunc-newmonth (date &optional day)
(or day (setq day 1))
@ -1416,8 +1345,7 @@ and ends on the last Sunday of October at 2 a.m."
(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))))
)
(1- day)))))
(defun calcFunc-newyear (date &optional day)
(or day (setq day 1))
@ -1432,8 +1360,7 @@ and ends on the last Sunday of October at 2 a.m."
(1- day))))
(if (and (>= day -12) (<= day -1))
(list 'date (math-dt-to-date (list (car dt) (- day) 1)))
(math-reject-arg day 'range))))
)
(math-reject-arg day 'range)))))
(defun calcFunc-incmonth (date &optional step)
(or step (setq step 1))
@ -1452,12 +1379,10 @@ and ends on the last Sunday of October at 2 a.m."
(and (math-negp (car dt)) (not (math-negp year))
(setq year (math-add year 1)))
(list 'date (math-dt-to-date
(cons year (cons month (cons day (cdr (cdr (cdr dt)))))))))
)
(cons year (cons month (cons day (cdr (cdr (cdr dt))))))))))
(defun calcFunc-incyear (date &optional step)
(calcFunc-incmonth date (math-mul (or step 1) 12))
)
(calcFunc-incmonth date (math-mul (or step 1) 12)))
@ -1472,8 +1397,7 @@ and ends on the last Sunday of October at 2 a.m."
(db (math-to-business-day b)))
(math-add (math-sub (car da) (car db))
(if (and (cdr db) (not (cdr da))) 1 0))))
(calcFunc-badd a (math-neg b)))
)
(calcFunc-badd a (math-neg b))))
(defun calcFunc-badd (a b)
(if (eq (car-safe b) 'date)
@ -1497,12 +1421,10 @@ and ends on the last Sunday of October at 2 a.m."
(setq b (math-div b (cdr hours))))
(calcFunc-badd a b))
(math-reject-arg nil "*Illegal combination in date arithmetic")))
(math-reject-arg a 'datep)))
)
(math-reject-arg a 'datep))))
(defun calcFunc-holiday (a)
(if (cdr (math-to-business-day a)) 1 0)
)
(if (cdr (math-to-business-day a)) 1 0))
(setq math-holidays-cache nil)
@ -1547,8 +1469,7 @@ and ends on the last Sunday of October at 2 a.m."
(setq time
(math-sub 1
(math-div 1 (math-mul 86400 (cdr hours)))))))))
(cons (math-add (math-sub day delta) time) holiday))
)
(cons (math-add (math-sub day delta) time) holiday)))
;;; Compute the date a certain number of business days since Jan 1, 1 AD.
@ -1579,8 +1500,7 @@ and ends on the last Sunday of October at 2 a.m."
(if hours
(setq time (math-add (math-mul time (cdr hours)) (car hours)))))
(and (not (math-setup-holidays day))
(list 'date (math-add day time)))))
)
(list 'date (math-add day time))))))
(defun math-setup-holidays (&optional date)
@ -1686,8 +1606,7 @@ and ends on the last Sunday of October at 2 a.m."
(t
(setq done t)
nil)))
(or done (setq math-holidays-cache-tag t)))))
)
(or done (setq math-holidays-cache-tag t))))))
(defun math-setup-year-holidays (year)
(let ((exprs (nth 2 math-holidays-cache)))
@ -1700,8 +1619,7 @@ and ends on the last Sunday of October at 2 a.m."
(while (<= (setq var-m (1+ var-m)) 12)
(math-setup-add-holidays (math-evaluate-expr expr))))
(math-setup-add-holidays expr)))
(setq exprs (cdr exprs))))
)
(setq exprs (cdr exprs)))))
(defun math-setup-add-holidays (days) ; uses "year"
(cond ((eq (car-safe days) 'vec)
@ -1731,8 +1649,7 @@ and ends on the last Sunday of October at 2 a.m."
((Math-realp days)
(math-reject-arg (list 'date days) "*Invalid holiday value"))
(t
(math-reject-arg days "*Holiday formula failed to evaluate")))
)
(math-reject-arg days "*Holiday formula failed to evaluate"))))
@ -1749,11 +1666,9 @@ and ends on the last Sunday of October at 2 a.m."
(setq sigma (math-abs sigma)))
(if (and (Math-zerop sigma) (Math-scalarp x))
x
(list 'sdev x sigma))
)
(list 'sdev x sigma)))
(defun calcFunc-sdev (x sigma)
(math-make-sdev x sigma)
)
(math-make-sdev x sigma))
@ -1764,8 +1679,7 @@ and ends on the last Sunday of October at 2 a.m."
(m (math-normalize (nth 2 a))))
(if (and (math-anglep n) (math-anglep m) (math-posp m))
(math-make-mod n m)
(math-normalize (list 'calcFunc-makemod n m))))
)
(math-normalize (list 'calcFunc-makemod n m)))))
;;; Build a modulo form. [N R R]
(defun math-make-mod (n m)
@ -1789,11 +1703,9 @@ and ends on the last Sunday of October at 2 a.m."
(math-mul (math-make-mod (nth 1 n) m) (nth 2 n)))
((memq (car n) '(* ^ var calcFunc-subscr))
(math-mul (math-make-mod 1 m) n))
(t (math-reject-arg n 'anglep))))
)
(t (math-reject-arg n 'anglep)))))
(defun calcFunc-makemod (n m)
(math-make-mod n m)
)
(math-make-mod n m))
@ -1819,20 +1731,17 @@ and ends on the last Sunday of October at 2 a.m."
(list 'intv 2 lo lo)
(list 'intv mask lo lo))
(list 'intv mask lo hi))))
(list 'intv mask lo hi))
)
(list 'intv mask lo hi)))
(defun calcFunc-intv (mask lo hi)
(if (math-messy-integerp mask) (setq mask (math-trunc mask)))
(or (natnump mask) (math-reject-arg mask 'fixnatnump))
(or (<= mask 3) (math-reject-arg mask 'range))
(math-make-intv mask lo hi)
)
(math-make-intv mask lo hi))
(defun math-sort-intv (mask lo hi)
(if (Math-lessp hi lo)
(math-make-intv (aref [0 2 1 3] mask) hi lo)
(math-make-intv mask lo hi))
)
(math-make-intv mask lo hi)))
@ -1847,8 +1756,7 @@ and ends on the last Sunday of October at 2 a.m."
(setq b d bm dm)
(if (= res 0)
(setq bm (or bm dm))))
(math-make-intv (+ (if am 2 0) (if bm 1 0)) a b))
)
(math-make-intv (+ (if am 2 0) (if bm 1 0)) a b)))
(defun math-div-mod (a b m) ; [R R R R] (Returns nil if no solution)
@ -1860,8 +1768,7 @@ and ends on the last Sunday of October at 2 a.m."
(setq u1 v1 u3 v3 v1 t1 v3 (cdr q))))
(let ((q (math-idivmod a u3)))
(and (eq (cdr q) 0)
(math-mod (math-mul (car q) u1) m)))))
)
(math-mod (math-mul (car q) u1) m))))))
(defun math-mod-intv (a b)
(let* ((q1 (math-floor (math-div (nth 2 a) b)))
@ -1875,8 +1782,7 @@ and ends on the last Sunday of October at 2 a.m."
(memq (nth 1 a) '(0 2)))
(math-make-intv (nth 1 a) m1 b))
(t
(math-make-intv 2 0 b))))
)
(math-make-intv 2 0 b)))))
(defun math-read-angle-brackets ()
@ -1909,6 +1815,6 @@ and ends on the last Sunday of October at 2 a.m."
(throw 'syntax (nth 2 res)))
(setq exp-pos (1+ last))
(math-read-token)
res)
)
res))
;;; calc-forms.el ends here

42
lisp/calc/calc-frac.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-frac.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -32,8 +32,7 @@
(defun calc-fdiv (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op ":" 'calcFunc-fdiv arg 1))
)
(calc-binary-op ":" 'calcFunc-fdiv arg 1)))
(defun calc-fraction (arg)
@ -46,8 +45,7 @@
(calc-top-n 1)))
(calc-enter-result 1 "frac" (list func
(calc-top-n 1)
(prefix-numeric-value (or arg 0)))))))
)
(prefix-numeric-value (or arg 0))))))))
(defun calc-over-notation (fmt)
@ -60,14 +58,12 @@
fmt (math-match-substring fmt 1)))
(if (eq n 0) (error "Bad denominator"))
(calc-change-mode 'calc-frac-format (list fmt n) t))
(error "Bad fraction separator format.")))
)
(error "Bad fraction separator format."))))
(defun calc-slash-notation (n)
(interactive "P")
(calc-wrapper
(calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t))
)
(calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t)))
(defun calc-frac-mode (n)
@ -76,8 +72,7 @@
(calc-change-mode 'calc-prefer-frac n nil t)
(message (if calc-prefer-frac
"Integer division will now generate fractions."
"Integer division will now generate floating-point results.")))
)
"Integer division will now generate floating-point results."))))
@ -99,8 +94,7 @@
(list 'frac num den))
(if (equal gcd den)
(math-quotient num gcd)
(list 'frac (math-quotient num gcd) (math-quotient den gcd)))))
)
(list 'frac (math-quotient num gcd) (math-quotient den gcd))))))
(defun calc-add-fractions (a b)
(if (eq (car-safe a) 'frac)
@ -113,8 +107,7 @@
(nth 2 a)))
(math-make-frac (math-add (math-mul a (nth 2 b))
(nth 1 b))
(nth 2 b)))
)
(nth 2 b))))
(defun calc-mul-fractions (a b)
(if (eq (car-safe a) 'frac)
@ -124,8 +117,7 @@
(math-make-frac (math-mul (nth 1 a) b)
(nth 2 a)))
(math-make-frac (math-mul a (nth 1 b))
(nth 2 b)))
)
(nth 2 b))))
(defun calc-div-fractions (a b)
(if (eq (car-safe a) 'frac)
@ -135,8 +127,7 @@
(math-make-frac (nth 1 a)
(math-mul (nth 2 a) b)))
(math-make-frac (math-mul a (nth 2 b))
(nth 1 b)))
)
(nth 1 b))))
@ -183,8 +174,7 @@
(t
(let ((cfrac (math-continued-fraction a tol))
(calc-prefer-frac t))
(math-eval-continued-fraction cfrac))))
)
(math-eval-continued-fraction cfrac)))))
(defun math-continued-fraction (a tol)
(let ((calc-internal-prec (+ calc-internal-prec 2)))
@ -207,8 +197,7 @@
cfrac (cons int cfrac))
(or (Math-zerop aa)
(setq aa (math-div 1 aa))))
cfrac))
)
cfrac)))
(defun math-eval-continued-fraction (cf)
(let ((n (car cf))
@ -218,8 +207,7 @@
(setq temp (math-add (math-mul (car cf) n) d)
d n
n temp))
(math-div n d))
)
(math-div n d)))
@ -230,6 +218,6 @@
(math-reject-arg a "*Division by zero")
(math-make-frac (math-trunc a) (math-trunc b)))
(math-reject-arg b 'integerp))
(math-reject-arg a 'integerp))
)
(math-reject-arg a 'integerp)))
;;; calc-frac.el ends here

188
lisp/calc/calc-funcs.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-funcs.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -38,102 +38,86 @@
(calc-binary-op "gamQ" 'calcFunc-gammaQ arg))
(if (calc-is-hyperbolic)
(calc-binary-op "gamg" 'calcFunc-gammag arg)
(calc-binary-op "gamP" 'calcFunc-gammaP arg))))
)
(calc-binary-op "gamP" 'calcFunc-gammaP arg)))))
(defun calc-erf (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-inverse)
(calc-unary-op "erfc" 'calcFunc-erfc arg)
(calc-unary-op "erf" 'calcFunc-erf arg)))
)
(calc-unary-op "erf" 'calcFunc-erf arg))))
(defun calc-erfc (arg)
(interactive "P")
(calc-invert-func)
(calc-erf arg)
)
(calc-erf arg))
(defun calc-beta (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op "beta" 'calcFunc-beta arg))
)
(calc-binary-op "beta" 'calcFunc-beta arg)))
(defun calc-inc-beta ()
(interactive)
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-enter-result 3 "betB" (cons 'calcFunc-betaB (calc-top-list-n 3)))
(calc-enter-result 3 "betI" (cons 'calcFunc-betaI (calc-top-list-n 3)))))
)
(calc-enter-result 3 "betI" (cons 'calcFunc-betaI (calc-top-list-n 3))))))
(defun calc-bessel-J (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op "besJ" 'calcFunc-besJ arg))
)
(calc-binary-op "besJ" 'calcFunc-besJ arg)))
(defun calc-bessel-Y (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op "besY" 'calcFunc-besY arg))
)
(calc-binary-op "besY" 'calcFunc-besY arg)))
(defun calc-bernoulli-number (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-binary-op "bern" 'calcFunc-bern arg)
(calc-unary-op "bern" 'calcFunc-bern arg)))
)
(calc-unary-op "bern" 'calcFunc-bern arg))))
(defun calc-euler-number (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-binary-op "eulr" 'calcFunc-euler arg)
(calc-unary-op "eulr" 'calcFunc-euler arg)))
)
(calc-unary-op "eulr" 'calcFunc-euler arg))))
(defun calc-stirling-number (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-binary-op "str2" 'calcFunc-stir2 arg)
(calc-binary-op "str1" 'calcFunc-stir1 arg)))
)
(calc-binary-op "str1" 'calcFunc-stir1 arg))))
(defun calc-utpb ()
(interactive)
(calc-prob-dist "b" 3)
)
(calc-prob-dist "b" 3))
(defun calc-utpc ()
(interactive)
(calc-prob-dist "c" 2)
)
(calc-prob-dist "c" 2))
(defun calc-utpf ()
(interactive)
(calc-prob-dist "f" 3)
)
(calc-prob-dist "f" 3))
(defun calc-utpn ()
(interactive)
(calc-prob-dist "n" 3)
)
(calc-prob-dist "n" 3))
(defun calc-utpp ()
(interactive)
(calc-prob-dist "p" 2)
)
(calc-prob-dist "p" 2))
(defun calc-utpt ()
(interactive)
(calc-prob-dist "t" 2)
)
(calc-prob-dist "t" 2))
(defun calc-prob-dist (letter nargs)
(calc-slow-wrapper
@ -145,8 +129,7 @@
(calc-enter-result nargs (concat "utp" letter)
(append (list (intern (concat "calcFunc-utp" letter))
(calc-top-n 1))
(calc-top-list-n (1- nargs) 2)))))
)
(calc-top-list-n (1- nargs) 2))))))
@ -159,8 +142,7 @@
(defun calcFunc-gamma (x)
(or (math-numberp x) (math-reject-arg x 'numberp))
(calcFunc-fact (math-add x -1))
)
(calcFunc-fact (math-add x -1)))
(defun math-gammap1-raw (x &optional fprec nfprec) ; compute gamma(1 + x)
(or fprec
@ -193,8 +175,7 @@
xinv
(math-sqr xinv)
'(float 0 0)
2))))))
)
2)))))))
(defun math-gamma-series (sum x xinvsqr oterm n)
(math-working "gamma" sum)
@ -212,8 +193,7 @@
(calc-record-why
"*Gamma computation stopped early, not all digits may be valid")
next)
(math-gamma-series next (math-mul x xinvsqr) xinvsqr term (+ n 2)))))
)
(math-gamma-series next (math-mul x xinvsqr) xinvsqr term (+ n 2))))))
;;; Incomplete gamma function.
@ -229,8 +209,7 @@
(> a 0) (< a 20))
(math-sub 1 (calcFunc-gammaQ a x))
(let ((math-current-gamma-value (calcFunc-gamma a)))
(math-div (calcFunc-gammag a x) math-current-gamma-value))))
)
(math-div (calcFunc-gammag a x) math-current-gamma-value)))))
(defun calcFunc-gammaQ (a x)
(if (equal x '(var inf var-inf))
@ -251,8 +230,7 @@
(math-working "gamma" sum))
(math-mul sum (calcFunc-exp (math-neg x)))))
(let ((math-current-gamma-value (calcFunc-gamma a)))
(math-div (calcFunc-gammaG a x) math-current-gamma-value))))
)
(math-div (calcFunc-gammaG a x) math-current-gamma-value)))))
(defun calcFunc-gammag (a x)
(if (equal x '(var inf var-inf))
@ -269,8 +247,7 @@
'(float 1 0))))
(math-inc-gamma-series a x)
(math-sub (or math-current-gamma-value (calcFunc-gamma a))
(math-inc-gamma-cfrac a x)))))
)
(math-inc-gamma-cfrac a x))))))
(setq math-current-gamma-value nil)
(defun calcFunc-gammaG (a x)
@ -288,8 +265,7 @@
'(float 1 0))))
(math-sub (or math-current-gamma-value (calcFunc-gamma a))
(math-inc-gamma-series a x))
(math-inc-gamma-cfrac a x))))
)
(math-inc-gamma-cfrac a x)))))
(defun math-inc-gamma-series (a x)
(if (Math-zerop x)
@ -297,8 +273,7 @@
(math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x))
(math-with-extra-prec 2
(let ((start (math-div '(float 1 0) a)))
(math-inc-gamma-series-step start start a x)))))
)
(math-inc-gamma-series-step start start a x))))))
(defun math-inc-gamma-series-step (sum term a x)
(math-working "gamma" sum)
@ -307,8 +282,7 @@
(let ((next (math-add sum term)))
(if (math-nearly-equal sum next)
next
(math-inc-gamma-series-step next term a x)))
)
(math-inc-gamma-series-step next term a x))))
(defun math-inc-gamma-cfrac (a x)
(if (Math-zerop x)
@ -317,8 +291,7 @@
(math-inc-gamma-cfrac-step '(float 1 0) x
'(float 0 0) '(float 1 0)
'(float 1 0) '(float 1 0) '(float 0 0)
a x)))
)
a x))))
(defun math-inc-gamma-cfrac-step (a0 a1 b0 b1 n fac g a x)
(let ((ana (math-sub n a))
@ -335,8 +308,7 @@
(math-working "gamma" next)
(if (math-nearly-equal next g)
next
(math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac next a x)))))
)
(math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac next a x))))))
;;; Error function.
@ -353,8 +325,7 @@
(math-div (calcFunc-gammag '(float 5 -1)
(math-sqr (math-to-complex-quad-one x)))
math-current-gamma-value)
x)))))
)
x))))))
(defun calcFunc-erfc (x)
(if (equal x '(var inf var-inf))
@ -363,15 +334,13 @@
(let ((math-current-gamma-value (math-sqrt-pi)))
(math-div (calcFunc-gammaG '(float 5 -1) (math-sqr x))
math-current-gamma-value))
(math-sub 1 (calcFunc-erf x))))
)
(math-sub 1 (calcFunc-erf x)))))
(defun math-to-complex-quad-one (x)
(if (eq (car-safe x) 'polar) (setq x (math-complex x)))
(if (eq (car-safe x) 'cplx)
(list 'cplx (math-abs (nth 1 x)) (math-abs (nth 2 x)))
x)
)
x))
(defun math-to-same-complex-quad (x y)
(if (eq (car-safe y) 'cplx)
@ -384,8 +353,7 @@
(if (eq (car-safe x) 'cplx)
(list 'cplx (math-neg (nth 1 x)) (nth 2 x))
(math-neg x))
x))
)
x)))
;;; Beta function.
@ -398,8 +366,7 @@
(if (math-num-integerp b)
(calcFunc-beta b a)
(math-div (math-mul (calcFunc-gamma a) (calcFunc-gamma b))
(calcFunc-gamma (math-add a b)))))
)
(calcFunc-gamma (math-add a b))))))
;;; Incomplete beta function.
@ -425,8 +392,7 @@
((not (math-numberp b)) (math-reject-arg b 'numberp))
((math-inexact-result))
(t (let ((math-current-beta-value (calcFunc-beta a b)))
(math-div (calcFunc-betaB x a b) math-current-beta-value))))
)
(math-div (calcFunc-betaB x a b) math-current-beta-value)))))
(defun calcFunc-betaB (x a b)
(cond
@ -478,8 +444,7 @@
(math-sub (or math-current-beta-value (calcFunc-beta a b))
(math-div (math-mul bt
(math-beta-cfrac b a (math-sub 1 x)))
b)))))))
)
b))))))))
(setq math-current-beta-value nil)
(defun math-beta-cfrac (a b x)
@ -491,8 +456,7 @@
(math-div (math-mul qab x) qap))
'(float 1 0) '(float 1 0)
'(float 1 0)
qab qap qam a b x))
)
qab qap qam a b x)))
(defun math-beta-cfrac-step (az bz am bm m qab qap qam a b x)
(let* ((two-m (math-mul m '(float 2 0)))
@ -512,8 +476,7 @@
(math-beta-cfrac-step next '(float 1 0)
(math-div ap bpp) (math-div bp bpp)
(math-add m '(float 1 0))
qab qap qam a b x)))
)
qab qap qam a b x))))
;;; Bessel functions.
@ -583,8 +546,7 @@
(setq sum (math-add sum bj)))
(if (= j v)
(setq ans bjp)))
(math-div ans (math-sub (math-mul 2 sum) bj)))))))
)
(math-div ans (math-sub (math-mul 2 sum) bj))))))))
(defun math-besJ-series (sum term k zz vk)
(math-working "besJ" sum)
@ -594,8 +556,7 @@
(let ((next (math-add sum term)))
(if (math-nearly-equal next sum)
next
(math-besJ-series next term k zz vk)))
)
(math-besJ-series next term k zz vk))))
(defun math-besJ0 (x &optional yflag)
(cond ((and (not yflag) (math-negp (calcFunc-re x)))
@ -638,8 +599,7 @@
(float (bigpos 853 264 927 5) -5)
(float (bigpos 718 680 494 9) -3)
(float (bigpos 985 532 029 1) 0)
(float (bigpos 411 490 568 57) 0)))))))
)
(float (bigpos 411 490 568 57) 0))))))))
(defun math-besJ1 (x &optional yflag)
(cond ((and (math-negp (calcFunc-re x)) (not yflag))
@ -686,8 +646,7 @@
(float (bigpos 474 330 858 1) -2)
(float (bigpos 178 535 300 2) 0)
(float (bigpos 442 228 725 144)
0))))))))
)
0)))))))))
(defun calcFunc-besY (v x)
(math-inexact-result)
@ -721,8 +680,7 @@
bym)
bym by
by byp))
by)))))
)
by))))))
(defun math-besY0 (x)
(cond ((Math-lessp (math-abs-approx x) '(float 8 0))
@ -749,8 +707,7 @@
(math-mul '(cplx 0 2)
(math-besJ0 (math-neg x)))))
(t
(math-besJ0 x t)))
)
(math-besJ0 x t))))
(defun math-besY1 (x)
(cond ((Math-lessp (math-abs-approx x) '(float 8 0))
@ -782,15 +739,13 @@
(math-mul '(cplx 0 2)
(math-besJ1 (math-neg x))))))
(t
(math-besJ1 x t)))
)
(math-besJ1 x t))))
(defun math-poly-eval (x coefs)
(let ((accum (car coefs)))
(while (setq coefs (cdr coefs))
(setq accum (math-add (car coefs) (math-mul accum x))))
accum)
)
accum))
;;;; Bernoulli and Euler polynomials and numbers.
@ -805,8 +760,7 @@
(progn
(math-inexact-result)
(math-float (math-bernoulli-number (math-trunc n))))
(math-bernoulli-number n)))
)
(math-bernoulli-number n))))
(defun calcFunc-euler (n &optional x)
(or (math-num-natnump n) (math-reject-arg n 'natnump))
@ -840,8 +794,7 @@
(progn
(math-inexact-result)
(calcFunc-euler n '(float 5 -1)))
(calcFunc-euler n '(frac 1 2)))))
)
(calcFunc-euler n '(frac 1 2))))))
(defun math-bernoulli-coefs (n)
(let* ((coefs (list (calcFunc-bern n)))
@ -855,8 +808,7 @@
coef (math-mul term (math-bernoulli-number k))
coefs (cons (if (consp n) (math-float coef) coef) coefs)
term (math-mul term k)))
(nreverse coefs))
)
(nreverse coefs)))
(defun math-bernoulli-number (n)
(if (= (% n 2) 1)
@ -884,8 +836,7 @@
math-bernoulli-B-cache (cons (math-mul sum ofact)
math-bernoulli-B-cache)
math-bernoulli-cache-size (1+ math-bernoulli-cache-size))))
(nth (- math-bernoulli-cache-size n 1) math-bernoulli-B-cache))
)
(nth (- math-bernoulli-cache-size n 1) math-bernoulli-B-cache)))
;;; Bn = n! bn
;;; bn = - sum_k=0^n-1 bk / (n-k+1)!
@ -919,28 +870,24 @@
(defun calcFunc-utpb (x n p)
(if math-expand-formulas
(math-normalize (list 'calcFunc-betaI p x (list '+ (list '- n x) 1)))
(calcFunc-betaI p x (math-add (math-sub n x) 1)))
)
(calcFunc-betaI p x (math-add (math-sub n x) 1))))
(put 'calcFunc-utpb 'math-expandable t)
(defun calcFunc-ltpb (x n p)
(math-sub 1 (calcFunc-utpb x n p))
)
(math-sub 1 (calcFunc-utpb x n p)))
(put 'calcFunc-ltpb 'math-expandable t)
;;; Chi-square.
(defun calcFunc-utpc (chisq v)
(if math-expand-formulas
(math-normalize (list 'calcFunc-gammaQ (list '/ v 2) (list '/ chisq 2)))
(calcFunc-gammaQ (math-div v 2) (math-div chisq 2)))
)
(calcFunc-gammaQ (math-div v 2) (math-div chisq 2))))
(put 'calcFunc-utpc 'math-expandable t)
(defun calcFunc-ltpc (chisq v)
(if math-expand-formulas
(math-normalize (list 'calcFunc-gammaP (list '/ v 2) (list '/ chisq 2)))
(calcFunc-gammaP (math-div v 2) (math-div chisq 2)))
)
(calcFunc-gammaP (math-div v 2) (math-div chisq 2))))
(put 'calcFunc-ltpc 'math-expandable t)
;;; F-distribution.
@ -952,13 +899,11 @@
(list '/ v1 2)))
(calcFunc-betaI (math-div v2 (math-add v2 (math-mul v1 f)))
(math-div v2 2)
(math-div v1 2)))
)
(math-div v1 2))))
(put 'calcFunc-utpf 'math-expandable t)
(defun calcFunc-ltpf (f v1 v2)
(math-sub 1 (calcFunc-utpf f v1 v2))
)
(math-sub 1 (calcFunc-utpf f v1 v2)))
(put 'calcFunc-ltpf 'math-expandable t)
;;; Normal.
@ -975,8 +920,7 @@
(calcFunc-erf
(math-div (math-sub mean x)
(math-mul sdev (math-sqrt-2)))))
'(float 5 -1)))
)
'(float 5 -1))))
(put 'calcFunc-utpn 'math-expandable t)
(defun calcFunc-ltpn (x mean sdev)
@ -992,23 +936,20 @@
(calcFunc-erf
(math-div (math-sub x mean)
(math-mul sdev (math-sqrt-2)))))
'(float 5 -1)))
)
'(float 5 -1))))
(put 'calcFunc-ltpn 'math-expandable t)
;;; Poisson.
(defun calcFunc-utpp (n x)
(if math-expand-formulas
(math-normalize (list 'calcFunc-gammaP x n))
(calcFunc-gammaP x n))
)
(calcFunc-gammaP x n)))
(put 'calcFunc-utpp 'math-expandable t)
(defun calcFunc-ltpp (n x)
(if math-expand-formulas
(math-normalize (list 'calcFunc-gammaQ x n))
(calcFunc-gammaQ x n))
)
(calcFunc-gammaQ x n)))
(put 'calcFunc-ltpp 'math-expandable t)
;;; Student's t. (As defined in Abramowitz & Stegun and Numerical Recipes.)
@ -1020,15 +961,12 @@
'(float 5 -1)))
(calcFunc-betaI (math-div v (math-add v (math-sqr tt)))
(math-div v 2)
'(float 5 -1)))
)
'(float 5 -1))))
(put 'calcFunc-utpt 'math-expandable t)
(defun calcFunc-ltpt (tt v)
(math-sub 1 (calcFunc-utpt tt v))
)
(math-sub 1 (calcFunc-utpt tt v)))
(put 'calcFunc-ltpt 'math-expandable t)
;;; calc-funcs.el ends here

190
lisp/calc/calc-graph.el
View File

@ -64,16 +64,14 @@
(let ((calc-graph-no-auto-view t))
(calc-graph-delete t)
(calc-graph-add many)
(calc-graph-plot nil))
)
(calc-graph-plot nil)))
(defun calc-graph-fast-3d (many)
(interactive "P")
(let ((calc-graph-no-auto-view t))
(calc-graph-delete t)
(calc-graph-add-3d many)
(calc-graph-plot nil))
)
(calc-graph-plot nil)))
(defun calc-graph-delete (all)
(interactive "P")
@ -88,8 +86,7 @@
(setq calc-graph-var-cache nil)
(delete-region (point) (point-max)))
(delete-region (point) (1- (point-max)))))))
(calc-graph-view-commands))
)
(calc-graph-view-commands)))
(defun calc-graph-find-plot (&optional before all)
(goto-char (point-min))
@ -105,8 +102,7 @@
(beginning-of-line)))
(or before
(re-search-forward ",[ \t]+")))
t))
)
t)))
(defun calc-graph-add (many)
(interactive "P")
@ -139,8 +135,7 @@
(calc-graph-add-curve (calc-graph-lookup (nth 1 pair))
(calc-graph-lookup (nth 2 pair)))
(setq many (1- many))))))
(calc-graph-view-commands))
)
(calc-graph-view-commands)))
(defun calc-graph-add-3d (many)
(interactive "P")
@ -178,8 +173,7 @@
(calc-graph-lookup (nth 2 curve))
(calc-graph-lookup (nth 3 curve)))
(setq many (1- many))))))
(calc-graph-view-commands))
)
(calc-graph-view-commands)))
(defun calc-graph-add-curve (xdata ydata &optional zdata)
(let ((num (calc-graph-count-curves))
@ -214,8 +208,7 @@
0)
(or (and (Math-num-integerp pstyle) (math-trunc pstyle))
(if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec)
0 -1)))))
)
0 -1))))))
(defun calc-graph-lookup (thing)
(if (and (eq (car-safe thing) 'var)
@ -232,8 +225,7 @@
found (cons thing var)
calc-graph-var-cache (cons found calc-graph-var-cache))
(set (nth 2 var) thing)))
(cdr found)))
)
(cdr found))))
(defun calc-graph-juggle (arg)
(interactive "p")
@ -246,8 +238,7 @@
(while (< arg 0)
(setq arg (+ arg num))))))
(while (>= (setq arg (1- arg)) 0)
(calc-graph-do-juggle)))
)
(calc-graph-do-juggle))))
(defun calc-graph-count-curves ()
(save-excursion
@ -258,8 +249,7 @@
(while (search-forward "," nil t)
(setq num (1+ num)))
num)
0))
)
0)))
(defun calc-graph-do-juggle ()
(let (base)
@ -271,13 +261,11 @@
(let ((str (buffer-substring (+ (point) 2) (1- (point-max)))))
(delete-region (point) (1- (point-max)))
(goto-char (+ base 5))
(insert str ", "))))))
)
(insert str ", ")))))))
(defun calc-graph-print (flag)
(interactive "P")
(calc-graph-plot flag t)
)
(calc-graph-plot flag t))
(defun calc-graph-plot (flag &optional printing)
(interactive "P")
@ -522,8 +510,7 @@
calc-gnuplot-print-output)))
(if (symbolp command)
(funcall command output)
(eval command)))))))))
)
(eval command))))))))))
(defun calc-graph-compute-2d ()
(if (setq yvec (eq (car-safe yvalue) 'vec))
@ -560,8 +547,7 @@
(if (and (not (setq xvec (eq (car-safe xvalue) 'vec)))
refine (cdr (cdr ycache)))
(calc-graph-refine-2d)
(calc-graph-recompute-2d)))
)
(calc-graph-recompute-2d))))
(defun calc-graph-refine-2d ()
(setq keep-file nil
@ -592,8 +578,7 @@
(cdr ycacheptr)))
(setq ycacheptr (cdr (cdr ycacheptr))))
(setq yp ycache
numsteps 1000000)
)
numsteps 1000000))
(defun calc-graph-recompute-2d ()
(setq ycacheptr ycache)
@ -645,8 +630,7 @@
yvec t
yp (cons 'vec (nreverse yvector))
numsteps (1- (length xp)))
(setq numsteps 1000000))
)
(setq numsteps 1000000)))
(defun calc-graph-compute-3d ()
(if (setq yvec (eq (car-safe yvalue) 'vec))
@ -760,8 +744,7 @@
var-DUMMY2 (car y3step)
zp (cons (math-evaluate-expr yvalue) zp))))
(setq zp (nreverse zp)
numsteps (1- (* numsteps (1+ numsteps3)))))
)
numsteps (1- (* numsteps (1+ numsteps3))))))
(defun calc-graph-format-data ()
(while (<= (setq stepcount (1+ stepcount)) numsteps)
@ -848,8 +831,7 @@
(or blank
(progn
(insert "\n")
(setq blank t)))))
)
(setq blank t))))))
(defun calc-temp-file-name (num)
(while (<= (length calc-graph-file-cache) (1+ num))
@ -861,8 +843,7 @@
(if (<= num 0)
(char-to-string (- ?A num))
(int-to-string num))))
nil))))
)
nil)))))
(defun calc-graph-delete-temps ()
(while calc-graph-file-cache
@ -871,22 +852,19 @@
(condition-case err
(delete-file (car (car calc-graph-file-cache)))
(error nil)))
(setq calc-graph-file-cache (cdr calc-graph-file-cache)))
)
(setq calc-graph-file-cache (cdr calc-graph-file-cache))))
(defun calc-graph-kill-hook ()
(calc-graph-delete-temps)
(if calc-graph-prev-kill-hook
(funcall calc-graph-prev-kill-hook))
)
(funcall calc-graph-prev-kill-hook)))
(defun calc-graph-show-tty (output)
"Default calc-gnuplot-plot-command for \"tty\" output mode.
This is useful for tek40xx and other graphics-terminal types."
(call-process-region 1 1 shell-file-name
nil calc-gnuplot-buffer nil
"-c" (format "cat %s >/dev/tty; rm %s" output output))
)
"-c" (format "cat %s >/dev/tty; rm %s" output output)))
(defun calc-graph-show-dumb (&optional output)
"Default calc-gnuplot-plot-command for Pinard's \"dumb\" terminal type.
@ -934,8 +912,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch)
" or `M-# M-#'" ""))
(recursive-edit)
(bury-buffer "*Gnuplot Trail*"))
)
(bury-buffer "*Gnuplot Trail*")))
(defun calc-graph-clear ()
(interactive)
@ -946,41 +923,34 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(if (equal calc-graph-last-output "STDOUT")
""
(prin1-to-string calc-graph-last-output)))
(calc-gnuplot-command "clear")))
)
(calc-gnuplot-command "clear"))))
(defun calc-graph-title-x (title)
(interactive "sX axis title: ")
(calc-graph-set-command "xlabel" (if (not (equal title ""))
(prin1-to-string title)))
)
(prin1-to-string title))))
(defun calc-graph-title-y (title)
(interactive "sY axis title: ")
(calc-graph-set-command "ylabel" (if (not (equal title ""))
(prin1-to-string title)))
)
(prin1-to-string title))))
(defun calc-graph-title-z (title)
(interactive "sZ axis title: ")
(calc-graph-set-command "zlabel" (if (not (equal title ""))
(prin1-to-string title)))
)
(prin1-to-string title))))
(defun calc-graph-range-x (range)
(interactive "sX axis range: ")
(calc-graph-set-range "xrange" range)
)
(calc-graph-set-range "xrange" range))
(defun calc-graph-range-y (range)
(interactive "sY axis range: ")
(calc-graph-set-range "yrange" range)
)
(calc-graph-set-range "yrange" range))
(defun calc-graph-range-z (range)
(interactive "sZ axis range: ")
(calc-graph-set-range "zrange" range)
)
(calc-graph-set-range "zrange" range))
(defun calc-graph-set-range (cmd range)
(if (equal range "$")
@ -1004,23 +974,19 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(string-match " " range)))
(aset range (match-beginning 0) ?\:))
(calc-graph-set-command cmd (if (not (equal range ""))
(concat "[" range "]")))
)
(concat "[" range "]"))))
(defun calc-graph-log-x (flag)
(interactive "P")
(calc-graph-set-log flag 0 0)
)
(calc-graph-set-log flag 0 0))
(defun calc-graph-log-y (flag)
(interactive "P")
(calc-graph-set-log 0 flag 0)
)
(calc-graph-set-log 0 flag 0))
(defun calc-graph-log-z (flag)
(interactive "P")
(calc-graph-set-log 0 0 flag)
)
(calc-graph-set-log 0 0 flag))
(defun calc-graph-set-log (xflag yflag zflag)
(let* ((old (or (calc-graph-find-command "logscale") ""))
@ -1040,18 +1006,15 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(if (eq zflag 0) zold
(> (prefix-numeric-value zflag) 0))
(not zold)) "z" "")))
(calc-graph-set-command "logscale" (if (not (equal str "")) str)))
)
(calc-graph-set-command "logscale" (if (not (equal str "")) str))))
(defun calc-graph-line-style (style)
(interactive "P")
(calc-graph-set-styles (and style (prefix-numeric-value style)) t)
)
(calc-graph-set-styles (and style (prefix-numeric-value style)) t))
(defun calc-graph-point-style (style)
(interactive "P")
(calc-graph-set-styles t (and style (prefix-numeric-value style)))
)
(calc-graph-set-styles t (and style (prefix-numeric-value style))))
(defun calc-graph-set-styles (lines points)
(calc-graph-init)
@ -1104,8 +1067,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
" " (int-to-string pstyle))
(if (and lstyle (> lstyle 0))
(insert " " (int-to-string lstyle))))))
(calc-graph-view-commands)
)
(calc-graph-view-commands))
(defun calc-graph-zero-x (flag)
(interactive "P")
@ -1113,8 +1075,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(and (if flag
(<= (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "noxzeroaxis")))
" "))
)
" ")))
(defun calc-graph-zero-y (flag)
(interactive "P")
@ -1122,8 +1083,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(and (if flag
(<= (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "noyzeroaxis")))
" "))
)
" ")))
(defun calc-graph-name (name)
(interactive "sTitle for current curve: ")
@ -1143,8 +1103,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(delete-region (point) end))
(goto-char end))
(insert " title " (prin1-to-string name))))
(calc-graph-view-commands)
)
(calc-graph-view-commands))
(defun calc-graph-hide (flag)
(interactive "P")
@ -1158,14 +1117,12 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(if (or (null flag) (<= (prefix-numeric-value flag) 0))
(delete-char 1))
(if (or (null flag) (> (prefix-numeric-value flag) 0))
(insert "*")))))
)
(insert "*"))))))
(defun calc-graph-header (title)
(interactive "sTitle for entire graph: ")
(calc-graph-set-command "title" (if (not (equal title ""))
(prin1-to-string title)))
)
(prin1-to-string title))))
(defun calc-graph-border (flag)
(interactive "P")
@ -1173,24 +1130,21 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(and (if flag
(<= (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "noborder")))
" "))
)
" ")))
(defun calc-graph-grid (flag)
(interactive "P")
(calc-graph-set-command "grid" (and (if flag
(> (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "grid")))
" "))
)
" ")))
(defun calc-graph-key (flag)
(interactive "P")
(calc-graph-set-command "key" (and (if flag
(> (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "key")))
" "))
)
" ")))
(defun calc-graph-num-points (res flag)
(interactive "sNumber of data points: \nP")
@ -1204,8 +1158,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(message "Default 3D resolution is %d."
calc-graph-default-resolution-3d)
(setq calc-graph-default-resolution-3d (string-to-int res))))
(calc-graph-set-command "samples" (if (not (equal res "")) res)))
)
(calc-graph-set-command "samples" (if (not (equal res "")) res))))
(defun calc-graph-device (name flag)
(interactive "sDevice name: \nP")
@ -1224,8 +1177,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
calc-gnuplot-print-device)
(setq calc-gnuplot-print-device name)))
(calc-graph-set-command "terminal" (if (not (equal name ""))
name))))
)
name)))))
(defun calc-graph-output (name flag)
(interactive "FOutput file name: \np")
@ -1249,8 +1201,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
calc-gnuplot-print-output)
(setq calc-gnuplot-print-output name)))
(calc-graph-set-command "output" (if (not (equal name ""))
(prin1-to-string name))))
)
(prin1-to-string name)))))
(defun calc-graph-display (name)
(interactive "sX display name: ")
@ -1259,8 +1210,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(or calc-gnuplot-display "<none>"))
(setq calc-gnuplot-display name)
(if (calc-gnuplot-alive)
(calc-gnuplot-command "exit")))
)
(calc-gnuplot-command "exit"))))
(defun calc-graph-geometry (name)
(interactive "sX geometry spec (or \"default\"): ")
@ -1269,8 +1219,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(or calc-gnuplot-geometry "default"))
(setq calc-gnuplot-geometry (and (not (equal name "default")) name))
(if (calc-gnuplot-alive)
(calc-gnuplot-command "exit")))
)
(calc-gnuplot-command "exit"))))
(defun calc-graph-find-command (cmd)
(calc-graph-init)
@ -1278,8 +1227,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(set-buffer calc-gnuplot-input)
(goto-char (point-min))
(if (re-search-forward (concat "^set[ \t]+" cmd "[ \t]*\\(.*\\)$") nil t)
(buffer-substring (match-beginning 1) (match-end 1))))
)
(buffer-substring (match-beginning 1) (match-end 1)))))
(defun calc-graph-set-command (cmd &rest args)
(calc-graph-init)
@ -1302,8 +1250,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(or (bolp)
(insert "\n"))
(insert "set " (mapconcat 'identity (cons cmd args) " ") "\n"))))
(calc-graph-view-commands)
)
(calc-graph-view-commands))
(defun calc-graph-command (cmd)
(interactive "sGNUPLOT command: ")
@ -1312,8 +1259,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(calc-graph-view-trail)
(calc-gnuplot-command cmd)
(accept-process-output)
(calc-graph-view-trail))
)
(calc-graph-view-trail)))
(defun calc-graph-kill (&optional no-view)
(interactive)
@ -1326,8 +1272,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(sit-for 1)
(if (process-status calc-gnuplot-process)
(delete-process calc-gnuplot-process))
(setq calc-gnuplot-process nil)))
)
(setq calc-gnuplot-process nil))))
(defun calc-graph-quit ()
(interactive)
@ -1335,20 +1280,17 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(calc-graph-view-commands t))
(if (get-buffer-window calc-gnuplot-buffer)
(calc-graph-view-trail t))
(calc-graph-kill t)
)
(calc-graph-kill t))
(defun calc-graph-view-commands (&optional no-need)
(interactive "p")
(or calc-graph-no-auto-view (calc-graph-init-buffers))
(calc-graph-view calc-gnuplot-input calc-gnuplot-buffer (null no-need))
)
(calc-graph-view calc-gnuplot-input calc-gnuplot-buffer (null no-need)))
(defun calc-graph-view-trail (&optional no-need)
(interactive "p")
(or calc-graph-no-auto-view (calc-graph-init-buffers))
(calc-graph-view calc-gnuplot-buffer calc-gnuplot-input (null no-need))
)
(calc-graph-view calc-gnuplot-buffer calc-gnuplot-input (null no-need)))
(defun calc-graph-view (buf other-buf need)
(let (win)
@ -1383,8 +1325,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(vertical-motion (- 6 (window-height win)))
(set-window-start win (point))
(goto-char (point-max)))))
(or calc-graph-no-auto-view (sit-for 0)))
)
(or calc-graph-no-auto-view (sit-for 0))))
(setq calc-graph-no-auto-view nil)
(defun calc-gnuplot-check-for-errors ()
@ -1396,8 +1337,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(re-search-forward "^[ \t]+\\^$" nil t)
(goto-char (point-max))
(setq calc-gnuplot-last-error-pos (point-max))))
(calc-graph-view-trail))
)
(calc-graph-view-trail)))
(defun calc-gnuplot-command (&rest args)
(calc-graph-init)
@ -1418,8 +1358,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
calc-gnuplot-process))
(calc-gnuplot-check-for-errors)
(if (get-buffer-window calc-gnuplot-buffer)
(calc-graph-view-trail))))
)
(calc-graph-view-trail)))))
(setq calc-graph-no-wait nil)
(defun calc-graph-init-buffers ()
@ -1428,8 +1367,7 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(setq calc-gnuplot-buffer (get-buffer-create "*Gnuplot Trail*")))
(or (and calc-gnuplot-input
(buffer-name calc-gnuplot-input))
(setq calc-gnuplot-input (get-buffer-create "*Gnuplot Commands*")))
)
(setq calc-gnuplot-input (get-buffer-create "*Gnuplot Commands*"))))
(defun calc-graph-init ()
(or (calc-gnuplot-alive)
@ -1491,6 +1429,6 @@ This \"dumb\" driver will be present in Gnuplot 3.0."
(eq (char-after (1- (point-max))) ?\n)
(progn
(goto-char (point-max))
(insert "\n")))))
)
(insert "\n"))))))
;;; calc-graph.el ends here

109
lisp/calc/calc-help.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-help.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -43,8 +43,7 @@
(message "")
(if key
(call-interactively key)
(beep)))
)
(beep))))
(defun calc-help-for-help (arg)
"You have typed `h', the Calc help character. Type a Help option:
@ -84,20 +83,17 @@ C-w Describe how there is no warranty for Calc."
(calc-unread-command (cdr key))
(calc-help-prefix nil))
(let ((calc-dispatch-help t))
(calc-help-prefix arg)))
)
(calc-help-prefix arg))))
(defun calc-describe-copying ()
(interactive)
(calc-info)
(Info-goto-node "Copying")
)
(Info-goto-node "Copying"))
(defun calc-describe-distribution ()
(interactive)
(calc-info)
(Info-goto-node "Reporting Bugs")
)
(Info-goto-node "Reporting Bugs"))
(defun calc-describe-no-warranty ()
(interactive)
@ -106,8 +102,7 @@ C-w Describe how there is no warranty for Calc."
(let ((case-fold-search nil))
(search-forward " NO WARRANTY"))
(beginning-of-line)
(recenter 0)
)
(recenter 0))
(defun calc-describe-bindings ()
(interactive)
@ -141,13 +136,11 @@ C-w Describe how there is no warranty for Calc."
(delete-backward-char 1)
(delete-char 1)
(insert (format "%c .. %c" (min dig1 dig2) (max dig1 dig2)))))
(goto-char (point-min)))
)
(goto-char (point-min))))
(defun calc-describe-key-briefly (key)
(interactive "kDescribe key briefly: ")
(calc-describe-key key t)
)
(calc-describe-key key t))
(defun calc-describe-key (key &optional briefly)
(interactive "kDescribe key: ")
@ -298,8 +291,7 @@ C-w Describe how there is no warranty for Calc."
(if inv (setq desc (concat "I " desc)))
(if hyp (setq desc (concat "H " desc)))
(calc-describe-thing desc "Key Index" nil
(string-match "[A-Z][A-Z][A-Z]" desc)))))
)
(string-match "[A-Z][A-Z][A-Z]" desc))))))
(defun calc-describe-function (&optional func)
(interactive)
@ -312,8 +304,7 @@ C-w Describe how there is no warranty for Calc."
(calc-describe-thing (if (string-match "\\`calcFunc-." func)
(substring func 9)
func)
"Function Index"))
)
"Function Index")))
(defun calc-describe-variable (&optional var)
(interactive)
@ -324,8 +315,7 @@ C-w Describe how there is no warranty for Calc."
(calc-describe-thing var "Variable Index"
(if (string-match "\\`var-." var)
(substring var 4)
var))
)
var)))
(defun calc-describe-thing (thing where &optional target not-quoted)
(message "Looking for `%s' in %s..." thing where)
@ -365,8 +355,7 @@ C-w Describe how there is no warranty for Calc."
(search-forward (format "`%s'" (or target thing)) nil t)
(search-forward (or target thing) nil t))))
(beginning-of-line)
(message "Found `%s' in %s" thing where))
)
(message "Found `%s' in %s" thing where)))
(defun calc-view-news ()
(interactive)
@ -384,10 +373,7 @@ C-w Describe how there is no warranty for Calc."
(search-forward "Summary of changes")
(forward-line -1)
(delete-region (point-min) (point))
(goto-char (point-min)))
)
(goto-char (point-min))))
(defun calc-full-help ()
(interactive)
@ -444,23 +430,20 @@ C-w Describe how there is no warranty for Calc."
calc-shift-Y-prefix-help
calc-shift-Z-prefix-help
calc-z-prefix-help)))
(print-help-return-message))
)
(print-help-return-message)))
(defvar calc-help-long-names '( ( ?b . "binary/business" )
( ?g . "graphics" )
( ?j . "selection" )
( ?k . "combinatorics/statistics" )
( ?u . "units/statistics" )
))
(defvar calc-help-long-names '((?b . "binary/business")
(?g . "graphics")
(?j . "selection")
(?k . "combinatorics/statistics")
(?u . "units/statistics")))
(defun calc-h-prefix-help ()
(interactive)
(calc-do-prefix-help
'("Help; Bindings; Info, Tutorial, Summary; News"
"describe: Key, C (briefly), Function, Variable")
"help" ?h)
)
"help" ?h))
(defun calc-inverse-prefix-help ()
(interactive)
@ -474,8 +457,7 @@ C-w Describe how there is no warranty for Calc."
"I + v s (remove subvec); v h (tail)"
"I + t + (alt sum), t M (mean with error)"
"I + t S (pop std dev), t C (pop covar)")
"inverse" nil)
)
"inverse" nil))
(defun calc-hyperbolic-prefix-help ()
(interactive)
@ -490,8 +472,7 @@ C-w Describe how there is no warranty for Calc."
"H + a R (widen/root), a N (widen/min), a X (widen/max)"
"H + t M (median), t S (variance), t C (correlation coef)"
"H + c f/F/c (pervasive float/frac/clean)")
"hyperbolic" nil)
)
"hyperbolic" nil))
(defun calc-inv-hyp-prefix-help ()
(interactive)
@ -501,8 +482,7 @@ C-w Describe how there is no warranty for Calc."
"I H + F (float ceiling), R (float truncate)"
"I H + t S (pop variance)"
"I H + a S (general invert func); v h (rtail)")
"inverse-hyperbolic" nil)
)
"inverse-hyperbolic" nil))
(defun calc-f-prefix-help ()
@ -513,8 +493,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + int-sQrt; Int-log, Exp(x)-1, Ln(x+1); arcTan2"
"SHIFT + Abssqr; Mantissa, eXponent, Scale"
"SHIFT + incomplete: Gamma-P, Beta-I")
"functions" ?f)
)
"functions" ?f))
(defun calc-s-prefix-help ()
@ -526,15 +505,13 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + Decls, GenCount, TimeZone, Holidays; IntegLimit"
"SHIFT + LineStyles, PointStyles, plotRejects; Units"
"SHIFT + Eval-, AlgSimp-, ExtSimp-, FitRules")
"store" ?s)
)
"store" ?s))
(defun calc-r-prefix-help ()
(interactive)
(calc-do-prefix-help
'("digits 0-9: recall, same as `s r 0-9'")
"recall" ?r)
)
"recall" ?r))
(defun calc-j-prefix-help ()
@ -547,8 +524,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + swap: Left, Right; maybe: Select, Once"
"SHIFT + Commute, Merge, Distrib, jump-Eqn, Isolate"
"SHIFT + Negate, & (invert); Unpack")
"select" ?j)
)
"select" ?j))
(defun calc-a-prefix-help ()
@ -564,8 +540,7 @@ C-w Describe how there is no warranty for Calc."
"relations: =, # (not =), <, >, [ (< or =), ] (> or =)"
"logical: & (and), | (or), ! (not); : (if)"
"misc: { (in-set); . (rmeq)")
"algebra" ?a)
)
"algebra" ?a))
(defun calc-b-prefix-help ()
@ -575,8 +550,7 @@ C-w Describe how there is no warranty for Calc."
"Lshift, Rshift, roTate; SHIFT + signed Lshift, Rshift"
"SHIFT + business: Pv, Npv, Fv, pMt, #pmts, raTe, Irr"
"SHIFT + business: Sln, sYd, Ddb; %ch")
"binary/bus" ?b)
)
"binary/bus" ?b))
(defun calc-c-prefix-help ()
@ -584,8 +558,7 @@ C-w Describe how there is no warranty for Calc."
(calc-do-prefix-help
'("Deg, Rad, HMS; Float; Polar/rect; Clean, 0-9; %"
"SHIFT + Fraction")
"convert" ?c)
)
"convert" ?c))
(defun calc-d-prefix-help ()
@ -598,8 +571,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + language: Normal, One-line, Big, Unformatted"
"SHIFT + language: C, Pascal, Fortran; TeX, Eqn"
"SHIFT + language: Mathematica, W=Maple")
"display" ?d)
)
"display" ?d))
(defun calc-g-prefix-help ()
@ -612,8 +584,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + Print; Device, Output-file; X-geometry"
"SHIFT + Num-pts; Command, Kill, View-trail"
"SHIFT + 3d: Fast, Add; CTRL + z-axis: Range, Title, Log")
"graph" ?g)
)
"graph" ?g))
(defun calc-k-prefix-help ()
@ -626,8 +597,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + Extended-gcd"
"SHIFT + dists: Binomial, Chi-square, F, Normal"
"SHIFT + dists: Poisson, student's-T")
"combinatorics" ?k)
)
"combinatorics" ?k))
(defun calc-m-prefix-help ()
@ -637,8 +607,7 @@ C-w Describe how there is no warranty for Calc."
"Working; Xtensions; Mode-save"
"SHIFT + Shifted-prefixes, mode-Filename; Record; reCompute"
"SHIFT + simplify: Off, Num, Default, Bin, Alg, Ext, Units")
"mode" ?m)
)
"mode" ?m))
(defun calc-t-prefix-help ()
@ -650,8 +619,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + time: newWeek, newMonth, newYear; Incmonth"
"SHIFT + time: +, - (business days)"
"digits 0-9: store-to, same as `s t 0-9'")
"trail/time" ?t)
)
"trail/time" ?t))
(defun calc-u-prefix-help ()
@ -663,8 +631,7 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + View-table-other-window"
"SHIFT + stat: Mean, G-mean, Std-dev, Covar, maX, miN"
"SHIFT + stat: + (sum), - (asum), * (prod), # (count)")
"units/stat" ?u)
)
"units/stat" ?u))
(defun calc-v-prefix-help ()
@ -681,6 +648,6 @@ C-w Describe how there is no warranty for Calc."
"SHIFT + sets: : (span), # (card), + (rdup)"
"<, =, > (justification); , (commas); [, {, ( (brackets)"
"} (matrix brackets); . (abbreviate); / (multi-lines)")
"vec/mat" ?v)
)
"vec/mat" ?v))
;;; calc-help.el ends here

35
lisp/calc/calc-incom.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-incom.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -36,8 +36,7 @@
(calc-wrapper
(if (or calc-algebraic-mode calc-incomplete-algebraic-mode)
(calc-alg-entry "(")
(calc-push (list 'incomplete calc-complex-mode))))
)
(calc-push (list 'incomplete calc-complex-mode)))))
(defun calc-end-complex ()
(interactive)
@ -60,16 +59,14 @@
(if (not (and (math-realp (nth 2 top))
(math-anglep (nth 3 top))))
(error "Components must be real"))
(calc-enter-result 1 "()" (cdr top)))))
)
(calc-enter-result 1 "()" (cdr top))))))
(defun calc-begin-vector ()
(interactive)
(calc-wrapper
(if (or calc-algebraic-mode calc-incomplete-algebraic-mode)
(calc-alg-entry "[")
(calc-push '(incomplete vec))))
)
(calc-push '(incomplete vec)))))
(defun calc-end-vector ()
(interactive)
@ -88,8 +85,7 @@
(if (not (and (eq (car-safe top) 'incomplete)
(eq (nth 1 top) 'vec)))
(error "Not entering a vector"))
(calc-pop-push-record 1 "[]" (cdr top)))))
)
(calc-pop-push-record 1 "[]" (cdr top))))))
(defun calc-comma (&optional allow-polar)
(interactive)
@ -121,8 +117,7 @@
(if (and (eq (nth 1 new) 'intv)
(> (length new) 5))
(error "Too many components in interval form"))
(calc-pop-push num new))))
)
(calc-pop-push num new)))))
(defun calc-semi ()
(interactive)
@ -169,8 +164,7 @@
(calc-pop-push num
(list 'incomplete 'vec
(cons 'vec (append (cdr (cdr inc)) stuff)))
(list 'incomplete 'vec)))))))
)
(list 'incomplete 'vec))))))))
(defun calc-digit-dots ()
(if (eq calc-prev-char ?.)
@ -186,8 +180,7 @@
(erase-buffer)
(exit-minibuffer)))
;; just ignore extra decimal point, anticipating ".."
(delete-backward-char 1))
)
(delete-backward-char 1)))
(defun calc-dots ()
(interactive)
@ -208,8 +201,7 @@
(setq new (append new '((neg (var inf var-inf))))))
(if (> (length new) 5)
(error "Too many components in interval form"))
(calc-pop-push num new))))
)
(calc-pop-push num new)))))
(defun calc-find-first-incomplete (stack n)
(cond ((null stack)
@ -217,8 +209,7 @@
((eq (car-safe (car-safe (car stack))) 'incomplete)
n)
(t
(calc-find-first-incomplete (cdr stack) (1+ n))))
)
(calc-find-first-incomplete (cdr stack) (1+ n)))))
(defun calc-incomplete-error (a)
(cond ((memq (nth 1 a) '(cplx polar))
@ -227,8 +218,6 @@
(error "Vector is incomplete"))
((eq (nth 1 a) 'intv)
(error "Interval form is incomplete"))
(t (error "Object is incomplete")))
)
(t (error "Object is incomplete"))))
;;; calc-incom.el ends here

49
lisp/calc/calc-keypd.el
View File

@ -127,8 +127,7 @@
(interactive)
(if calc-standalone-flag
(save-buffers-kill-emacs nil)
(calc-keypad))
)
(calc-keypad)))
(defun calc-keypad-redraw ()
(set-buffer calc-keypad-buffer)
@ -176,8 +175,7 @@
row (cdr row)))))
(setq calc-keypad-prev-input t)
(calc-keypad-show-input)
(goto-char (point-min))
)
(goto-char (point-min)))
(defun calc-keypad-show-input ()
(or (equal calc-keypad-input calc-keypad-prev-input)
@ -191,8 +189,7 @@
(insert "----+-----Calc " calc-version "-----+----"
(int-to-string (1+ calc-keypad-menu))
"\n")))))
(setq calc-keypad-prev-input calc-keypad-input)
)
(setq calc-keypad-prev-input calc-keypad-input))
(defun calc-keypad-press ()
(interactive)
@ -343,8 +340,7 @@
(command-execute (car cmd))))
(command-execute cmd)))))
(set-buffer calc-keypad-buffer)
(calc-keypad-show-input)))
)
(calc-keypad-show-input))))
(defun calc-keypad-left-click (event)
"Handle a left-button mouse click in Calc Keypad window."
@ -372,8 +368,7 @@
(while (progn (setq calc-keypad-menu (% (1+ calc-keypad-menu)
(length calc-keypad-menus)))
(not (symbol-value (nth calc-keypad-menu calc-keypad-menus)))))
(calc-keypad-redraw)
)
(calc-keypad-redraw))
(defun calc-keypad-menu-back ()
(interactive)
@ -383,25 +378,21 @@
(length calc-keypad-menus)))
(length calc-keypad-menus)))
(not (symbol-value (nth calc-keypad-menu calc-keypad-menus)))))
(calc-keypad-redraw)
)
(calc-keypad-redraw))
(defun calc-keypad-store ()
(interactive)
(setq calc-keypad-input "STO")
)
(setq calc-keypad-input "STO"))
(defun calc-keypad-recall ()
(interactive)
(setq calc-keypad-input "RCL")
)
(setq calc-keypad-input "RCL"))
(defun calc-pack-interval (mode)
(interactive "p")
(if (or (< mode 0) (> mode 3))
(error "Open/close code should be in the range from 0 to 3."))
(calc-pack (- -6 mode))
)
(calc-pack (- -6 mode)))
(defun calc-keypad-execute ()
(interactive)
@ -430,8 +421,7 @@
(message "")
(if (commandp cmd)
(command-execute cmd)
(error "Not a Calc command: %s" (key-description keys))))
)
(error "Not a Calc command: %s" (key-description keys)))))
;;; |----+----+----+----+----+----|
@ -474,8 +464,7 @@
( "0" ("0") calc-imaginary )
( "." (".") calc-precision )
( "PI" calc-pi )
( "+" calc-plus calc-sqrt ) ) )
)
( "+" calc-plus calc-sqrt ) ) ))
(defvar calc-keypad-menus '( calc-keypad-math-menu
calc-keypad-funcs-menu
@ -509,8 +498,7 @@
( "TAN" calc-tan )
( "SQRT" calc-sqrt )
( "y^x" calc-power )
( "1/x" calc-inv ) ) )
)
( "1/x" calc-inv ) ) ))
;;; |----+----+----+----+----+----|
;;; |IGAM|BETA|IBET|ERF |BESJ|BESY|
@ -537,8 +525,7 @@
( "DFCT" calc-double-factorial )
( "BNOM" calc-choose )
( "PERM" calc-perm )
( "NXTP" calc-next-prime calc-prev-prime ) ) )
)
( "NXTP" calc-next-prime calc-prev-prime ) ) ))
;;; |----+----+----+----+----+----|
;;; |AND | OR |XOR |NOT |LSH |RSH |
@ -565,8 +552,7 @@
( "C" ("C") )
( "D" ("D") )
( "E" ("E") )
( "F" ("F") ) ) )
)
( "F" ("F") ) ) ))
;;; |----+----+----+----+----+----|
;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$|
@ -598,8 +584,7 @@
( "INDX" (progn calc-num-prefix calc-index) "\C-u\excalc-index\r" )
( "BLD" (progn calc-num-prefix calc-build-vector) )
( "LEN" calc-vlength )
( "..." calc-full-vectors ) ) )
)
( "..." calc-full-vectors ) ) ))
;;; |----+----+----+----+----+----|
;;; |FLT |FIX |SCI |ENG |GRP | |
@ -630,6 +615,6 @@
( "RLL4" (progn 4 calc-roll-up) (progn 4 calc-roll-down) )
( "OVER" calc-over )
( "STO" calc-keypad-store )
( "RCL" calc-keypad-recall ) ) )
)
( "RCL" calc-keypad-recall ) ) ))
;;; calc-keypd.el ends here

126
lisp/calc/calc-lang.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-lang.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -46,44 +46,38 @@
(setq calc-language lang
calc-language-option option)
(calc-change-mode '(calc-language calc-language-option)
(list lang option) t))
)
(list lang option) t)))
(defun calc-normal-language ()
(interactive)
(calc-wrapper
(calc-set-language nil)
(message "Normal language mode."))
)
(message "Normal language mode.")))
(defun calc-flat-language ()
(interactive)
(calc-wrapper
(calc-set-language 'flat)
(message "Flat language mode (all stack entries shown on one line)."))
)
(message "Flat language mode (all stack entries shown on one line).")))
(defun calc-big-language ()
(interactive)
(calc-wrapper
(calc-set-language 'big)
(message "\"Big\" language mode."))
)
(message "\"Big\" language mode.")))
(defun calc-unformatted-language ()
(interactive)
(calc-wrapper
(calc-set-language 'unform)
(message "Unformatted language mode."))
)
(message "Unformatted language mode.")))
(defun calc-c-language ()
(interactive)
(calc-wrapper
(calc-set-language 'c)
(message "`C' language mode."))
)
(message "`C' language mode.")))
(put 'c 'math-oper-table
'( ( "u+" ident -1 1000 )
@ -114,8 +108,7 @@
( "|||" calcFunc-por 75 76 )
( "=" calcFunc-assign 51 50 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
)) ; should support full assignments
( "::" calcFunc-condition 45 46 ))) ; should support full assignments
(put 'c 'math-function-table
'( ( acos . calcFunc-arccos )
@ -124,13 +117,11 @@
( asinh . calcFunc-arcsinh )
( atan . calcFunc-arctan )
( atan2 . calcFunc-arctan2 )
( atanh . calcFunc-arctanh )
))
( atanh . calcFunc-arctanh )))
(put 'c 'math-variable-table
'( ( M_PI . var-pi )
( M_E . var-e )
))
( M_E . var-e )))
(put 'c 'math-vector-brackets "{}")
@ -150,8 +141,7 @@
(if (> n 0)
"Pascal language mode (all uppercase)."
"Pascal language mode (all lowercase).")
"Pascal language mode.")))
)
"Pascal language mode."))))
(put 'pascal 'math-oper-table
'( ( "not" calcFunc-lnot -1 1000 )
@ -179,8 +169,7 @@
( "&&&" calcFunc-pand 80 81 )
( "|||" calcFunc-por 75 76 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
))
( "::" calcFunc-condition 45 46 )))
(put 'pascal 'math-input-filter 'calc-input-case-filter)
(put 'pascal 'math-output-filter 'calc-output-case-filter)
@ -194,8 +183,7 @@
(cond ((or (null calc-language-option) (= calc-language-option 0))
str)
(t
(downcase str)))
)
(downcase str))))
(defun calc-output-case-filter (str)
(cond ((or (null calc-language-option) (= calc-language-option 0))
@ -203,8 +191,7 @@
((> calc-language-option 0)
(upcase str))
(t
(downcase str)))
)
(downcase str))))
(defun calc-fortran-language (n)
@ -216,8 +203,7 @@
(if (> n 0)
"FORTRAN language mode (all uppercase)."
"FORTRAN language mode (all lowercase).")
"FORTRAN language mode.")))
)
"FORTRAN language mode."))))
(put 'fortran 'math-oper-table
'( ( "u/" (math-parse-fortran-vector) -1 1 )
@ -243,8 +229,7 @@
( "|||" calcFunc-por 75 76 )
( "=" calcFunc-assign 51 50 )
( ":=" calcFunc-assign 51 50 )
( "::" calcFunc-condition 45 46 )
))
( "::" calcFunc-condition 45 46 )))
(put 'fortran 'math-vector-brackets "//")
@ -261,8 +246,7 @@
( conjg . calcFunc-conj )
( log . calcFunc-ln )
( nint . calcFunc-round )
( real . calcFunc-re )
))
( real . calcFunc-re )))
(put 'fortran 'math-input-filter 'calc-input-case-filter)
(put 'fortran 'math-output-filter 'calc-output-case-filter)
@ -272,8 +256,7 @@
(prog1
(math-read-brackets t "]")
(setq exp-token (car math-parsing-fortran-vector)
exp-data (cdr math-parsing-fortran-vector))))
)
exp-data (cdr math-parsing-fortran-vector)))))
(defun math-parse-fortran-vector-end (x op)
(if math-parsing-fortran-vector
@ -282,8 +265,7 @@
exp-token 'end
exp-data "\000")
x)
(throw 'syntax "Unmatched closing `/'"))
)
(throw 'syntax "Unmatched closing `/'")))
(setq math-parsing-fortran-vector nil)
(defun math-parse-fortran-subscr (sym args)
@ -291,8 +273,7 @@
(while args
(setq sym (list 'calcFunc-subscr sym (car args))
args (cdr args)))
sym
)
sym)
(defun calc-tex-language (n)
@ -304,8 +285,7 @@
(if (> n 0)
"TeX language mode with \\hbox{func}(\\hbox{var})."
"TeX language mode with \\func{\\hbox{var}}.")
"TeX language mode.")))
)
"TeX language mode."))))
(put 'tex 'math-oper-table
'( ( "u+" ident -1 1000 )
@ -360,8 +340,7 @@
( "\\to" calcFunc-evalto 40 41 )
( "\\to" calcFunc-evalto 40 -1 )
( "=>" calcFunc-evalto 40 41 )
( "=>" calcFunc-evalto 40 -1 )
))
( "=>" calcFunc-evalto 40 -1 )))
(put 'tex 'math-function-table
'( ( \\arccos . calcFunc-arccos )
@ -383,8 +362,7 @@
( \\sqrt . calcFunc-sqrt )
( \\tanh . calcFunc-tanh )
( \\phi . calcFunc-totient )
( \\mu . calcFunc-moebius )
))
( \\mu . calcFunc-moebius )))
(put 'tex 'math-variable-table
'( ( \\pi . var-pi )
@ -393,8 +371,7 @@
( \\phi . var-phi )
( \\gamma . var-gamma )
( \\sum . (math-parse-tex-sum calcFunc-sum) )
( \\prod . (math-parse-tex-sum calcFunc-prod) )
))
( \\prod . (math-parse-tex-sum calcFunc-prod) )))
(put 'tex 'math-complex-format 'i)
@ -411,15 +388,13 @@
(or (equal exp-data "^") (throw 'syntax "Expected `^'"))
(math-read-token)
(setq high (math-read-factor))
(list (nth 2 f) (math-read-factor) (nth 1 low) (nth 2 low) high))
)
(list (nth 2 f) (math-read-factor) (nth 1 low) (nth 2 low) high)))
(defun math-tex-input-filter (str) ; allow parsing of 123\,456\,789.
(while (string-match "[0-9]\\\\,[0-9]" str)
(setq str (concat (substring str 0 (1+ (match-beginning 0)))
(substring str (1- (match-end 0))))))
str
)
str)
(put 'tex 'math-input-filter 'math-tex-input-filter)
@ -427,8 +402,7 @@
(interactive "P")
(calc-wrapper
(calc-set-language 'eqn)
(message "Eqn language mode."))
)
(message "Eqn language mode.")))
(put 'eqn 'math-oper-table
'( ( "u+" ident -1 1000 )
@ -482,8 +456,7 @@
( "->" calcFunc-evalto 40 41 )
( "->" calcFunc-evalto 40 -1 )
( "=>" calcFunc-evalto 40 41 )
( "=>" calcFunc-evalto 40 -1 )
))
( "=>" calcFunc-evalto 40 -1 )))
(put 'eqn 'math-function-table
'( ( arc\ cos . calcFunc-arccos )
@ -495,12 +468,10 @@
( GAMMA . calcFunc-gamma )
( phi . calcFunc-totient )
( mu . calcFunc-moebius )
( matrix . (math-parse-eqn-matrix) )
))
( matrix . (math-parse-eqn-matrix) )))
(put 'eqn 'math-variable-table
'( ( inf . var-uinf )
))
'( ( inf . var-uinf )))
(put 'eqn 'math-complex-format 'i)
@ -518,8 +489,7 @@
(or (equal exp-data calc-function-close)
(throw 'syntax "Expected `}'"))
(math-read-token)
(math-transpose (cons 'vec (nreverse vec))))
)
(math-transpose (cons 'vec (nreverse vec)))))
(defun math-parse-eqn-prime (x sym)
(if (eq (car-safe x) 'var)
@ -538,16 +508,14 @@
(list 'var
(intern (concat (symbol-name (nth 1 x)) "'"))
(intern (concat (symbol-name (nth 2 x)) "'"))))
(list 'calcFunc-Prime x))
)
(list 'calcFunc-Prime x)))
(defun calc-mathematica-language ()
(interactive)
(calc-wrapper
(calc-set-language 'math)
(message "Mathematica language mode."))
)
(message "Mathematica language mode.")))
(put 'math 'math-oper-table
'( ( "[[" (math-read-math-subscr) 250 -1 )
@ -653,16 +621,14 @@
(equal exp-data "]")))
(throw 'syntax "Expected ']]'"))
(math-read-token)
(list 'calcFunc-subscr x idx))
)
(list 'calcFunc-subscr x idx)))
(defun calc-maple-language ()
(interactive)
(calc-wrapper
(calc-set-language 'maple)
(message "Maple language mode."))
)
(message "Maple language mode.")))
(put 'maple 'math-oper-table
'( ( "matrix" ident -1 300 )
@ -732,8 +698,7 @@
(put 'maple 'math-complex-format 'I)
(defun math-read-maple-dots (x op)
(list 'intv 3 x (math-read-expr-level (nth 3 op)))
)
(list 'intv 3 x (math-read-expr-level (nth 3 op))))
@ -1074,8 +1039,7 @@
the-h2 h)
(or short (= the-h2 h2)
(math-read-big-error h baseline))
p))
)
p)))
(defun math-read-big-char (h v)
(or (and (>= h h1)
@ -1086,8 +1050,7 @@
(and line
(< h (length line))
(aref line h))))
?\ )
)
?\ ))
(defun math-read-big-emptyp (eh1 ev1 eh2 ev2 &optional what error)
(and (< ev1 v1) (setq ev1 v1))
@ -1109,8 +1072,7 @@
(< h eh1)))
(setq ev1 (1+ ev1)
p (cdr p)))
(>= ev1 ev2))
)
(>= ev1 ev2)))
(defun math-read-big-error (h v &optional msg)
(let ((pos 0)
@ -1121,8 +1083,7 @@
v (1- v)))
(setq h (+ pos (min h (length (car p))))
err-msg (list 'error h (or msg "Syntax error")))
(throw 'syntax nil))
)
(throw 'syntax nil)))
(defun math-read-big-balance (h v what &optional commas)
(let* ((line (nth v lines))
@ -1143,9 +1104,6 @@
(memq (aref line h) '(?\) ?\])))
(setq count (1- count))))
(setq h (1+ h))))
h)
)
h))
;;; calc-lang.el ends here

102
lisp/calc/calc-macs.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part I [calc-macs.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -32,27 +32,23 @@
(defmacro calc-wrapper (&rest body)
(list 'calc-do (list 'function (append (list 'lambda ()) body)))
)
(list 'calc-do (list 'function (append (list 'lambda ()) body))))
;; We use "point" here to generate slightly smaller byte-code than "t".
(defmacro calc-slow-wrapper (&rest body)
(list 'calc-do (list 'function (append (list 'lambda ()) body)) (point))
)
(list 'calc-do (list 'function (append (list 'lambda ()) body)) (point)))
(defmacro math-showing-full-precision (body)
(list 'let
'((calc-float-format calc-full-float-format))
body)
)
body))
(defmacro math-with-extra-prec (delta &rest body)
(` (math-normalize
(let ((calc-internal-prec (+ calc-internal-prec (, delta))))
(,@ body))))
)
(,@ body)))))
;;; Faster in-line version zerop, normalized values only.
@ -62,20 +58,17 @@
(if (eq (car (, a)) 'float)
(eq (nth 1 (, a)) 0)
(math-zerop (, a))))
(eq (, a) 0)))
)
(eq (, a) 0))))
(defmacro Math-integer-negp (a)
(` (if (consp (, a))
(eq (car (, a)) 'bigneg)
(< (, a) 0)))
)
(< (, a) 0))))
(defmacro Math-integer-posp (a)
(` (if (consp (, a))
(eq (car (, a)) 'bigpos)
(> (, a) 0)))
)
(> (, a) 0))))
(defmacro Math-negp (a)
@ -85,8 +78,7 @@
(if (memq (car (, a)) '(frac float))
(Math-integer-negp (nth 1 (, a)))
(math-negp (, a)))))
(< (, a) 0)))
)
(< (, a) 0))))
(defmacro Math-looks-negp (a) ; [P x] [Public]
@ -94,8 +86,7 @@
(and (consp (, a)) (or (eq (car (, a)) 'neg)
(and (memq (car (, a)) '(* /))
(or (math-looks-negp (nth 1 (, a)))
(math-looks-negp (nth 2 (, a)))))))))
)
(math-looks-negp (nth 2 (, a))))))))))
(defmacro Math-posp (a)
@ -105,69 +96,57 @@
(if (memq (car (, a)) '(frac float))
(Math-integer-posp (nth 1 (, a)))
(math-posp (, a)))))
(> (, a) 0)))
)
(> (, a) 0))))
(defmacro Math-integerp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg))))
)
(memq (car (, a)) '(bigpos bigneg)))))
(defmacro Math-natnump (a)
(` (if (consp (, a))
(eq (car (, a)) 'bigpos)
(>= (, a) 0)))
)
(>= (, a) 0))))
(defmacro Math-ratp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg frac))))
)
(memq (car (, a)) '(bigpos bigneg frac)))))
(defmacro Math-realp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg frac float))))
)
(memq (car (, a)) '(bigpos bigneg frac float)))))
(defmacro Math-anglep (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg frac float hms))))
)
(memq (car (, a)) '(bigpos bigneg frac float hms)))))
(defmacro Math-numberp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg frac float cplx polar))))
)
(memq (car (, a)) '(bigpos bigneg frac float cplx polar)))))
(defmacro Math-scalarp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg frac float cplx polar hms))))
)
(memq (car (, a)) '(bigpos bigneg frac float cplx polar hms)))))
(defmacro Math-vectorp (a)
(` (and (consp (, a)) (eq (car (, a)) 'vec)))
)
(` (and (consp (, a)) (eq (car (, a)) 'vec))))
(defmacro Math-messy-integerp (a)
(` (and (consp (, a))
(eq (car (, a)) 'float)
(>= (nth 2 (, a)) 0)))
)
(>= (nth 2 (, a)) 0))))
(defmacro Math-objectp (a) ; [Public]
(` (or (not (consp (, a)))
(memq (car (, a))
'(bigpos bigneg frac float cplx polar hms date sdev intv mod))))
)
'(bigpos bigneg frac float cplx polar hms date sdev intv mod)))))
(defmacro Math-objvecp (a) ; [Public]
(` (or (not (consp (, a)))
(memq (car (, a))
'(bigpos bigneg frac float cplx polar hms date
sdev intv mod vec))))
)
sdev intv mod vec)))))
;;; Compute the negative of A. [O O; o o] [Public]
@ -176,38 +155,32 @@
(if (eq (car (, a)) 'bigpos)
(cons 'bigneg (cdr (, a)))
(cons 'bigpos (cdr (, a))))
(- (, a))))
)
(- (, a)))))
(defmacro Math-equal (a b)
(` (= (math-compare (, a) (, b)) 0))
)
(` (= (math-compare (, a) (, b)) 0)))
(defmacro Math-lessp (a b)
(` (= (math-compare (, a) (, b)) -1))
)
(` (= (math-compare (, a) (, b)) -1)))
(defmacro math-working (msg arg) ; [Public]
(` (if (eq calc-display-working-message 'lots)
(math-do-working (, msg) (, arg))))
)
(math-do-working (, msg) (, arg)))))
(defmacro calc-with-default-simplification (body)
(list 'let
'((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num)))
calc-simplify-mode)))
body)
)
body))
(defmacro Math-primp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg frac float cplx polar
hms date mod var))))
)
hms date mod var)))))
(defmacro calc-with-trail-buffer (&rest body)
@ -218,23 +191,20 @@
(set-buffer (calc-trail-display t))
(goto-char calc-trail-pointer))
body))
(set-buffer save-buf))))
)
(set-buffer save-buf)))))
(defmacro Math-num-integerp (a)
(` (or (not (consp (, a)))
(memq (car (, a)) '(bigpos bigneg))
(and (eq (car (, a)) 'float)
(>= (nth 2 (, a)) 0))))
)
(>= (nth 2 (, a)) 0)))))
(defmacro Math-bignum-test (a) ; [B N; B s; b b]
(` (if (consp (, a))
(, a)
(math-bignum (, a))))
)
(math-bignum (, a)))))
(defmacro Math-equal-int (a b)
@ -242,20 +212,18 @@
(and (consp (, a))
(eq (car (, a)) 'float)
(eq (nth 1 (, a)) (, b))
(= (nth 2 (, a)) 0))))
)
(= (nth 2 (, a)) 0)))))
(defmacro Math-natnum-lessp (a b)
(` (if (consp (, a))
(and (consp (, b))
(= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1))
(or (consp (, b))
(< (, a) (, b)))))
)
(< (, a) (, b))))))
(defmacro math-format-radix-digit (a) ; [X D]
(` (aref math-radix-digits (, a)))
)
(` (aref math-radix-digits (, a))))
;;; calc-macs.el ends here

39
lisp/calc/calc-maint.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, maintenance routines
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -42,8 +42,7 @@ Unix usage:
(calc-do-compile))
(fset 'message old-message)
(fset 'write-region old-write-region)))
(calc-do-compile))
)
(calc-do-compile)))
(defun calc-do-compile ()
(let ((make-backup-files nil)
@ -133,8 +132,7 @@ Unix usage:
(sort rules 'string<))
(save-buffer))))
(error (message "Unable to pre-build tables %s" err))))
(message "Done. Don't forget to install with \"make public\" or \"make private\"."))
)
(message "Done. Don't forget to install with \"make public\" or \"make private\".")))
(defun calc-compile-message (fmt &rest args)
(cond ((and (= (length args) 2)
@ -166,8 +164,7 @@ Unix usage:
(send-string-to-terminal (apply 'format fmt args)))
((string-match "\\(Preparing\\|Building\\).*\\.\\.\\. *done$" fmt)
(send-string-to-terminal "done\n"))
(t (apply old-message fmt args)))
)
(t (apply old-message fmt args))))
(defun calc-compile-write-region (start end filename &optional append visit &rest rest)
(if (eq visit t)
@ -182,8 +179,7 @@ Unix usage:
(setq end (point-max))))
(apply old-write-region start end filename append 'quietly rest)
(message "Wrote %s" filename)
nil
)
nil)
@ -241,8 +237,7 @@ Usage: C-x C-f calc.texinfo RET
(goto-char 1))
(message (cond ((eq part 1) "Wrote file calctut.tex")
((eq part 2) "Wrote file calcref.tex")
(t "Wrote files calctut.tex and calcref.tex")))
)
(t "Wrote files calctut.tex and calcref.tex"))))
(defun calc-split-volume (number fix name other-name)
(goto-char 1)
@ -270,14 +265,12 @@ Usage: C-x C-f calc.texinfo RET
(while (search-forward "@c [not-split]\n" nil t)
(while (not (looking-at "@c"))
(insert "@c ")
(forward-line 1)))
)
(forward-line 1))))
(defun calc-inline-summary ()
"Make a special \"calcsum.tex\" file to be used with main manual."
(calc-split-summary nil t)
)
(calc-split-summary nil t))
(defun calc-split-summary (&optional force in-line)
"Make a special \"calcsum.tex\" file with just the Calc summary."
@ -392,8 +385,7 @@ Usage: C-x C-f calc.texinfo RET
"Unable to find Key Index (calc.ky); no page numbers inserted"))
(switch-to-buffer buf))
(save-buffer))
(message "Wrote file calcsum.tex")
)
(message "Wrote file calcsum.tex"))
@ -414,8 +406,7 @@ global-set-key commands for Calc."
(find-file name)
(if buffer-read-only (error "No write permission for \"%s\"" buffer-file-name))
(goto-char (point-max))
(calc-add-autoloads home "calc-public-autoloads"))
)
(calc-add-autoloads home "calc-public-autoloads")))
(defun calc-private-autoloads ()
"Modify the user's \".emacs\" file to contain the necessary autoload and
@ -424,8 +415,7 @@ global-set-key commands for Calc."
(let ((home default-directory))
(find-file "~/.emacs")
(goto-char (point-max))
(calc-add-autoloads home "calc-private-autoloads"))
)
(calc-add-autoloads home "calc-private-autoloads")))
(defun calc-add-autoloads (home cmd)
(barf-if-buffer-read-only)
@ -458,9 +448,6 @@ global-set-key commands for Calc."
\(global-set-key \"\\e#\" 'calc-dispatch)
;;; End of Calc autoloads.\n")
(let ((trim-versions-without-asking t))
(save-buffer))
)
(save-buffer)))
;;; End.
;;; calc-maint.el ends here

142
lisp/calc/calc-map.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-map.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -48,8 +48,7 @@
(nth 2 oper))
(list 'calcFunc-apply
(math-calcFunc-to-var (nth 1 oper))
expr))))
)
expr)))))
(defun calc-reduce (&optional oper accum)
(interactive)
@ -91,13 +90,11 @@
"reduce"
calc-mapping-dir)))
(math-calcFunc-to-var (nth 1 oper))
(calc-top-n (1+ calc-dollar-used)))))))
)
(calc-top-n (1+ calc-dollar-used))))))))
(defun calc-accumulate (&optional oper)
(interactive)
(calc-reduce oper t)
)
(calc-reduce oper t))
(defun calc-map (&optional oper)
(interactive)
@ -118,8 +115,7 @@
(cons (math-calcFunc-to-var (nth 1 oper))
(calc-top-list-n
nargs
(1+ calc-dollar-used)))))))
)
(1+ calc-dollar-used))))))))
(defun calc-map-equation (&optional oper)
(interactive)
@ -142,16 +138,14 @@
(cons (math-calcFunc-to-var (nth 1 oper))
(calc-top-list-n
nargs
(1+ calc-dollar-used)))))))
)
(1+ calc-dollar-used))))))))
(defun calc-map-stack ()
"This is meant to be called by calc-keypad mode."
(interactive)
(let ((calc-verify-arglist nil))
(calc-unread-command ?\$)
(calc-map))
)
(calc-map)))
(defun calc-outer-product (&optional oper)
(interactive)
@ -169,8 +163,7 @@
(cons 'calcFunc-outer
(cons (math-calcFunc-to-var (nth 1 oper))
(calc-top-list-n
2 (1+ calc-dollar-used)))))))
)
2 (1+ calc-dollar-used))))))))
(defun calc-inner-product (&optional mul-oper add-oper)
(interactive)
@ -196,8 +189,7 @@
(math-calcFunc-to-var (nth 1 mul-oper))
(math-calcFunc-to-var (nth 1 add-oper)))
(calc-top-list-n
2 (+ 1 mul-used calc-dollar-used))))))
)
2 (+ 1 mul-used calc-dollar-used)))))))
;;; Return a list of the form (nargs func name)
(defun calc-get-operator (msg &optional nargs)
@ -448,8 +440,7 @@
(char-to-string key))))
(if (> (length name) 3)
(substring name 0 3)
name)))))
)
name))))))
(setq calc-verify-arglist t)
(setq calc-mapping-dir nil)
@ -763,8 +754,7 @@
(intern (concat "calcFunc-" (symbol-name (nth 1 f)))))
(if (memq (car-safe f) '(lambda calcFunc-lambda))
f
(math-reject-arg f "*Expected a function name")))
)
(math-reject-arg f "*Expected a function name"))))
;;; Convert a function name into a like-looking variable name formula.
(defun math-calcFunc-to-var (f)
@ -785,8 +775,7 @@
(list 'var
(intern base)
(intern (concat "var-" base))))
f)
)
f))
;;; Expand a function call using "lambda" notation.
(defun math-build-call (f args)
@ -807,8 +796,7 @@
( calcFunc-vconcat . | ) ))))
(if (and func (= (length args) 2))
(cons (cdr func) args)
(cons f args)))))
)
(cons f args))))))
;;; Do substitutions in parallel to avoid crosstalk.
(defun math-multi-subst (expr olds news)
@ -818,8 +806,7 @@
(setq args (cons (cons (car olds) (car news)) args)
olds (cdr olds)
news (cdr news)))
(math-multi-subst-rec expr))
)
(math-multi-subst-rec expr)))
(defun math-multi-subst-rec (expr)
(cond ((setq temp (assoc expr args)) (cdr temp))
@ -834,21 +821,18 @@
(nreverse (cons (math-multi-subst-rec (car expr)) new))))
(t
(cons (car expr)
(mapcar 'math-multi-subst-rec (cdr expr)))))
)
(mapcar 'math-multi-subst-rec (cdr expr))))))
(defun calcFunc-call (f &rest args)
(setq args (math-build-call (math-var-to-calcFunc f) args))
(if (eq (car-safe args) 'calcFunc-call)
args
(math-normalize args))
)
(math-normalize args)))
(defun calcFunc-apply (f args)
(or (Math-vectorp args)
(math-reject-arg args 'vectorp))
(apply 'calcFunc-call (cons f (cdr args)))
)
(apply 'calcFunc-call (cons f (cdr args))))
@ -928,32 +912,26 @@
(setq vec (cons head (nreverse vec)))
(if (and (eq mode 'cols) (math-matrixp vec))
(math-transpose vec)
vec))
)
vec)))
(defun calcFunc-map (func &rest args)
(math-symb-map func 'elems args)
)
(math-symb-map func 'elems args))
(defun calcFunc-mapr (func &rest args)
(math-symb-map func 'rows args)
)
(math-symb-map func 'rows args))
(defun calcFunc-mapc (func &rest args)
(math-symb-map func 'cols args)
)
(math-symb-map func 'cols args))
(defun calcFunc-mapa (func arg)
(if (math-matrixp arg)
(math-symb-map func 'elems (cdr (math-transpose arg)))
(math-symb-map func 'elems arg))
)
(math-symb-map func 'elems arg)))
(defun calcFunc-mapd (func arg)
(if (math-matrixp arg)
(math-symb-map func 'elems (cdr arg))
(math-symb-map func 'elems arg))
)
(math-symb-map func 'elems arg)))
(defun calcFunc-mapeq (func &rest args)
(if (and (or (equal func '(var mul var-mul))
@ -974,8 +952,7 @@
(equal func '(var neg var-neg))
(equal func '(var inv var-inv)))
(apply 'calcFunc-mapeqr func args)
(apply 'calcFunc-mapeqp func args))
)
(apply 'calcFunc-mapeqp func args)))
(defun calcFunc-mapeqr (func &rest args)
(setq args (mapcar (function (lambda (x)
@ -985,8 +962,7 @@
(cons (nth 1 func) (cdr x))
x))))
args))
(apply 'calcFunc-mapeqp func args)
)
(apply 'calcFunc-mapeqp func args))
(defun calcFunc-mapeqp (func &rest args)
(if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq))
@ -999,8 +975,7 @@
(nth 2 (nth 1 args))
(nth 1 (nth 1 args)))
(cdr (cdr args))))))
(math-symb-map func 'eqn args)
)
(math-symb-map func 'eqn args))
@ -1019,8 +994,7 @@
(math-build-call func (list expr (car row))))
(car row)))))
(math-normalize expr))
(calcFunc-reducer func vec))
)
(calcFunc-reducer func vec)))
(defun calcFunc-rreduce (func vec)
(if (math-matrixp vec)
@ -1036,8 +1010,7 @@
row (cdr row)))
(setq vec (cdr vec)))
(math-normalize expr))
(calcFunc-rreducer func vec))
)
(calcFunc-rreducer func vec)))
(defun calcFunc-reducer (func vec)
(setq func (math-var-to-calcFunc func))
@ -1066,8 +1039,7 @@
(setq expr (math-build-call func (list expr (car vec)))))
(math-normalize expr))
(or (math-identity-value func)
(math-reject-arg vec "*Vector is empty"))))
)
(math-reject-arg vec "*Vector is empty")))))
(defun math-identity-value (func)
(cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0)
@ -1076,8 +1048,7 @@
(calcFunc-min . (var inf var-inf))
(calcFunc-max . (neg (var inf var-inf)))
(calcFunc-vconcat . (vec))
(calcFunc-append . (vec)) )))
)
(calcFunc-append . (vec)) ))))
(defun calcFunc-rreducer (func vec)
(setq func (math-var-to-calcFunc func))
@ -1100,52 +1071,45 @@
(setq expr (math-build-call func (list (car vec) expr))))
(math-normalize expr))
(or (math-identity-value func)
(math-reject-arg vec "*Vector is empty")))))
)
(math-reject-arg vec "*Vector is empty"))))))
(defun calcFunc-reducec (func vec)
(if (math-matrixp vec)
(calcFunc-reducer func (math-transpose vec))
(calcFunc-reducer func vec))
)
(calcFunc-reducer func vec)))
(defun calcFunc-rreducec (func vec)
(if (math-matrixp vec)
(calcFunc-rreducer func (math-transpose vec))
(calcFunc-rreducer func vec))
)
(calcFunc-rreducer func vec)))
(defun calcFunc-reducea (func vec)
(if (math-matrixp vec)
(cons 'vec
(mapcar (function (lambda (x) (calcFunc-reducer func x)))
(cdr vec)))
(calcFunc-reducer func vec))
)
(calcFunc-reducer func vec)))
(defun calcFunc-rreducea (func vec)
(if (math-matrixp vec)
(cons 'vec
(mapcar (function (lambda (x) (calcFunc-rreducer func x)))
(cdr vec)))
(calcFunc-rreducer func vec))
)
(calcFunc-rreducer func vec)))
(defun calcFunc-reduced (func vec)
(if (math-matrixp vec)
(cons 'vec
(mapcar (function (lambda (x) (calcFunc-reducer func x)))
(cdr (math-transpose vec))))
(calcFunc-reducer func vec))
)
(calcFunc-reducer func vec)))
(defun calcFunc-rreduced (func vec)
(if (math-matrixp vec)
(cons 'vec
(mapcar (function (lambda (x) (calcFunc-rreducer func x)))
(cdr (math-transpose vec))))
(calcFunc-rreducer func vec))
)
(calcFunc-rreducer func vec)))
(defun calcFunc-accum (func vec)
(setq func (math-var-to-calcFunc func))
@ -1158,8 +1122,7 @@
(while (setq vec (cdr vec))
(setq expr (math-build-call func (list expr (car vec)))
res (nconc res (list expr))))
(math-normalize res))
)
(math-normalize res)))
(defun calcFunc-raccum (func vec)
(setq func (math-var-to-calcFunc func))
@ -1172,8 +1135,7 @@
(while (setq vec (cdr vec))
(setq expr (math-build-call func (list (car vec) expr))
res (cons (list expr) res)))
(math-normalize (cons 'vec res)))
)
(math-normalize (cons 'vec res))))
(defun math-nest-calls (func base iters accum tol)
@ -1226,24 +1188,19 @@
(setq avalues (cons value avalues))))
(if accum
(cons 'vec (nreverse avalues))
value)))
)
value))))
(defun calcFunc-nest (func base iters)
(math-nest-calls func base iters nil nil)
)
(math-nest-calls func base iters nil nil))
(defun calcFunc-anest (func base iters)
(math-nest-calls func base iters t nil)
)
(math-nest-calls func base iters t nil))
(defun calcFunc-fixp (func base &optional iters tol)
(math-nest-calls func base iters nil (or tol t))
)
(math-nest-calls func base iters nil (or tol t)))
(defun calcFunc-afixp (func base &optional iters tol)
(math-nest-calls func base iters t (or tol t))
)
(math-nest-calls func base iters t (or tol t)))
(defun calcFunc-outer (func a b)
@ -1259,8 +1216,7 @@
x))))
(cdr b)))
mat)))
(math-normalize (cons 'vec (nreverse mat))))
)
(math-normalize (cons 'vec (nreverse mat)))))
(defun calcFunc-inner (mul-func add-func a b)
@ -1281,8 +1237,7 @@
(math-dimension-error))))
(if (math-matrixp b)
(nth 1 (math-inner-mats (list 'vec a) b))
(calcFunc-reduce add-func (calcFunc-map mul-func a b))))
)
(calcFunc-reduce add-func (calcFunc-map mul-func a b)))))
(defun math-inner-mats (a b)
(let ((mat nil)
@ -1298,8 +1253,7 @@
(math-mat-col b col)))
row)))
(setq mat (cons (cons 'vec row) mat)))
(cons 'vec (nreverse mat)))
)
(cons 'vec (nreverse mat))))
;;; calc-map.el ends here

154
lisp/calc/calc-mode.el
View File

@ -34,8 +34,7 @@
(calc-wrapper
(message (if (calc-change-mode 'calc-line-numbering n t t)
"Displaying stack level numbers."
"Hiding stack level numbers.")))
)
"Hiding stack level numbers."))))
(defun calc-line-breaking (n)
(interactive "P")
@ -49,8 +48,7 @@
(if (integerp calc-line-breaking)
(message "Breaking lines longer than %d characters." n)
(message "Breaking long lines in Stack display."))
(message "Not breaking long lines in Stack display.")))
)
(message "Not breaking long lines in Stack display."))))
(defun calc-left-justify (n)
@ -61,8 +59,7 @@
(list nil n) t)
(if n
(message "Displaying stack entries indented by %d." n)
(message "Displaying stack entries left-justified.")))
)
(message "Displaying stack entries left-justified."))))
(defun calc-center-justify (n)
(interactive "P")
@ -72,8 +69,7 @@
(list 'center n) t)
(if n
(message "Displaying stack entries centered on column %d." n)
(message "Displaying stack entries centered in window.")))
)
(message "Displaying stack entries centered in window."))))
(defun calc-right-justify (n)
(interactive "P")
@ -83,24 +79,21 @@
(list 'right n) t)
(if n
(message "Displaying stack entries right-justified to column %d." n)
(message "Displaying stack entries right-justified in window.")))
)
(message "Displaying stack entries right-justified in window."))))
(defun calc-left-label (s)
(interactive "sLefthand label: ")
(calc-wrapper
(or (equal s "")
(setq s (concat s " ")))
(calc-change-mode 'calc-left-label s t))
)
(calc-change-mode 'calc-left-label s t)))
(defun calc-right-label (s)
(interactive "sRighthand label: ")
(calc-wrapper
(or (equal s "")
(setq s (concat " " s)))
(calc-change-mode 'calc-right-label s t))
)
(calc-change-mode 'calc-right-label s t)))
(defun calc-auto-why (n)
(interactive "P")
@ -117,8 +110,7 @@
((eq n t)
(message "Automatically doing `w' to explain unsimplified results."))
(t
(message "Automatically doing `w' only for unusual messages."))))
)
(message "Automatically doing `w' only for unusual messages.")))))
(defun calc-group-digits (n)
(interactive "P")
@ -138,8 +130,7 @@
((integerp n)
(message "Grouping every %d digits." (math-abs n)))
(t
(message "Grouping is on."))))
)
(message "Grouping is on.")))))
(defun calc-group-char (ch)
(interactive "cGrouping character: ")
@ -150,8 +141,7 @@
(setq ch "\\,")
(setq ch (char-to-string ch)))
(calc-change-mode 'calc-group-char ch calc-group-digits)
(message "Digit grouping character is \"%s\"." ch))
)
(message "Digit grouping character is \"%s\"." ch)))
(defun calc-point-char (ch)
(interactive "cCharacter to use as decimal point: ")
@ -159,8 +149,7 @@
(or (>= ch 32)
(error "Control characters not allowed as decimal point."))
(calc-change-mode 'calc-point-char (char-to-string ch) t)
(message "Decimal point character is \"%c\"." ch))
)
(message "Decimal point character is \"%c\"." ch)))
(defun calc-normal-notation (n)
(interactive "P")
@ -180,8 +169,7 @@
"Displaying floating-point numbers with %d significant digits."
(nth 1 n))
(message "Displaying floating-point numbers with (precision%d)."
(nth 1 n)))))
)
(nth 1 n))))))
(defun calc-fix-notation (n)
(interactive "NDigits after decimal point: ")
@ -190,8 +178,7 @@
(setq n (list 'fix (if n (prefix-numeric-value n) 0)))
t)
(message "Displaying floats with %d digits after decimal."
(math-abs (nth 1 n))))
)
(math-abs (nth 1 n)))))
(defun calc-sci-notation (n)
(interactive "P")
@ -205,8 +192,7 @@
(message "Displaying scientific notation with %d significant digits."
(nth 1 n))
(message "Displaying scientific notation with (precision%d)."
(nth 1 n)))))
)
(nth 1 n))))))
(defun calc-eng-notation (n)
(interactive "P")
@ -220,8 +206,7 @@
(message "Displaying engineering notation with %d significant digits."
(nth 1 n))
(message "Displaying engineering notation with (precision%d)."
(nth 1 n)))))
)
(nth 1 n))))))
(defun calc-truncate-stack (n &optional rel)
@ -253,18 +238,15 @@
(if calc-line-numbering
(calc-refresh))))
(calc-record-undo (list 'set 'saved-stack-top 0))
(setq calc-stack-top newtop)))
)
(setq calc-stack-top newtop))))
(defun calc-truncate-up (n)
(interactive "p")
(calc-truncate-stack n t)
)
(calc-truncate-stack n t))
(defun calc-truncate-down (n)
(interactive "p")
(calc-truncate-stack (- n) t)
)
(calc-truncate-stack (- n) t))
(defun calc-display-raw (arg)
(interactive "P")
@ -272,8 +254,7 @@
(setq calc-display-raw (if calc-display-raw nil (if arg 0 t)))
(calc-do-refresh)
(if calc-display-raw
(message "Press d ' again to cancel \"raw\" display mode.")))
)
(message "Press d ' again to cancel \"raw\" display mode."))))
@ -323,8 +304,7 @@
;; FIXME: why is this here? -cgw 2001.11.12
(let ((executing-kbd-macro "")) ; what a kludge!
(save-buffer))
(save-buffer))))
)
(save-buffer)))))
(defun calc-settings-file-name (name &optional arg)
(interactive
@ -381,8 +361,7 @@
(t 1))
(cond ((eq calc-infinite-mode 1) 0)
(calc-infinite-mode 1)
(t -1)))
)
(t -1))))
(defun calc-get-modes (n)
(interactive "P")
@ -394,8 +373,7 @@
(< n (length modes)))
(nth n modes)
(error "Prefix out of range"))
modes))))
)
modes)))))
(defun calc-shift-prefix (arg)
(interactive "P")
@ -406,8 +384,7 @@
(calc-init-prefixes)
(message (if calc-shift-prefix
"Prefix keys are now case-insensitive"
"Prefix keys must be unshifted (except V, Z)")))
)
"Prefix keys must be unshifted (except V, Z)"))))
(defun calc-mode-record-mode (n)
(interactive "P")
@ -441,8 +418,7 @@
(format "Recording mode changes in \"%s\"."
calc-settings-file))
(t
"Not recording mode changes permanently."))))
)
"Not recording mode changes permanently.")))))
(defun calc-total-algebraic-mode (flag)
(interactive "P")
@ -455,8 +431,7 @@
'(total nil))
(use-local-map calc-alg-map)
(message
"All keys begin algebraic entry; use Meta (ESC) for Calc keys.")))
)
"All keys begin algebraic entry; use Meta (ESC) for Calc keys."))))
(defun calc-algebraic-mode (flag)
(interactive "P")
@ -472,8 +447,7 @@
"Numeric keys and ( and [ begin algebraic entry."
(if calc-incomplete-algebraic-mode
"Only ( and [ begin algebraic entry."
"No keys except ' and $ begin algebraic entry."))))
)
"No keys except ' and $ begin algebraic entry.")))))
(defun calc-symbolic-mode (n)
(interactive "P")
@ -481,8 +455,7 @@
(message (if (calc-change-mode 'calc-symbolic-mode n nil t)
"Inexact computations like sqrt(2) are deferred."
"Numerical computations are always done immediately.")))
)
"Numerical computations are always done immediately."))))
(defun calc-infinite-mode (n)
(interactive "P")
@ -493,8 +466,7 @@
(message "Computations like 1 / 0 produce \"inf\"."))
(message (if (calc-change-mode 'calc-infinite-mode n nil t)
"Computations like 1 / 0 produce \"uinf\"."
"Computations like 1 / 0 are left unsimplified."))))
)
"Computations like 1 / 0 are left unsimplified.")))))
(defun calc-matrix-mode (arg)
(interactive "P")
@ -514,8 +486,7 @@
"Variables are assumed to be matrices."
(if calc-matrix-mode
"Variables are assumed to be scalars (non-matrices)."
"Variables are not assumed to be matrix or scalar.")))))
)
"Variables are not assumed to be matrix or scalar."))))))
(defun calc-set-simplify-mode (mode arg msg)
(calc-change-mode 'calc-simplify-mode
@ -526,22 +497,19 @@
mode)))
(message (if (eq calc-simplify-mode mode)
msg
"Default simplifications enabled."))
)
"Default simplifications enabled.")))
(defun calc-no-simplify-mode (arg)
(interactive "P")
(calc-wrapper
(calc-set-simplify-mode 'none arg
"All default simplifications are disabled."))
)
"All default simplifications are 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."))
)
"Default simplifications apply only if arguments are numeric.")))
(defun calc-default-simplify-mode (arg)
(interactive "p")
@ -555,37 +523,32 @@
((= 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")))
)
(t (error "Prefix argument out of range"))))
(defun calc-bin-simplify-mode (arg)
(interactive "P")
(calc-wrapper
(calc-set-simplify-mode 'binary arg
(format "Binary simplification occurs by default (word size=%d)."
calc-word-size)))
)
calc-word-size))))
(defun calc-alg-simplify-mode (arg)
(interactive "P")
(calc-wrapper
(calc-set-simplify-mode 'alg arg
"Algebraic simplification occurs by default."))
)
"Algebraic simplification occurs by default.")))
(defun calc-ext-simplify-mode (arg)
(interactive "P")
(calc-wrapper
(calc-set-simplify-mode 'ext arg
"Extended algebraic simplification occurs by default."))
)
"Extended algebraic simplification occurs by default.")))
(defun calc-units-simplify-mode (arg)
(interactive "P")
(calc-wrapper
(calc-set-simplify-mode 'units arg
"Units simplification occurs by default."))
)
"Units simplification occurs by default.")))
(defun calc-auto-recompute (arg)
(interactive "P")
@ -594,8 +557,7 @@
(calc-refresh-evaltos)
(message (if calc-auto-recompute
"Automatically recomputing `=>' forms when necessary."
"Not recomputing `=>' forms automatically.")))
)
"Not recomputing `=>' forms automatically."))))
(defun calc-working (n)
(interactive "P")
@ -613,70 +575,61 @@
(calc-display-working-message
(message "Detailed \"Working...\" messages enabled."))
(t
(message "\"Working...\" messages disabled."))))
)
(message "\"Working...\" messages disabled.")))))
(defun calc-always-load-extensions ()
(interactive)
(calc-wrapper
(if (setq calc-always-load-extensions (not calc-always-load-extensions))
(message "Always loading extensions package.")
(message "Loading extensions package on demand only.")))
)
(message "Loading extensions package on demand only."))))
(defun calc-matrix-left-justify ()
(interactive)
(calc-wrapper
(calc-change-mode 'calc-matrix-just nil t)
(message "Matrix elements will be left-justified in columns."))
)
(message "Matrix elements will be left-justified in columns.")))
(defun calc-matrix-center-justify ()
(interactive)
(calc-wrapper
(calc-change-mode 'calc-matrix-just 'center t)
(message "Matrix elements will be centered in columns."))
)
(message "Matrix elements will be centered in columns.")))
(defun calc-matrix-right-justify ()
(interactive)
(calc-wrapper
(calc-change-mode 'calc-matrix-just 'right t)
(message "Matrix elements will be right-justified in columns."))
)
(message "Matrix elements will be right-justified in columns.")))
(defun calc-full-vectors (n)
(interactive "P")
(calc-wrapper
(message (if (calc-change-mode 'calc-full-vectors n t t)
"Displaying long vectors in full."
"Displaying long vectors in [a, b, c, ..., z] notation.")))
)
"Displaying long vectors in [a, b, c, ..., z] notation."))))
(defun calc-full-trail-vectors (n)
(interactive "P")
(calc-wrapper
(message (if (calc-change-mode 'calc-full-trail-vectors n nil t)
"Recording long vectors in full."
"Recording long vectors in [a, b, c, ..., z] notation.")))
)
"Recording long vectors in [a, b, c, ..., z] notation."))))
(defun calc-break-vectors (n)
(interactive "P")
(calc-wrapper
(message (if (calc-change-mode 'calc-break-vectors n t t)
"Displaying vector elements one-per-line."
"Displaying vector elements all on one line.")))
)
"Displaying vector elements all on one line."))))
(defun calc-vector-commas ()
(interactive)
(calc-wrapper
(if (calc-change-mode 'calc-vector-commas (if calc-vector-commas nil ",") t)
(message "Separating vector elements with \",\".")
(message "Separating vector elements with spaces.")))
)
(message "Separating vector elements with spaces."))))
(defun calc-vector-brackets ()
(interactive)
@ -684,8 +637,7 @@
(if (calc-change-mode 'calc-vector-brackets
(if (equal calc-vector-brackets "[]") nil "[]") t)
(message "Surrounding vectors with \"[]\".")
(message "Not surrounding vectors with brackets.")))
)
(message "Not surrounding vectors with brackets."))))
(defun calc-vector-braces ()
(interactive)
@ -693,8 +645,7 @@
(if (calc-change-mode 'calc-vector-brackets
(if (equal calc-vector-brackets "{}") nil "{}") t)
(message "Surrounding vectors with \"{}\".")
(message "Not surrounding vectors with brackets.")))
)
(message "Not surrounding vectors with brackets."))))
(defun calc-vector-parens ()
(interactive)
@ -702,8 +653,7 @@
(if (calc-change-mode 'calc-vector-brackets
(if (equal calc-vector-brackets "()") nil "()") t)
(message "Surrounding vectors with \"()\".")
(message "Not surrounding vectors with brackets.")))
)
(message "Not surrounding vectors with brackets."))))
(defun calc-matrix-brackets (arg)
(interactive "sCode letters (R, O, C, P): ")
@ -715,6 +665,6 @@
(bad (string-match "[^rRoOcCpP ]" arg)))
(if bad
(error "Unrecognized character: %c" (aref arg bad)))
(calc-change-mode 'calc-matrix-brackets code t)))
)
(calc-change-mode 'calc-matrix-brackets code t))))
;;; calc-mode.el ends here

57
lisp/calc/calc-mtx.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-mat.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -32,20 +32,17 @@
(defun calc-mdet (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "mdet" 'calcFunc-det arg))
)
(calc-unary-op "mdet" 'calcFunc-det arg)))
(defun calc-mtrace (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "mtr" 'calcFunc-tr arg))
)
(calc-unary-op "mtr" 'calcFunc-tr arg)))
(defun calc-mlud (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "mlud" 'calcFunc-lud arg))
)
(calc-unary-op "mlud" 'calcFunc-lud arg)))
;;; Coerce row vector A to be a matrix. [V V]
@ -53,16 +50,14 @@
(if (and (Math-vectorp a)
(not (math-matrixp a)))
(list 'vec a)
a)
)
a))
;;; Coerce column vector A to be a matrix. [V V]
(defun math-col-matrix (a)
(if (and (Math-vectorp a)
(not (math-matrixp a)))
(cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a)))
a)
)
a))
@ -82,29 +77,25 @@
(setq accum (math-add accum (math-mul (car ap) (nth col (car bp))))))
(setq row (cons accum row)))
(setq mat (cons (cons 'vec row) mat)))
(cons 'vec (nreverse mat)))
)
(cons 'vec (nreverse mat))))
(defun math-mul-mat-vec (a b)
(cons 'vec (mapcar (function (lambda (row)
(math-dot-product row b)))
(cdr a)))
)
(cdr a))))
(defun calcFunc-tr (mat) ; [Public]
(if (math-square-matrixp mat)
(math-matrix-trace-step 2 (1- (length mat)) mat (nth 1 (nth 1 mat)))
(math-reject-arg mat 'square-matrixp))
)
(math-reject-arg mat 'square-matrixp)))
(defun math-matrix-trace-step (n size mat sum)
(if (<= n size)
(math-matrix-trace-step (1+ n) size mat
(math-add sum (nth n (nth n mat))))
sum)
)
sum))
;;; Matrix inverse and determinant.
@ -167,8 +158,7 @@
det)))
(let ((lud (math-matrix-lud m)))
(and lud
(math-lud-solve lud (calcFunc-idn 1 n))))))
)
(math-lud-solve lud (calcFunc-idn 1 n)))))))
(defun calcFunc-det (m)
(if (math-square-matrixp m)
@ -177,8 +167,7 @@
(or (math-zerop (nth 1 m))
(math-equal-int (nth 1 m) 1)))
(nth 1 m)
(math-reject-arg m 'square-matrixp)))
)
(math-reject-arg m 'square-matrixp))))
(defun math-det-raw (m)
(let ((n (1- (length m))))
@ -217,14 +206,12 @@
(if lud
(let ((lu (car lud)))
(math-det-step n (nth 2 lud)))
0)))))
)
0))))))
(defun math-det-step (n prod)
(if (> n 0)
(math-det-step (1- n) (math-mul prod (nth n (nth n lu))))
prod)
)
prod))
;;; This returns a list (LU index d), or NIL if not possible.
;;; Argument M must be a square matrix.
@ -238,8 +225,7 @@
(if old
(setcdr old entry)
(setq math-lud-cache (cons (cons m entry) math-lud-cache)))
lud)))
)
lud))))
(defvar math-lud-cache nil)
;;; Numerical Recipes section 2.3; implicit pivoting omitted.
@ -288,8 +274,7 @@
(setcar (nthcdr j (nth i lu))
(math-div (nth j (nth i lu)) pivot)))))
(setq j (1+ j)))
(list lu (nreverse index) d))
)
(list lu (nreverse index) d)))
(defun math-swap-rows (m r1 r2)
(or (= r1 r2)
@ -302,8 +287,7 @@
(setcdr r1prev row2)
(setcdr row2 (cdr row1))
(setcdr row1 r2next)))
m
)
m)
(defun math-lud-solve (lud b &optional need)
@ -345,8 +329,7 @@
(setq col (1+ col)))
x)
(and need
(math-reject-arg need "*Singular matrix")))
)
(math-reject-arg need "*Singular matrix"))))
(defun calcFunc-lud (m)
(if (math-square-matrixp m)
@ -373,6 +356,6 @@
(setq perm (math-swap-rows perm j pos)))))
(list 'vec perm lmat umat)))))
(math-reject-arg m "*Singular matrix"))
(math-reject-arg m 'square-matrixp))
)
(math-reject-arg m 'square-matrixp)))
;;; calc-mtx.el ends here

179
lisp/calc/calc-poly.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-poly.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -65,23 +65,20 @@
(math-neg (math-poly-gcd cont c2))
(math-poly-gcd cont c2))))))
(var expr)
(t 1))
)
(t 1)))
(defun calcFunc-pprim (expr &optional var)
(let ((cont (calcFunc-pcont expr var)))
(if (math-equal-int cont 1)
expr
(math-poly-div-exact expr cont var)))
)
(math-poly-div-exact expr cont var))))
(defun math-div-poly-const (expr c)
(cond ((memq (car-safe expr) '(+ -))
(list (car expr)
(math-div-poly-const (nth 1 expr) c)
(math-div-poly-const (nth 2 expr) c)))
(t (math-div expr c)))
)
(t (math-div expr c))))
(defun calcFunc-pdeg (expr &optional var)
(if (Math-zerop expr)
@ -89,8 +86,7 @@
(if var
(or (math-polynomial-p expr var)
(math-reject-arg expr "Expected a polynomial"))
(math-poly-degree expr)))
)
(math-poly-degree expr))))
(defun math-poly-degree (expr)
(cond ((Math-primp expr)
@ -108,8 +104,7 @@
((memq (car expr) '(+ -))
(max (math-poly-degree (nth 1 expr))
(math-poly-degree (nth 2 expr))))
(t 1))
)
(t 1)))
(defun calcFunc-plead (expr var)
(cond ((eq (car-safe expr) '*)
@ -128,8 +123,7 @@
(let ((p (math-is-polynomial expr var)))
(if (cdr p)
(nth (1- (length p)) p)
1))))
)
1)))))
@ -149,8 +143,7 @@
(math-reject-arg pd "Coefficients must be rational"))
(let ((calc-prefer-frac t)
(math-poly-modulus (math-poly-modulus pn pd)))
(math-poly-gcd pn pd))
)
(math-poly-gcd pn pd)))
;;; Return only quotient to top of stack (nil if zero)
(defun calcFunc-pdiv (pn pd &optional base)
@ -158,29 +151,25 @@
(math-poly-modulus (math-poly-modulus pn pd))
(res (math-poly-div pn pd base)))
(setq calc-poly-div-remainder (cdr res))
(car res))
)
(car res)))
;;; Return only remainder to top of stack
(defun calcFunc-prem (pn pd &optional base)
(let ((calc-prefer-frac t)
(math-poly-modulus (math-poly-modulus pn pd)))
(cdr (math-poly-div pn pd base)))
)
(cdr (math-poly-div pn pd base))))
(defun calcFunc-pdivrem (pn pd &optional base)
(let* ((calc-prefer-frac t)
(math-poly-modulus (math-poly-modulus pn pd))
(res (math-poly-div pn pd base)))
(list 'vec (car res) (cdr res)))
)
(list 'vec (car res) (cdr res))))
(defun calcFunc-pdivide (pn pd &optional base)
(let* ((calc-prefer-frac t)
(math-poly-modulus (math-poly-modulus pn pd))
(res (math-poly-div pn pd base)))
(math-add (car res) (math-div (cdr res) pd)))
)
(math-add (car res) (math-div (cdr res) pd))))
;;; Multiply two terms, expanding out products of sums.
@ -193,16 +182,14 @@
(list (car rhs)
(math-mul-thru lhs (nth 1 rhs))
(math-mul-thru lhs (nth 2 rhs)))
(math-mul lhs rhs)))
)
(math-mul lhs rhs))))
(defun math-div-thru (num den)
(if (memq (car-safe num) '(+ -))
(list (car num)
(math-div-thru (nth 1 num) den)
(math-div-thru (nth 2 num) den))
(math-div num den))
)
(math-div num den)))
;;; Sort the terms of a sum into canonical order.
@ -211,8 +198,7 @@
(math-list-to-sum
(sort (math-sum-to-list expr)
(function (lambda (a b) (math-beforep (car a) (car b))))))
expr)
)
expr))
(defun math-list-to-sum (lst)
(if (cdr lst)
@ -221,8 +207,7 @@
(car (car lst)))
(if (cdr (car lst))
(math-neg (car (car lst)))
(car (car lst))))
)
(car (car lst)))))
(defun math-sum-to-list (tree &optional neg)
(cond ((eq (car-safe tree) '+)
@ -231,39 +216,34 @@
((eq (car-safe tree) '-)
(nconc (math-sum-to-list (nth 1 tree) neg)
(math-sum-to-list (nth 2 tree) (not neg))))
(t (list (cons tree neg))))
)
(t (list (cons tree neg)))))
;;; Check if the polynomial coefficients are modulo forms.
(defun math-poly-modulus (expr &optional expr2)
(or (math-poly-modulus-rec expr)
(and expr2 (math-poly-modulus-rec expr2))
1)
)
1))
(defun math-poly-modulus-rec (expr)
(if (and (eq (car-safe expr) 'mod) (Math-natnump (nth 2 expr)))
(list 'mod 1 (nth 2 expr))
(and (memq (car-safe expr) '(+ - * /))
(or (math-poly-modulus-rec (nth 1 expr))
(math-poly-modulus-rec (nth 2 expr)))))
)
(math-poly-modulus-rec (nth 2 expr))))))
;;; Divide two polynomials. Return (quotient . remainder).
(defun math-poly-div (u v &optional math-poly-div-base)
(if math-poly-div-base
(math-do-poly-div u v)
(math-do-poly-div (calcFunc-expand u) (calcFunc-expand v)))
)
(math-do-poly-div (calcFunc-expand u) (calcFunc-expand v))))
(setq math-poly-div-base nil)
(defun math-poly-div-exact (u v &optional base)
(let ((res (math-poly-div u v base)))
(if (eq (cdr res) 0)
(car res)
(math-reject-arg (list 'vec u v) "Argument is not a polynomial")))
)
(math-reject-arg (list 'vec u v) "Argument is not a polynomial"))))
(defun math-do-poly-div (u v)
(cond ((math-constp u)
@ -293,8 +273,7 @@
(setq up (math-is-polynomial u base nil 'gen)
res (math-poly-div-coefs up vp))
(cons (math-build-polynomial-expr (car res) base)
(math-build-polynomial-expr (cdr res) base))))))
)
(math-build-polynomial-expr (cdr res) base)))))))
(defun math-poly-div-rec (u v)
(cond ((math-constp u)
@ -322,8 +301,7 @@
res (math-poly-div-coefs up vp))
(math-add (math-build-polynomial-expr (car res) base)
(math-div (math-build-polynomial-expr (cdr res) base)
v))))))
)
v)))))))
;;; Divide two polynomials in coefficient-list form. Return (quot . rem).
(defun math-poly-div-coefs (u v)
@ -349,8 +327,7 @@
(cons q (nreverse (mapcar 'math-simplify urev)))))
(t
(cons (list (math-poly-div-rec (car u) (car v)))
nil)))
)
nil))))
;;; Perform a pseudo-division of polynomials. (See Knuth section 4.6.1.)
;;; This returns only the remainder from the pseudo-division.
@ -375,8 +352,7 @@
(while (and urev (Math-zerop (car urev)))
(setq urev (cdr urev)))
(nreverse (mapcar 'math-simplify urev))))
(t nil))
)
(t nil)))
;;; Compute the GCD of two multivariate polynomials.
(defun math-poly-gcd (u v)
@ -398,16 +374,14 @@
(math-poly-gcd-coefs (math-is-polynomial u base nil 'gen)
(math-is-polynomial v base nil 'gen))
base)))
(calcFunc-gcd (calcFunc-pcont u) (calcFunc-pcont u))))))
)
(calcFunc-gcd (calcFunc-pcont u) (calcFunc-pcont u)))))))
(defun math-poly-div-list (lst a)
(if (eq a 1)
lst
(if (eq a -1)
(math-mul-list lst a)
(mapcar (function (lambda (x) (math-poly-div-exact x a))) lst)))
)
(mapcar (function (lambda (x) (math-poly-div-exact x a))) lst))))
(defun math-mul-list (lst a)
(if (eq a 1)
@ -415,8 +389,7 @@
(if (eq a -1)
(mapcar 'math-neg lst)
(and (not (eq a 0))
(mapcar (function (lambda (x) (math-mul x a))) lst))))
)
(mapcar (function (lambda (x) (math-mul x a))) lst)))))
;;; Run GCD on all elements in a list.
(defun math-poly-gcd-list (lst)
@ -427,8 +400,7 @@
(or (eq (car lst) 0)
(setq gcd (math-poly-gcd gcd (car lst)))))
(if lst (setq lst (math-poly-gcd-frac-list lst)))
gcd))
)
gcd)))
(defun math-poly-gcd-frac-list (lst)
(while (and lst (not (eq (car-safe (car lst)) 'frac)))
@ -439,8 +411,7 @@
(if (eq (car-safe (car lst)) 'frac)
(setq denom (calcFunc-lcm denom (nth 2 (car lst))))))
(list 'frac 1 denom))
1)
)
1))
;;; Compute the GCD of two monovariate polynomial lists.
;;; Knuth section 4.6.1, algorithm C.
@ -473,8 +444,7 @@
(setq v (math-mul-list v -1)))
(while (>= (setq z (1- z)) 0)
(setq v (cons 0 v)))
v)
)
v))
;;; Return true if is a factor containing no sums or quotients.
@ -486,8 +456,7 @@
nil)
((memq (car-safe expr) '(^ neg))
(math-atomic-factorp (nth 1 expr)))
(t t))
)
(t t)))
;;; Find a suitable base for dividing a by b.
;;; The base must exist in both expressions.
@ -506,8 +475,7 @@
(if maybe
(if (>= (nth 1 (car a-base)) (nth 1 maybe))
(throw 'return (car (car a-base))))))
(setq a-base (cdr a-base))))))
)
(setq a-base (cdr a-base)))))))
;;; Same as above but for gcd algorithm.
;;; Here there is no requirement that degree(a) > degree(b).
@ -526,16 +494,14 @@
(setq a-base (cdr a-base)))
(if (assoc (car (car b-base)) a-base)
(throw 'return (car (car b-base)))
(setq b-base (cdr b-base))))))))
)
(setq b-base (cdr b-base)))))))))
;;; Sort a list of polynomial bases.
(defun math-sort-poly-base-list (lst)
(sort lst (function (lambda (a b)
(or (> (nth 1 a) (nth 1 b))
(and (= (nth 1 a) (nth 1 b))
(math-beforep (car a) (car b)))))))
)
(math-beforep (car a) (car b))))))))
;;; Given an expression find all variables that are polynomial bases.
;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ).
@ -543,8 +509,7 @@
(defun math-total-polynomial-base (expr)
(let ((mpb-total-base nil))
(math-polynomial-base expr 'math-polynomial-p1)
(math-sort-poly-base-list mpb-total-base))
)
(math-sort-poly-base-list mpb-total-base)))
(defun math-polynomial-p1 (subexpr)
(or (assoc subexpr mpb-total-base)
@ -555,8 +520,7 @@
(if exponent
(setq mpb-total-base (cons (list subexpr exponent)
mpb-total-base)))))
nil
)
nil)
@ -572,8 +536,7 @@
expr))))
(math-simplify (if (math-vectorp res)
res
(list 'vec (list 'vec res 1))))))
)
(list 'vec (list 'vec res 1)))))))
(defun calcFunc-factor (expr &optional var)
(let ((math-factored-vars nil)
@ -583,22 +546,19 @@
(if var
(let ((math-factored-vars t))
(or (catch 'factor (math-factor-expr-try var)) expr))
(math-factor-expr expr)))))
)
(math-factor-expr expr))))))
(defun math-factor-finish (x)
(if (Math-primp x)
x
(if (eq (car x) 'calcFunc-Fac-Prot)
(math-factor-finish (nth 1 x))
(cons (car x) (mapcar 'math-factor-finish (cdr x)))))
)
(cons (car x) (mapcar 'math-factor-finish (cdr x))))))
(defun math-factor-protect (x)
(if (memq (car-safe x) '(+ -))
(list 'calcFunc-Fac-Prot x)
x)
)
x))
(defun math-factor-expr (expr)
(cond ((eq math-factored-vars t) expr)
@ -611,8 +571,7 @@
(if y
(math-factor-expr y)
expr)))
(t expr))
)
(t expr)))
(defun math-factor-expr-part (x) ; uses "expr"
(if (memq (car-safe x) '(+ - * / ^ neg))
@ -622,8 +581,7 @@
(not (assoc x math-factored-vars))
(> (math-factor-contains expr x) 1)
(setq math-factored-vars (cons (list x) math-factored-vars))
(math-factor-expr-try x)))
)
(math-factor-expr-try x))))
(defun math-factor-expr-try (x)
(if (eq (car-safe expr) '*)
@ -639,8 +597,7 @@
res)
(and (cdr p)
(setq res (math-factor-poly-coefs p))
(throw 'factor res))))
)
(throw 'factor res)))))
(defun math-accum-factors (fac pow facs)
(if math-to-list
@ -671,8 +628,7 @@
(cons 'vec (cons (nth 1 facs) (cons (list 'vec fac pow)
(cdr (cdr facs)))))
(cons 'vec (cons (list 'vec fac pow) (cdr facs))))))))
(math-mul (math-pow fac pow) facs))
)
(math-mul (math-pow fac pow) facs)))
(defun math-factor-poly-coefs (p &optional square-free) ; uses "x"
(let (t1 t2)
@ -813,8 +769,7 @@
(and (setq temp (math-factor-poly-coefs p))
(math-pow temp (nth 2 math-poly-modulus))))
(t
(math-reject-arg nil "*Modulo factorization not yet implemented"))))
)
(math-reject-arg nil "*Modulo factorization not yet implemented")))))
(defun math-poly-deriv-coefs (p)
(let ((n 1)
@ -822,8 +777,7 @@
(while (setq p (cdr p))
(setq dp (cons (math-mul (car p) n) dp)
n (1+ n)))
(nreverse dp))
)
(nreverse dp)))
(defun math-factor-contains (x a)
(if (equal x a)
@ -836,8 +790,7 @@
(if (and (eq (car-safe x) '^)
(natnump (nth 2 x)))
(* (math-factor-contains (nth 1 x) a) (nth 2 x))
0)))
)
0))))
@ -860,14 +813,12 @@
(den2 (math-poly-div den g)))
(and (eq (cdr num2) 0) (eq (cdr den2) 0)
(setq num (car num2) den (car den2)))))
(math-simplify (math-div num den))))
)
(math-simplify (math-div num den)))))
;;; Returns expressions (num . denom).
(defun math-to-ratpoly (expr)
(let ((res (math-to-ratpoly-rec expr)))
(cons (math-simplify (car res)) (math-simplify (cdr res))))
)
(cons (math-simplify (car res)) (math-simplify (cdr res)))))
(defun math-to-ratpoly-rec (expr)
(cond ((Math-primp expr)
@ -933,8 +884,7 @@
((eq (car expr) 'neg)
(let ((r1 (math-to-ratpoly-rec (nth 1 expr))))
(cons (math-neg (car r1)) (cdr r1))))
(t (cons expr 1)))
)
(t (cons expr 1))))
(defun math-ratpoly-p (expr &optional var)
@ -963,8 +913,7 @@
(and p1 (* p1 (nth 2 expr)))))
((not var) 1)
((math-poly-depends expr var) nil)
(t 0))
)
(t 0)))
(defun calcFunc-apart (expr &optional var)
@ -990,14 +939,12 @@
(math-add q (or (and var
(math-expr-contains den var)
(math-partial-fractions r den var))
(math-div r den))))))
)
(math-div r den)))))))
(defun math-padded-polynomial (expr var deg)
(let ((p (math-is-polynomial expr var deg)))
(append p (make-list (- deg (length p)) 0)))
)
(append p (make-list (- deg (length p)) 0))))
(defun math-partial-fractions (r den var)
(let* ((fden (calcFunc-factors den var))
@ -1063,8 +1010,7 @@
res (math-add res (math-div num (car dlist)))
num nil))
(setq dlist (cdr dlist)))
(math-normalize res))))))
)
(math-normalize res)))))))
@ -1096,12 +1042,10 @@
(list '^ (nth 1 expr) (1- (nth 2 expr)))))
(if (< (nth 2 expr) 0)
(list '/ 1 (list '^ (nth 1 expr) (- (nth 2 expr))))))))
(t expr))
)
(t expr)))
(defun calcFunc-expand (expr &optional many)
(math-normalize (math-map-tree 'math-expand-term expr many))
)
(math-normalize (math-map-tree 'math-expand-term expr many)))
(defun math-expand-power (x n &optional var else-nil)
(or (and (natnump n)
@ -1184,12 +1128,9 @@
(setq p1 (cdr p1)))
accum))))))
(and (not else-nil)
(list '^ x n)))
)
(list '^ x n))))
(defun calcFunc-expandpow (x n)
(math-normalize (math-expand-power x n))
)
(math-normalize (math-expand-power x n)))
;;; calc-poly.el ends here

349
lisp/calc/calc-prog.el
View File

@ -34,76 +34,64 @@
(calc-wrapper
(if (and (integerp arg) (> arg 2))
(calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
(calc-binary-op "eq" 'calcFunc-eq arg)))
)
(calc-binary-op "eq" 'calcFunc-eq arg))))
(defun calc-remove-equal (arg)
(interactive "P")
(calc-wrapper
(calc-unary-op "rmeq" 'calcFunc-rmeq arg))
)
(calc-unary-op "rmeq" 'calcFunc-rmeq arg)))
(defun calc-not-equal-to (arg)
(interactive "P")
(calc-wrapper
(if (and (integerp arg) (> arg 2))
(calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
(calc-binary-op "neq" 'calcFunc-neq arg)))
)
(calc-binary-op "neq" 'calcFunc-neq arg))))
(defun calc-less-than (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "lt" 'calcFunc-lt arg))
)
(calc-binary-op "lt" 'calcFunc-lt arg)))
(defun calc-greater-than (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "gt" 'calcFunc-gt arg))
)
(calc-binary-op "gt" 'calcFunc-gt arg)))
(defun calc-less-equal (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "leq" 'calcFunc-leq arg))
)
(calc-binary-op "leq" 'calcFunc-leq arg)))
(defun calc-greater-equal (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "geq" 'calcFunc-geq arg))
)
(calc-binary-op "geq" 'calcFunc-geq arg)))
(defun calc-in-set (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "in" 'calcFunc-in arg))
)
(calc-binary-op "in" 'calcFunc-in arg)))
(defun calc-logical-and (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "land" 'calcFunc-land arg 1))
)
(calc-binary-op "land" 'calcFunc-land arg 1)))
(defun calc-logical-or (arg)
(interactive "P")
(calc-wrapper
(calc-binary-op "lor" 'calcFunc-lor arg 0))
)
(calc-binary-op "lor" 'calcFunc-lor arg 0)))
(defun calc-logical-not (arg)
(interactive "P")
(calc-wrapper
(calc-unary-op "lnot" 'calcFunc-lnot arg))
)
(calc-unary-op "lnot" 'calcFunc-lnot arg)))
(defun calc-logical-if ()
(interactive)
(calc-wrapper
(calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3))))
)
(calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))))
@ -115,8 +103,7 @@
(calc-change-mode 'calc-timing n nil t)
(message (if calc-timing
"Reporting timing of slow commands in Trail."
"Not reporting timing of commands.")))
)
"Not reporting timing of commands."))))
(defun calc-pass-errors ()
(interactive)
@ -129,8 +116,7 @@
(or (memq (car (car place)) '(error xxxerror))
(error "foo"))
(setcar (car place) 'xxxerror))
(error (error "The calc-do function has been modified; unable to patch.")))
)
(error (error "The calc-do function has been modified; unable to patch."))))
(defun calc-user-define ()
(interactive)
@ -149,8 +135,7 @@
(old (assq key kmap)))
(if old
(setcdr old func)
(setcdr kmap (cons (cons key func) (cdr kmap)))))))
)
(setcdr kmap (cons (cons key func) (cdr kmap))))))))
(defun calc-user-undefine ()
(interactive)
@ -163,8 +148,7 @@
(assq (upcase key) kmap)
(assq (downcase key) kmap)
(error "No such user key is defined"))
kmap)))
)
kmap))))
(defun calc-user-define-formula ()
(interactive)
@ -304,8 +288,7 @@
(if old
(setcdr old cmd)
(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
(message ""))
)
(message "")))
(defun calc-default-formula-arglist (form)
(if (consp form)
@ -314,21 +297,18 @@
(math-const-var form))
()
(setq arglist (cons (nth 1 form) arglist)))
(calc-default-formula-arglist-step (cdr form))))
)
(calc-default-formula-arglist-step (cdr form)))))
(defun calc-default-formula-arglist-step (l)
(and l
(progn
(calc-default-formula-arglist (car l))
(calc-default-formula-arglist-step (cdr l))))
)
(calc-default-formula-arglist-step (cdr l)))))
(defun calc-subsetp (a b)
(or (null a)
(and (memq (car a) b)
(calc-subsetp (cdr a) b)))
)
(calc-subsetp (cdr a) b))))
(defun calc-fix-user-formula (f)
(if (consp f)
@ -356,8 +336,7 @@
(cons 'list
(cons (list 'quote (car f))
(mapcar 'calc-fix-user-formula (cdr f)))))))
f)
)
f))
(defun calc-user-define-composition ()
(interactive)
@ -395,8 +374,7 @@
(cons (setq entry2 (list (length alist))) (cdr entry))))
(setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))
(calc-pop-stack 1)
(calc-do-refresh)))
)
(calc-do-refresh))))
(defun calc-user-define-kbd-macro (arg)
@ -443,8 +421,7 @@
(old (assq key kmap)))
(if old
(setcdr old cmd)
(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
)
(setcdr kmap (cons (cons key cmd) (cdr kmap))))))))
(defun calc-edit-user-syntax ()
@ -459,8 +436,7 @@
(t (capitalize (symbol-name lang))))))
(calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
lang)))
(calc-show-edit-buffer)
)
(calc-show-edit-buffer))
(defun calc-finish-user-syntax-edit (lang)
(let ((tab (calc-read-parse-table calc-original-buffer lang))
@ -473,8 +449,7 @@
(if entry
(setq calc-user-parse-tables
(delq entry calc-user-parse-tables)))))
(switch-to-buffer calc-original-buffer)
)
(switch-to-buffer calc-original-buffer))
(defun calc-write-parse-table (tab calc-lang)
(let ((p tab))
@ -484,8 +459,7 @@
(let ((math-format-hash-args t))
(math-format-flat-expr (cdr (car p)) 0))
"\n")
(setq p (cdr p))))
)
(setq p (cdr p)))))
(defun calc-write-parse-table-part (p)
(while p
@ -515,8 +489,7 @@
(if (nth 2 (car p))
(calc-write-parse-table-part (list (car (nth 2 (car p)))))
(insert " "))))
(setq p (cdr p)))
)
(setq p (cdr p))))
(defun calc-read-parse-table (calc-buf calc-lang)
(let ((tab nil))
@ -551,8 +524,7 @@
(goto-char (+ pos (nth 1 exp)))
(error (nth 2 exp))))
(setq tab (nconc tab (list (cons p exp)))))))))
tab)
)
tab))
(defun calc-fix-token-name (name &optional unquoted)
(cond ((string-match "\\`\\.\\." name)
@ -571,8 +543,7 @@
((not (string-match "[^ ]" name))
(search-backward "\"" nil t)
(error "Blank tokens are not allowed"))
(t name))
)
(t name)))
(defun calc-read-parse-table-part (term eterm)
(let ((part nil)
@ -634,8 +605,7 @@
(not (eq (car last) quoted))
(setcar last
(list '\? (list (car last)) '("$$"))))))))
part)
)
part))
(defun calc-user-define-invocation ()
@ -643,8 +613,7 @@
(or last-kbd-macro
(error "No keyboard macro defined"))
(setq calc-invocation-macro last-kbd-macro)
(message "Use `M-# Z' to invoke this macro")
)
(message "Use `M-# Z' to invoke this macro"))
(defun calc-user-define-edit (prefix)
@ -746,8 +715,7 @@
(math-format-nice-expr defn (frame-width)))
"\n"))
(calc-show-edit-buffer))
(error "That command's definition cannot be edited"))))))
)
(error "That command's definition cannot be edited")))))))
(defun calc-finish-macro-edit (def keys)
(forward-line 1)
@ -764,14 +732,12 @@
(aset (car mac) 0 (if keys true-str (key-description str)))
(aset (car mac) 1 str))
(setcar mac str))))
(setcdr def str)))
)
(setcdr def str))))
;;; The following are hooks into the MacEdit package from macedit.el.
(put 'calc-execute-extended-command 'MacEdit-print
(function (lambda ()
(setq macro-str (concat "\excalc-" macro-str))))
)
(setq macro-str (concat "\excalc-" macro-str)))))
(put 'calcDigit-start 'MacEdit-print
(function (lambda ()
@ -809,8 +775,7 @@
(MacEdit-unread-chars ch))
(insert "type \"")
(MacEdit-insert-string str)
(insert "\"\n")))))
)
(insert "\"\n"))))))
(defun calc-macro-edit-algebraic ()
(MacEdit-unread-chars key-last)
@ -842,8 +807,7 @@
(progn
(insert "type \"")
(MacEdit-insert-string str)
(insert "\"\n"))))
)
(insert "\"\n")))))
(put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
(put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
@ -858,8 +822,7 @@
(char-to-string (MacEdit-read-char)) "\"\n")
(if (> (length str) 0)
(insert "type \"" str "\"\n"))
(MacEdit-read-argument)))
)
(MacEdit-read-argument))))
(put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)
(put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)
@ -880,14 +843,12 @@
(defun calc-macro-edit-variable-2 ()
(calc-macro-edit-variable)
(calc-macro-edit-variable t)
)
(calc-macro-edit-variable t))
(put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)
(put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)
(defun calc-macro-edit-quick-digit ()
(insert "type \"" key-str "\" # " (symbol-name key-symbol) "\n")
)
(insert "type \"" key-str "\" # " (symbol-name key-symbol) "\n"))
(put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
(put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
(put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
@ -910,8 +871,7 @@
(setcar (cdr body)
(let ((alist (nth 1 (symbol-function func))))
(calc-fix-user-formula val)))
(put func 'calc-user-defn val)))
)
(put func 'calc-user-defn val))))
(defun calc-valid-formula-func (func)
(let ((def (symbol-function func)))
@ -922,8 +882,7 @@
(while (and def
(not (eq (car (car def)) 'math-normalize)))
(setq def (cdr def)))
(car def))))
)
(car def)))))
(defun calc-get-user-defn ()
@ -953,8 +912,7 @@
func)))
(list defn))))
(calc-enter-result 0 "gdef" defn))
(error "That command is not defined by a formula")))))))
)
(error "That command is not defined by a formula"))))))))
(defun calc-user-define-permanent ()
@ -1051,8 +1009,7 @@
(prin1-to-string cmd)
")\n")))
(insert "))\n")
(save-buffer)))
)
(save-buffer))))
(defun calc-stack-command-p (cmd)
(if (and cmd (symbolp cmd))
@ -1065,8 +1022,7 @@
(setq cmd (assq 'calc-enter-result cmd))
(memq (car (nth 3 cmd)) '(cons list))
(eq (car (nth 1 (nth 3 cmd))) 'quote)
(nth 1 (nth 1 (nth 3 cmd)))))
)
(nth 1 (nth 1 (nth 3 cmd))))))
(defun calc-call-last-kbd-macro (arg)
@ -1075,8 +1031,7 @@
(error "Can't execute anonymous macro while defining one"))
(or last-kbd-macro
(error "No kbd macro has been defined"))
(calc-execute-kbd-macro last-kbd-macro arg)
)
(calc-execute-kbd-macro last-kbd-macro arg))
(defun calc-execute-kbd-macro (mac arg &rest prefix)
(if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0)))
@ -1127,8 +1082,7 @@
(calc-record-undo (list 'push 1))
(setq new-stack (cdr new-stack)))
(calc-refresh))
(calc-record-undo (list 'set 'saved-stack-top 0))))))))
)
(calc-record-undo (list 'set 'saved-stack-top 0)))))))))
(defun calc-push-list-in-macro (vals m sels)
(let ((entry (list (car vals) 1 (car sels)))
@ -1136,15 +1090,13 @@
(if (> mm 1)
(setcdr (nthcdr (- mm 2) calc-stack)
(cons entry (nthcdr (1- mm) calc-stack)))
(setq calc-stack (cons entry calc-stack))))
)
(setq calc-stack (cons entry calc-stack)))))
(defun calc-pop-stack-in-macro (n mm)
(if (> mm 1)
(setcdr (nthcdr (- mm 2) calc-stack)
(nthcdr (+ n mm -1) calc-stack))
(setq calc-stack (nthcdr n calc-stack)))
)
(setq calc-stack (nthcdr n calc-stack))))
(defun calc-kbd-if ()
@ -1157,13 +1109,11 @@
(message "If true..."))
(if defining-kbd-macro
(message "Condition is false; skipping to Z: or Z] ..."))
(calc-kbd-skip-to-else-if t))))
)
(calc-kbd-skip-to-else-if t)))))
(defun calc-kbd-else-if ()
(interactive)
(calc-kbd-if)
)
(calc-kbd-if))
(defun calc-kbd-skip-to-else-if (else-okay)
(let ((count 0)
@ -1188,21 +1138,18 @@
(and defining-kbd-macro
(if (= ch ?\:)
(message "Else...")
(message "End-if..."))))
)
(message "End-if...")))))
(defun calc-kbd-end-if ()
(interactive)
(if defining-kbd-macro
(message "End-if..."))
)
(message "End-if...")))
(defun calc-kbd-else ()
(interactive)
(if defining-kbd-macro
(message "Else; skipping to Z] ..."))
(calc-kbd-skip-to-else-if nil)
)
(calc-kbd-skip-to-else-if nil))
(defun calc-kbd-repeat ()
@ -1217,8 +1164,7 @@
(or (integerp count)
(setq count 1000000))
(calc-pop-stack 1))
(calc-kbd-loop count))
)
(calc-kbd-loop count)))
(defun calc-kbd-for (dir)
(interactive "P")
@ -1229,8 +1175,7 @@
(or (and (math-anglep init) (math-anglep final))
(error "Initial and final values must be real numbers"))
(calc-pop-stack 2))
(calc-kbd-loop nil init final (and dir (prefix-numeric-value dir))))
)
(calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))))
(defun calc-kbd-loop (rpt-count &optional initial final dir)
(interactive "P")
@ -1301,23 +1246,19 @@
(setq counter (calcFunc-add counter step)))
(setq rpt-count (1- rpt-count))))))))
(or executing-kbd-macro
(message "Looping...done")))
)
(message "Looping...done"))))
(defun calc-kbd-end-repeat ()
(interactive)
(error "Unbalanced Z> in keyboard macro")
)
(error "Unbalanced Z> in keyboard macro"))
(defun calc-kbd-end-for ()
(interactive)
(error "Unbalanced Z) in keyboard macro")
)
(error "Unbalanced Z) in keyboard macro"))
(defun calc-kbd-end-loop ()
(interactive)
(error "Unbalanced Z} in keyboard macro")
)
(error "Unbalanced Z} in keyboard macro"))
(defun calc-kbd-break ()
(interactive)
@ -1325,8 +1266,7 @@
(let ((cond (calc-top-n 1)))
(calc-pop-stack 1)
(if (math-is-true cond)
(error "Keyboard macro aborted."))))
)
(error "Keyboard macro aborted.")))))
(defun calc-kbd-push (arg)
@ -1383,8 +1323,7 @@
(execute-kbd-macro (substring body 0 -2))))
(let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
(message "Saving modes; type Z' to restore")
(recursive-edit)))))
)
(recursive-edit))))))
(setq calc-kbd-push-level 0)
(defun calc-kbd-pop ()
@ -1393,8 +1332,7 @@
(progn
(message "Mode settings restored")
(exit-recursive-edit))
(error "Unbalanced Z' in keyboard macro"))
)
(error "Unbalanced Z' in keyboard macro")))
(defun calc-kbd-report (msg)
@ -1402,16 +1340,14 @@
(calc-wrapper
(let ((executing-kbd-macro nil)
(defining-kbd-macro nil))
(math-working msg (calc-top-n 1))))
)
(math-working msg (calc-top-n 1)))))
(defun calc-kbd-query (msg)
(interactive "sPrompt: ")
(calc-wrapper
(let ((executing-kbd-macro nil)
(defining-kbd-macro nil))
(calc-alg-entry nil (and (not (equal msg "")) msg))))
)
(calc-alg-entry nil (and (not (equal msg "")) msg)))))
@ -1443,8 +1379,7 @@
(if (and (or (math-looks-negp a) (math-zerop a))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-eq (math-neg a) (math-neg b))
(list 'calcFunc-eq a b))))
)
(list 'calcFunc-eq a b)))))
(defun calcFunc-neq (a b &rest more)
(if more
@ -1468,8 +1403,7 @@
(if (and (or (math-looks-negp a) (math-zerop a))
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-neq (math-neg a) (math-neg b))
(list 'calcFunc-neq a b))))
)
(list 'calcFunc-neq a b)))))
(defun math-two-eq (a b)
(if (eq (car-safe a) 'vec)
@ -1495,8 +1429,7 @@
1
(if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
nil
0)))))
)
0))))))
(defun calcFunc-lt (a b)
(let ((res (math-compare a b)))
@ -1507,8 +1440,7 @@
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-gt (math-neg a) (math-neg b))
(list 'calcFunc-lt a b))
0)))
)
0))))
(defun calcFunc-gt (a b)
(let ((res (math-compare a b)))
@ -1519,8 +1451,7 @@
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-lt (math-neg a) (math-neg b))
(list 'calcFunc-gt a b))
0)))
)
0))))
(defun calcFunc-leq (a b)
(let ((res (math-compare a b)))
@ -1531,8 +1462,7 @@
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-geq (math-neg a) (math-neg b))
(list 'calcFunc-leq a b))
1)))
)
1))))
(defun calcFunc-geq (a b)
(let ((res (math-compare a b)))
@ -1543,8 +1473,7 @@
(or (math-looks-negp b) (math-zerop b)))
(list 'calcFunc-leq (math-neg a) (math-neg b))
(list 'calcFunc-geq a b))
1)))
)
1))))
(defun calcFunc-rmeq (a)
(if (math-vectorp a)
@ -1558,8 +1487,7 @@
(nth 2 a)
(if (eq (car-safe a) 'calcFunc-evalto)
(nth 1 a)
(list 'calcFunc-rmeq a)))))
)
(list 'calcFunc-rmeq a))))))
(defun calcFunc-land (a b)
(cond ((Math-zerop a)
@ -1570,8 +1498,7 @@
b)
((math-is-true b)
a)
(t (list 'calcFunc-land a b)))
)
(t (list 'calcFunc-land a b))))
(defun calcFunc-lor (a b)
(cond ((Math-zerop a)
@ -1582,8 +1509,7 @@
a)
((math-is-true b)
b)
(t (list 'calcFunc-lor a b)))
)
(t (list 'calcFunc-lor a b))))
(defun calcFunc-lnot (a)
(if (Math-zerop a)
@ -1594,8 +1520,7 @@
(assq (car a) calc-tweak-eqn-table))))
(if op
(cons (nth 2 op) (cdr a))
(list 'calcFunc-lnot a)))))
)
(list 'calcFunc-lnot a))))))
(defun calcFunc-if (c e1 e2)
(if (Math-zerop c)
@ -1616,16 +1541,14 @@
(list e2))))
(and ee1 ee2
(cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
(list 'calcFunc-if c e1 e2))))
)
(list 'calcFunc-if c e1 e2)))))
(defun math-if-vector (c e1 e2)
(and c
(cons (if (Math-zerop (car c)) (car e2) (car e1))
(math-if-vector (cdr c)
(or (cdr e1) e1)
(or (cdr e2) e2))))
)
(or (cdr e2) e2)))))
(defun math-normalize-logical-op (a)
(or (and (eq (car a) 'calcFunc-if)
@ -1644,8 +1567,7 @@
(list 'calcFunc-if a1
(math-normalize (nth 2 a))
(math-normalize (nth 3 a)))))))))
a)
)
a))
(defun calcFunc-in (a b)
(or (and (eq (car-safe b) 'vec)
@ -1678,8 +1600,7 @@
1)
(and (math-constp a) (math-constp b)
0)
(list 'calcFunc-in a b))
)
(list 'calcFunc-in a b)))
(defun calcFunc-typeof (a)
(cond ((Math-integerp a) 1)
@ -1695,40 +1616,35 @@
((eq (car a) 'var)
(if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
((eq (car a) 'vec) (if (math-matrixp a) 102 101))
(t (math-calcFunc-to-var func)))
)
(t (math-calcFunc-to-var func))))
(defun calcFunc-integer (a)
(if (Math-integerp a)
1
(if (Math-objvecp a)
0
(list 'calcFunc-integer a)))
)
(list 'calcFunc-integer a))))
(defun calcFunc-real (a)
(if (Math-realp a)
1
(if (Math-objvecp a)
0
(list 'calcFunc-real a)))
)
(list 'calcFunc-real a))))
(defun calcFunc-constant (a)
(if (math-constp a)
1
(if (Math-objvecp a)
0
(list 'calcFunc-constant a)))
)
(list 'calcFunc-constant a))))
(defun calcFunc-refers (a b)
(if (math-expr-contains a b)
1
(if (eq (car-safe a) 'var)
(list 'calcFunc-refers a b)
0))
)
0)))
(defun calcFunc-negative (a)
(if (math-looks-negp a)
@ -1736,28 +1652,24 @@
(if (or (math-zerop a)
(math-posp a))
0
(list 'calcFunc-negative a)))
)
(list 'calcFunc-negative a))))
(defun calcFunc-variable (a)
(if (eq (car-safe a) 'var)
1
(if (Math-objvecp a)
0
(list 'calcFunc-variable a)))
)
(list 'calcFunc-variable a))))
(defun calcFunc-nonvar (a)
(if (eq (car-safe a) 'var)
(list 'calcFunc-nonvar a)
1)
)
1))
(defun calcFunc-istrue (a)
(if (math-is-true a)
1
0)
)
0))
@ -1851,14 +1763,12 @@
(append (list 'defun fname clargs)
doc
(math-do-arg-list-check args nil nil)
body)))
)
body))))
(defun math-clean-arg (arg)
(if (consp arg)
(math-clean-arg (nth 1 arg))
arg)
)
arg))
(defun math-do-arg-check (arg var is-opt is-rest)
(if is-opt
@ -1915,8 +1825,7 @@
(list 'and
(list chk var)
(list 'math-reject-arg var qqual)))))
(error "Unknown qualifier `%s'" qual-name)))))))
)
(error "Unknown qualifier `%s'" qual-name))))))))
(defun math-do-arg-list-check (args is-opt is-rest)
(cond ((null args) nil)
@ -1929,8 +1838,7 @@
(math-do-arg-list-check (cdr args) t nil))
((eq (car args) '&rest)
(math-do-arg-list-check (cdr args) nil t))
(t (math-do-arg-list-check (cdr args) is-opt is-rest)))
)
(t (math-do-arg-list-check (cdr args) is-opt is-rest))))
(defconst math-prim-funcs
'( (~= . math-nearly-equal)
@ -1949,27 +1857,23 @@
(if . if)
(^ . math-pow)
(expt . math-pow)
)
)
))
(defconst math-prim-vars
'( (nil . nil)
(t . t)
(&optional . &optional)
(&rest . &rest)
)
)
))
(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)))
body))
)
body)))
(defun math-define-body (body exp-env)
(math-define-list body)
)
(math-define-list body))
(defun math-define-list (body &optional quote)
(cond ((null body)
@ -1988,8 +1892,7 @@
(math-define-list (cdr body))))
(t
(cons (math-define-exp (car body))
(math-define-list (cdr body)))))
)
(math-define-list (cdr body))))))
(defun math-define-exp (exp)
(cond ((consp exp)
@ -2140,26 +2043,22 @@
(if (or (<= exp -1000000) (>= exp 1000000))
(list 'quote (math-normalize exp))
exp))
(t exp))
)
(t exp)))
(defun math-define-cond (forms)
(and forms
(cons (math-define-list (car forms))
(math-define-cond (cdr forms))))
)
(math-define-cond (cdr forms)))))
(defun math-complicated-lhs (body)
(and body
(or (not (symbolp (car body)))
(math-complicated-lhs (cdr (cdr body)))))
)
(math-complicated-lhs (cdr (cdr body))))))
(defun math-define-setf-list (body)
(and body
(cons (math-define-setf (nth 0 body) (nth 1 body))
(math-define-setf-list (cdr (cdr body)))))
)
(math-define-setf-list (cdr (cdr body))))))
(defun math-define-setf (place value)
(setq place (math-define-exp place)
@ -2175,16 +2074,14 @@
((eq (car-safe place) 'cdr)
(list 'setcdr (nth 1 place) value))
(t
(error "Bad place form for setf: %s" place)))
)
(error "Bad place form for setf: %s" place))))
(defun math-define-binop (op ident arg1 rest)
(if rest
(math-define-binop op ident
(list op arg1 (car rest))
(cdr rest))
(or arg1 ident))
)
(or arg1 ident)))
(defun math-define-let (vlist)
(and vlist
@ -2192,29 +2089,25 @@
(cons (car (car vlist))
(math-define-list (cdr (car vlist))))
(car vlist))
(math-define-let (cdr vlist))))
)
(math-define-let (cdr vlist)))))
(defun math-define-let-env (vlist)
(and vlist
(cons (if (consp (car vlist))
(car (car vlist))
(car vlist))
(math-define-let-env (cdr vlist))))
)
(math-define-let-env (cdr vlist)))))
(defun math-define-lambda (exp exp-env)
(nconc (list (nth 0 exp) ; 'lambda
(nth 1 exp)) ; arg list
(math-define-function-body (cdr (cdr exp))
(append (nth 1 exp) exp-env)))
)
(append (nth 1 exp) exp-env))))
(defun math-define-elt (seq idx)
(if idx
(math-define-elt (list 'elt seq (car idx)) (cdr idx))
seq)
)
seq))
@ -2224,8 +2117,7 @@
(let ((body (cons 'while (cons head body))))
(if (math-body-refers-to body 'math-break)
(cons 'catch (cons '(quote math-break) (list body)))
body))
)
body)))
(defmacro math-for (head &rest body)
@ -2234,8 +2126,7 @@
(cons 'while (cons t body)))))
(if (math-body-refers-to body 'math-break)
(cons 'catch (cons '(quote math-break) (list body)))
body))
)
body)))
(defun math-handle-for (head body)
(let* ((var (nth 0 (car head)))
@ -2291,16 +2182,14 @@
'+
'math-add)
var
save-step))))))))))
)
save-step)))))))))))
(defmacro math-foreach (head &rest body)
(let ((body (math-handle-foreach head body)))
(if (math-body-refers-to body 'math-break)
(cons 'catch (cons '(quote math-break) (list body)))
body))
)
body)))
(defun math-handle-foreach (head body)
@ -2317,24 +2206,20 @@
(append body
(list (list 'setq
var
(list 'cdr var))))))))))
)
(list 'cdr var)))))))))))
(defun math-body-refers-to (body thing)
(or (equal body thing)
(and (consp body)
(or (math-body-refers-to (car body) thing)
(math-body-refers-to (cdr body) thing))))
)
(math-body-refers-to (cdr body) thing)))))
(defun math-break (&optional value)
(throw 'math-break value)
)
(throw 'math-break value))
(defun math-return (&optional value)
(throw 'math-return value)
)
(throw 'math-return value))
@ -2359,6 +2244,6 @@
(+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
(if (eq (car x) 'calcFunc-geq) 1 0))
(math-read-expr-level (nth 3 op)) (nth 1 x))
(throw 'syntax "Syntax error")))))
)
(throw 'syntax "Syntax error"))))))
;;; calc-prog.el ends here

174
lisp/calc/calc-rewr.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-rewr.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -85,8 +85,7 @@
(calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
(- num (if pop-rules 1 0))
(list (and reselect sel))))
(calc-handle-whys))
)
(calc-handle-whys)))
(defun calc-locate-select-marker (expr) ; changes "sel"
(if (Math-primp expr)
@ -97,8 +96,7 @@
(setq sel (if sel t (nth 1 expr)))
(nth 1 expr))
(cons (car expr)
(mapcar 'calc-locate-select-marker (cdr expr)))))
)
(mapcar 'calc-locate-select-marker (cdr expr))))))
@ -136,8 +134,7 @@
(let (sel)
(setq expr (calc-locate-select-marker expr)))
(calc-pop-push-record-list n "rwrt" (list expr)))
(calc-handle-whys))
)
(calc-handle-whys)))
(defun calc-match (pat)
(interactive "sPattern: \n")
@ -158,8 +155,7 @@
(or (math-vectorp expr) (error "Argument must be a vector"))
(if (calc-is-inverse)
(calc-enter-result n "mtcn" (math-match-patterns pat expr t))
(calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))
)
(calc-enter-result n "mtch" (math-match-patterns pat expr nil))))))
@ -206,8 +202,7 @@
(insert "\nDone rewriting"
(if (= mmt-many 0) " (reached iteration limit)" "")
":\n" fmt "\n"))))
whole-expr)
)
whole-expr))
(setq math-rewrite-default-iters 100)
(defun math-rewrite-phase (sched)
@ -236,8 +231,7 @@
(setq whole-expr (math-normalize
(math-map-tree-rec whole-expr)))
(not (equal whole-expr save-expr)))))))
(setq sched (cdr sched)))
)
(setq sched (cdr sched))))
(defun calcFunc-rewrite (expr rules &optional many)
(or (null many) (integerp many)
@ -245,22 +239,19 @@
(math-reject-arg many 'fixnump))
(condition-case err
(math-rewrite expr rules (or many 1))
(error (math-reject-arg rules (nth 1 err))))
)
(error (math-reject-arg rules (nth 1 err)))))
(defun calcFunc-match (pat vec)
(or (math-vectorp vec) (math-reject-arg vec 'vectorp))
(condition-case err
(math-match-patterns pat vec nil)
(error (math-reject-arg pat (nth 1 err))))
)
(error (math-reject-arg pat (nth 1 err)))))
(defun calcFunc-matchnot (pat vec)
(or (math-vectorp vec) (math-reject-arg vec 'vectorp))
(condition-case err
(math-match-patterns pat vec t)
(error (math-reject-arg pat (nth 1 err))))
)
(error (math-reject-arg pat (nth 1 err)))))
(defun math-match-patterns (pat vec &optional not-flag)
(let ((newvec nil)
@ -269,23 +260,20 @@
(if (eq (not (math-apply-rewrites (car vec) crules))
not-flag)
(setq newvec (cons (car vec) newvec))))
(cons 'vec (nreverse newvec)))
)
(cons 'vec (nreverse newvec))))
(defun calcFunc-matches (expr pat)
(condition-case err
(if (math-apply-rewrites expr (math-compile-patterns pat))
1
0)
(error (math-reject-arg pat (nth 1 err))))
)
(error (math-reject-arg pat (nth 1 err)))))
(defun calcFunc-vmatches (expr pat)
(condition-case err
(or (math-apply-rewrites expr (math-compile-patterns pat))
0)
(error (math-reject-arg pat (nth 1 err))))
)
(error (math-reject-arg pat (nth 1 err)))))
@ -490,8 +478,7 @@
(list 'vec x t)))
(if (eq (car-safe pats) 'vec)
(cdr pats)
(list pats))))))))
)
(list pats)))))))))
(setq math-rewrite-whole nil)
(setq math-make-import-list nil)
@ -730,15 +717,13 @@
(or math-schedule
(sort math-all-phases '<)
(list 1)))
rule-set)))
)
rule-set))))
(defun math-flatten-lands (expr)
(if (eq (car-safe expr) 'calcFunc-land)
(append (math-flatten-lands (nth 1 expr))
(math-flatten-lands (nth 2 expr)))
(list expr))
)
(list expr)))
(defun math-rewrite-heads (expr &optional more all)
(let ((heads more)
@ -751,8 +736,7 @@
calcFunc-pand))))
(or (Math-primp expr)
(math-rewrite-heads-rec expr))
heads)
)
heads))
(defun math-rewrite-heads-rec (expr)
(or (memq (car expr) skips)
@ -763,8 +747,7 @@
(setq heads (cons (car expr) heads)))
(while (setq expr (cdr expr))
(or (Math-primp (car expr))
(math-rewrite-heads-rec (car expr))))))
)
(math-rewrite-heads-rec (car expr)))))))
(defun math-parse-schedule (sched)
(mapcar (function
@ -776,8 +759,7 @@
(if (eq (car-safe s) 'var)
(math-var-to-calcFunc s)
(error "Improper component in rewrite schedule"))))))
sched)
)
sched))
(defun math-rwcomp-match-vars (expr)
(if (Math-primp expr)
@ -797,15 +779,13 @@
(cons (car (nth 1 expr))
(mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
(cons (car expr)
(mapcar 'math-rwcomp-match-vars (cdr expr))))))
)
(mapcar 'math-rwcomp-match-vars (cdr expr)))))))
(defun math-rwcomp-register-expr (num)
(let ((entry (nth (1- (- math-num-regs num)) math-regs)))
(if (nth 2 entry)
(list 'neg (list 'calcFunc-register (nth 1 entry)))
(list 'calcFunc-register (nth 1 entry))))
)
(list 'calcFunc-register (nth 1 entry)))))
(defun math-rwcomp-substitute (expr old new)
(if (and (eq (car-safe old) 'var)
@ -814,8 +794,7 @@
(new-func (math-var-to-calcFunc new)))
(math-rwcomp-subst-rec expr))
(let ((old-func nil))
(math-rwcomp-subst-rec expr)))
)
(math-rwcomp-subst-rec expr))))
(defun math-rwcomp-subst-rec (expr)
(cond ((equal expr old) new)
@ -824,37 +803,31 @@
(math-build-call new-func (mapcar 'math-rwcomp-subst-rec
(cdr expr)))
(cons (car expr)
(mapcar 'math-rwcomp-subst-rec (cdr expr))))))
)
(mapcar 'math-rwcomp-subst-rec (cdr expr)))))))
(setq math-rwcomp-tracing nil)
(defun math-rwcomp-trace (instr)
(if math-rwcomp-tracing (progn (terpri) (princ instr)))
instr
)
instr)
(defun math-rwcomp-instr (&rest instr)
(setcdr math-prog-last
(setq math-prog-last (list (math-rwcomp-trace instr))))
)
(setq math-prog-last (list (math-rwcomp-trace instr)))))
(defun math-rwcomp-multi-instr (tail &rest instr)
(setcdr math-prog-last
(setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
)
(setq math-prog-last (list (math-rwcomp-trace (append instr tail))))))
(defun math-rwcomp-bind-var (reg var)
(setcar (math-rwcomp-reg-entry reg) (nth 2 var))
(setq math-bound-vars (cons (nth 2 var) math-bound-vars))
(math-rwcomp-do-conditions)
)
(math-rwcomp-do-conditions))
(defun math-rwcomp-unbind-vars (mark)
(while (not (eq math-bound-vars mark))
(setcar (assq (car math-bound-vars) math-regs) nil)
(setq math-bound-vars (cdr math-bound-vars)))
)
(setq math-bound-vars (cdr math-bound-vars))))
(defun math-rwcomp-do-conditions ()
(let ((cond math-conds))
@ -864,8 +837,7 @@
(setq math-conds (delq (car cond) math-conds))
(setcar cond 1)
(math-rwcomp-cond-instr expr)))
(setq cond (cdr cond))))
)
(setq cond (cdr cond)))))
(defun math-rwcomp-cond-instr (expr)
(let (op arg)
@ -929,8 +901,7 @@
(list 'calcFunc-lor
math-remembering (nth 1 expr))
(nth 1 expr))))
(t (math-rwcomp-instr 'cond expr))))
)
(t (math-rwcomp-instr 'cond expr)))))
(defun math-rwcomp-same-instr (reg1 reg2 neg)
(math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
@ -938,8 +909,7 @@
neg)
'same-neg
'same)
reg1 reg2)
)
reg1 reg2))
(defun math-rwcomp-copy-instr (reg1 reg2 neg)
(if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
@ -947,19 +917,16 @@
neg)
(math-rwcomp-instr 'copy-neg reg1 reg2)
(or (eq reg1 reg2)
(math-rwcomp-instr 'copy reg1 reg2)))
)
(math-rwcomp-instr 'copy reg1 reg2))))
(defun math-rwcomp-reg ()
(prog1
math-num-regs
(setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
math-num-regs (1+ math-num-regs)))
)
math-num-regs (1+ math-num-regs))))
(defun math-rwcomp-reg-entry (num)
(nth (1- (- math-num-regs num)) math-regs)
)
(nth (1- (- math-num-regs num)) math-regs))
(defun math-rwcomp-pattern (expr part &optional not-direct)
@ -1195,8 +1162,7 @@
(while args
(math-rwcomp-pattern (car (car args)) (cdr (car args)))
(setq num (1+ num)
args (cdr args)))))))))
)
args (cdr args))))))))))
(defun math-rwcomp-best-reg (x)
(or (and (eq (car-safe x) 'var)
@ -1207,8 +1173,7 @@
(progn
(setcar (cdr (cdr entry)) t)
(nth 1 entry)))))
(math-rwcomp-reg))
)
(math-rwcomp-reg)))
(defun math-rwcomp-all-regs-done (expr)
(if (Math-primp expr)
@ -1226,8 +1191,7 @@
(math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
(while (and (setq expr (cdr expr))
(math-rwcomp-all-regs-done (car expr))))
(null expr))))
)
(null expr)))))
(defun math-rwcomp-no-vars (expr)
(if (Math-primp expr)
@ -1242,8 +1206,7 @@
(progn
(while (and (setq expr (cdr expr))
(math-rwcomp-no-vars (car expr))))
(null expr))))
)
(null expr)))))
(defun math-rwcomp-is-algebraic (expr)
(if (Math-primp expr)
@ -1254,8 +1217,7 @@
(progn
(while (and (setq expr (cdr expr))
(math-rwcomp-is-algebraic (car expr))))
(null expr))))
)
(null expr)))))
(defun math-rwcomp-is-constrained (expr not-these)
(if (Math-primp expr)
@ -1266,8 +1228,7 @@
(memq (car expr) not-these)
(and (memq 'commut (get (car expr) 'math-rewrite-props))
(or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
(eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
)
(eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))))
(defun math-rwcomp-optional-arg (head argp)
(let ((arg (car argp)))
@ -1286,8 +1247,7 @@
(partp (math-rwcomp-optional-arg head part)))
(and partp
(setcar argp (math-rwcomp-neg (car part)))
(math-neg partp))))))
)
(math-neg partp)))))))
(defun math-rwcomp-neg (expr)
(if (memq (car-safe expr) '(* /))
@ -1296,8 +1256,7 @@
(if (eq (car-safe (nth 2 expr)) 'var)
(list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
(math-neg expr)))
(math-neg expr))
)
(math-neg expr)))
(defun math-rwcomp-assoc-args (expr)
(if (and (eq (car-safe (nth 1 expr)) (car expr))
@ -1307,8 +1266,7 @@
(if (and (eq (car-safe (nth 2 expr)) (car expr))
(= (length (nth 2 expr)) 3))
(math-rwcomp-assoc-args (nth 2 expr))
(setq math-args (cons (nth 2 expr) math-args)))
)
(setq math-args (cons (nth 2 expr) math-args))))
(defun math-rwcomp-addsub-args (expr)
(if (memq (car-safe (nth 1 expr)) '(+ -))
@ -1318,13 +1276,11 @@
(setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
(if (eq (car-safe (nth 2 expr)) '+)
(math-rwcomp-addsub-args (nth 2 expr))
(setq math-args (cons (nth 2 expr) math-args))))
)
(setq math-args (cons (nth 2 expr) math-args)))))
(defun math-rwcomp-order (a b)
(< (math-rwcomp-priority (car a))
(math-rwcomp-priority (car b)))
)
(math-rwcomp-priority (car b))))
;;; Order of priority: 0 Constants and other exact matches (first)
;;; 10 Functions (except below)
@ -1355,8 +1311,7 @@
40
(if (memq 'algebraic props)
30
10))))))
)
10)))))))
(defun math-rwcomp-count-refs (var)
(let ((count (or (math-expr-contains-count math-pattern var) 0))
@ -1374,8 +1329,7 @@
(or (math-expr-contains-count
(nth 2 (nth 1 (car p))) var) 0))))))
(setq p (cdr p)))
count)
)
count))
(defun math-rwcomp-count-pnots (expr)
(if (Math-primp expr)
@ -1385,8 +1339,7 @@
(let ((count 0))
(while (setq expr (cdr expr))
(setq count (+ count (math-rwcomp-count-pnots (car expr)))))
count)))
)
count))))
;;; In the current implementation, all associative functions must
;;; also be commutative.
@ -1448,8 +1401,7 @@
(if back
'(setq btrack (cdr btrack))
'btrack)
''((backtrack))))
)
''((backtrack)))))
;;; This monstrosity is necessary because the use of static vectors of
;;; registers makes rewrite rules non-reentrant. Yucko!
@ -1458,8 +1410,7 @@
'(setcar rules (quote (nil nil nil no-phase)))
(list 'unwind-protect
form
'(setcar rules orig)))
)
'(setcar rules orig))))
(setq math-rewrite-phase 1)
@ -1922,8 +1873,7 @@
(t (error "%s is not a valid rewrite opcode" op))))))
(setq rules (cdr rules)))
result))
)
result)))
(defun math-rwapply-neg (expr)
(if (and (consp expr)
@ -1935,15 +1885,13 @@
(math-neg (nth 1 expr))
(list '* -1 (nth 1 expr)))
(nth 2 expr)))
(math-neg expr))
)
(math-neg expr)))
(defun math-rwapply-inv (expr)
(if (and (Math-integerp expr)
calc-prefer-frac)
(math-make-frac 1 expr)
(list '/ 1 expr))
)
(list '/ 1 expr)))
(defun math-rwapply-replace-regs (expr)
(cond ((Math-primp expr)
@ -2049,16 +1997,14 @@
(aref regs (nth 1 (nth 1 expr)))
(cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
(cdr (nth 1 expr)))))))
(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
)
(t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))))
(defun math-rwapply-reg-looks-negp (expr)
(if (eq (car-safe expr) 'calcFunc-register)
(math-looks-negp (aref regs (nth 1 expr)))
(if (memq (car-safe expr) '(* /))
(or (math-rwapply-reg-looks-negp (nth 1 expr))
(math-rwapply-reg-looks-negp (nth 2 expr)))))
)
(math-rwapply-reg-looks-negp (nth 2 expr))))))
(defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
(if (eq (car expr) 'calcFunc-register)
@ -2069,8 +2015,7 @@
(nth 2 expr)))
(math-rwapply-replace-regs (list (car expr)
(nth 1 expr)
(math-rwapply-reg-neg (nth 2 expr))))))
)
(math-rwapply-reg-neg (nth 2 expr)))))))
(defun math-rwapply-remember (old new)
(let ((varval (symbol-value (nth 2 (car ruleset))))
@ -2089,9 +2034,8 @@
(list (list 'same 0 1)
(list 'done new nil))
nil nil)
(cdr rules))))))
)
(cdr rules)))))))
;;; calc-rewr.el ends here

33
lisp/calc/calc-rules.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-rules.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -33,8 +33,7 @@
(prog2
(message "Preparing rule set %s..." name)
(math-read-plain-expr rules t)
(message "Preparing rule set %s...done" name))
)
(message "Preparing rule set %s...done" name)))
(defun calc-CommuteRules ()
"CommuteRules"
@ -56,8 +55,7 @@ select(plain(a != b)) := select(b != a),
select(a < b) := select(b > a),
select(a > b) := select(b < a),
select(a <= b) := select(b >= a),
select(a >= b) := select(b <= a) ]")
)
select(a >= b) := select(b <= a) ]"))
(defun calc-JumpRules ()
"JumpRules"
@ -87,8 +85,7 @@ plain(y = a ^ select(2)) := select(sqrt(y)) = a,
plain(y = a ^ select(x)) := y ^ select(1/x) = a,
plain(y = select(x) ^ a) := log(y, select(x)) = a,
plain(y = log(a, select(x))) := select(x) ^ y = a,
plain(y = log(select(x), a)) := select(x) ^ (1/y) = a ]")
)
plain(y = log(select(x), a)) := select(x) ^ (1/y) = a ]"))
(defun calc-DistribRules ()
"DistribRules"
@ -161,8 +158,7 @@ tanh(select(a + b)) := (tanh(select(a)) + tanh(b)) /
x && select(a || b) := (x && select(a)) || (x && b),
select(a || b) && x := (select(a) && x) || (b && x),
! select(a && b) := (!a) || (!b),
! select(a || b) := (!a) && (!b) ]")
)
! select(a || b) := (!a) && (!b) ]"))
(defun calc-MergeRules ()
"MergeRules"
@ -235,8 +231,7 @@ select(log(a,x)) / log(b,x) := select(log(a, b)),
log(a,x) / select(log(b,x)) := select(log(a, b)),
select(log(a,x)) / b := select(log(a ^ (1/b),x)),
log(a,x) / select(b) := select(log(a ^ (1/b),x)),
select(x && a) || (x && opt(b)) := x && (select(a) || b) ]")
)
select(x && a) || (x && opt(b)) := x && (select(a) || b) ]"))
(defun calc-NegateRules ()
"NegateRules"
@ -290,8 +285,7 @@ a < select(x) := -a > select(-x),
a > select(x) := -a < select(-x),
a <= select(x) := -a >= select(-x),
a >= select(x) := -a <= select(-x),
select(x) := -select(-x) ]")
)
select(x) := -select(-x) ]"))
(defun calc-InvertRules ()
"InvertRules"
@ -319,8 +313,7 @@ a < select(x) := 1/a > select(1/x),
a > select(x) := 1/a < select(1/x),
a <= select(x) := 1/a >= select(1/x),
a >= select(x) := 1/a <= select(1/x),
select(x) := 1 / select(1/x) ]")
)
select(x) := 1 / select(1/x) ]"))
(defun calc-FactorRules ()
@ -340,8 +333,7 @@ thecoefs(x, [z, 0, c]) := thefactors(x, [rz + rc x, rz - rc x])
:: negative(c)
:: let(rz := esimplify(sqrt(z))) :: !matches(rz, sqrt(rzz))
:: let(rc := esimplify(sqrt(-c))) :: !matches(rc, sqrt(rcc))
]")
)
]"))
;;(setq var-FactorRules 'calc-FactorRules)
@ -352,8 +344,7 @@ thecoefs(x, [z, 0, c]) := thefactors(x, [rz + rc x, rz - rc x])
opt(a) ln(x) + opt(b) ln(y) := 2 a esimplify(arctanh(x-1))
:: a + b = 0 :: nrat(x + y) = 2 || nrat(x - y) = 2,
a * (b + c) := a b + a c :: constant(a)
]")
)
]"))
;;(setq var-IntegAfterRules 'calc-IntegAfterRules)
@ -439,6 +430,6 @@ fitsystem(y, xv, pv, 0) := fitsystem(y, xv, cons(fvh,fvt))
:: let(cons(fvh,fvt),
solve(pv, table(fitparam(j), j, 1,
hasfitparams(pv)))),
fitparam(n) = x := x ]")
)
fitparam(n) = x := x ]"))
;;; calc-rules.el ends here

142
lisp/calc/calc-sel.el
View File

@ -52,23 +52,19 @@
(car entry) found)))
found)
(calc-grow-assoc-formula (car entry) found))
(car entry)))))))
)
(car entry))))))))
(defun calc-select-once (num)
(interactive "P")
(calc-select-here num t)
)
(calc-select-here num t))
(defun calc-select-here-maybe (num)
(interactive "P")
(calc-select-here num nil t)
)
(calc-select-here num nil t))
(defun calc-select-once-maybe (num)
(interactive "P")
(calc-select-here num t t)
)
(calc-select-here num t t))
(defun calc-select-additional ()
(interactive)
@ -88,8 +84,7 @@
(car entry) sel)))
sel)
(calc-grow-assoc-formula (car entry) found)))
(car entry)))))
)
(car entry))))))
(defun calc-select-more (num)
(interactive "P")
@ -102,8 +97,7 @@
(>= (setq num (1- (prefix-numeric-value num))) 0))
(setq sel (calc-find-assoc-parent-formula (car entry) sel)))
(calc-change-current-selection sel))
(calc-select-here num))))
)
(calc-select-here num)))))
(defun calc-select-less (num)
(interactive "p")
@ -125,8 +119,7 @@
(setq op (assq (car-safe sel) calc-assoc-ops))
(memq (car old) (nth index op))
(setq num (1+ num))))
sel)))))
)
sel))))))
(defun calc-select-part (num)
(interactive "P")
@ -138,8 +131,7 @@
num)))
(if sel
(calc-change-current-selection sel)
(error "%d is not a valid sub-formula index" num))))
)
(error "%d is not a valid sub-formula index" num)))))
(defun calc-find-nth-part (expr num)
(if (and calc-assoc-selections
@ -149,8 +141,7 @@
(if (eq (car-safe expr) 'intv)
(and (>= num 1) (<= num 2) (nth (1+ num) expr))
(and (not (Math-primp expr)) (>= num 1) (< num (length expr))
(nth num expr))))
)
(nth num expr)))))
(defun calc-find-nth-part-rec (expr) ; uses num, op
(or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
@ -162,8 +153,7 @@
(memq (car expr) (nth 2 op)))
(calc-find-nth-part-rec (nth 2 expr))
(and (= (setq num (1- num)) 0)
(nth 2 expr))))
)
(nth 2 expr)))))
(defun calc-select-next (num)
(interactive "p")
@ -200,8 +190,7 @@
(calc-change-current-selection sel))
(if (Math-primp (car entry))
(calc-change-current-selection (car entry))
(calc-select-part num))))))
)
(calc-select-part num)))))))
(defun calc-select-previous (num)
(interactive "p")
@ -246,8 +235,7 @@
(calc-find-nth-part-rec (car entry))
(- 1 num))
(length (car entry)))))
(calc-select-part (- len num))))))))
)
(calc-select-part (- len num)))))))))
(defun calc-find-parent-formula (expr part)
(cond ((eq expr part) t)
@ -258,13 +246,11 @@
(not (setq res (calc-find-parent-formula
(car p) part)))))
(and p
(if (eq res t) expr res)))))
)
(if (eq res t) expr res))))))
(defun calc-find-assoc-parent-formula (expr part)
(calc-grow-assoc-formula expr (calc-find-parent-formula expr part))
)
(calc-grow-assoc-formula expr (calc-find-parent-formula expr part)))
(defun calc-grow-assoc-formula (expr part)
(if calc-assoc-selections
@ -277,8 +263,7 @@
(nth (calc-find-sub-formula new part) op)))
(setq part new))))
part)
part)
)
part))
(defun calc-find-sub-formula (expr part)
(cond ((eq expr part) t)
@ -288,15 +273,13 @@
(while (and (setq expr (cdr expr))
(not (calc-find-sub-formula (car expr) part)))
(setq num (1+ num)))
(and expr num))))
)
(and expr num)))))
(defun calc-unselect (num)
(interactive "P")
(calc-wrapper
(calc-prepare-selection num)
(calc-change-current-selection nil))
)
(calc-change-current-selection nil)))
(defun calc-clear-selections ()
(interactive)
@ -309,8 +292,7 @@
(calc-prepare-selection n)
(calc-change-current-selection nil)))
(setq n (1+ n))))
(calc-clear-command-flag 'position-point))
)
(calc-clear-command-flag 'position-point)))
(defun calc-show-selections (arg)
(interactive "P")
@ -334,8 +316,7 @@
(calc-change-current-selection sel)))))
(message (if calc-show-selections
"Displaying only selected part of formulas"
"Displaying all but selected part of formulas")))
)
"Displaying all but selected part of formulas"))))
(defun calc-preserve-point ()
(or (looking-at "\\.\n+\\'")
@ -343,8 +324,7 @@
(setq calc-final-point-line (+ (count-lines (point-min) (point))
(if (bolp) 1 0))
calc-final-point-column (current-column))
(calc-set-command-flag 'position-point)))
)
(calc-set-command-flag 'position-point))))
(defun calc-enable-selections (arg)
(interactive "P")
@ -356,8 +336,7 @@
(calc-set-command-flag 'renum-stack)
(message (if calc-use-selections
"Commands operate only on selected sub-formulas"
"Selections of sub-formulas have no effect")))
)
"Selections of sub-formulas have no effect"))))
(defun calc-break-selections (arg)
(interactive "P")
@ -368,8 +347,7 @@
(not calc-assoc-selections)))
(message (if calc-assoc-selections
"Selection treats a+b+c as a sum of three terms"
"Selection treats a+b+c as (a+b)+c")))
)
"Selection treats a+b+c as (a+b)+c"))))
(defun calc-prepare-selection (&optional num)
(or num (setq num (calc-locate-cursor-element (point))))
@ -392,8 +370,7 @@
(+ (car (math-stack-value-offset calc-selection-cache-comp))
(length calc-left-label)
(if calc-line-numbering 4 0))))))
(calc-preserve-point)
)
(calc-preserve-point))
(setq calc-selection-cache-entry nil)
;;; The following ensures that no two subformulas will be "eq" to each other!
@ -402,8 +379,7 @@
(equal x '(float 0 0)))
(list 'cplx x 0)
(calc-encase-atoms-rec x)
x)
)
x))
(defun calc-encase-atoms-rec (x)
(or (Math-primp x)
@ -414,8 +390,7 @@
(if (or (not (consp (car x)))
(equal (car x) '(float 0 0)))
(setcar x (list 'cplx (car x) 0))
(calc-encase-atoms-rec (car x))))))
)
(calc-encase-atoms-rec (car x)))))))
(defun calc-find-selected-part ()
(let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
@ -441,8 +416,7 @@
(and (>= math-comp-sel-hpos 0)
(> calc-selection-true-num 0)
(math-composition-to-string calc-selection-cache-comp 1000000))
(nth 1 math-comp-sel-tag))
)
(nth 1 math-comp-sel-tag)))
(defun calc-change-current-selection (sub-expr)
(or (eq sub-expr (nth 2 calc-selection-cache-entry))
@ -457,8 +431,7 @@
(delete-region top (point))
(let ((calc-selection-cache-default-entry calc-selection-cache-entry))
(insert (math-format-stack-value calc-selection-cache-entry)
"\n"))))
)
"\n")))))
(defun calc-top-selected (&optional n m)
(and calc-any-selections
@ -473,25 +446,21 @@
(if (nth 2 (car top))
(setq sel (if sel t (nth 2 (car top)))))
(setq top (cdr top)))
sel)))
)
sel))))
(defun calc-replace-sub-formula (expr old new)
(setq new (calc-encase-atoms new))
(calc-replace-sub-formula-rec expr)
)
(calc-replace-sub-formula-rec expr))
(defun calc-replace-sub-formula-rec (expr)
(cond ((eq expr old) new)
((Math-primp expr) expr)
(t
(cons (car expr)
(mapcar 'calc-replace-sub-formula-rec (cdr expr)))))
)
(mapcar 'calc-replace-sub-formula-rec (cdr expr))))))
(defun calc-sel-error ()
(error "Illegal operation on sub-formulas")
)
(error "Illegal operation on sub-formulas"))
(defun calc-replace-selections (n vals m)
(if (calc-top-selected n m)
@ -538,8 +507,7 @@
(calc-push-list vals))))
(t (calc-sel-error))))
(calc-pop-stack n m t)
(calc-push-list vals m))
)
(calc-push-list vals m)))
(setq calc-keep-selection t)
(defun calc-delete-selection (n)
@ -590,32 +558,28 @@
(copy-sequence
parent)))))
n)))))
(calc-pop-stack 1 n t)))
)
(calc-pop-stack 1 n t))))
(defun calc-roll-down-with-selections (n m)
(let ((vals (append (calc-top-list m 1)
(calc-top-list (- n m) (1+ m))))
(sels (append (calc-top-list m 1 'sel)
(calc-top-list (- n m) (1+ m) 'sel))))
(calc-pop-push-list n vals 1 sels))
)
(calc-pop-push-list n vals 1 sels)))
(defun calc-roll-up-with-selections (n m)
(let ((vals (append (calc-top-list (- n m) 1)
(calc-top-list m (- n m -1))))
(sels (append (calc-top-list (- n m) 1 'sel)
(calc-top-list m (- n m -1) 'sel))))
(calc-pop-push-list n vals 1 sels))
)
(calc-pop-push-list n vals 1 sels)))
(defun calc-auto-selection (entry)
(or (nth 2 entry)
(progn
(and (boundp 'reselect) (setq reselect nil))
(calc-prepare-selection)
(calc-grow-assoc-formula (car entry) (calc-find-selected-part))))
)
(calc-grow-assoc-formula (car entry) (calc-find-selected-part)))))
(defun calc-copy-selection ()
(interactive)
@ -623,8 +587,7 @@
(calc-preserve-point)
(let* ((num (max 1 (calc-locate-cursor-element (point))))
(entry (calc-top num 'entry)))
(calc-push (or (calc-auto-selection entry) (car entry)))))
)
(calc-push (or (calc-auto-selection entry) (car entry))))))
(defun calc-del-selection ()
(interactive)
@ -634,8 +597,7 @@
(entry (calc-top num 'entry))
(sel (calc-auto-selection entry)))
(setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
(calc-delete-selection num)))
)
(calc-delete-selection num))))
(defun calc-enter-selection ()
(interactive)
@ -658,8 +620,7 @@
expr sel alg))
num
(list (and reselect alg))))))
(calc-handle-whys)))
)
(calc-handle-whys))))
(defun calc-edit-selection ()
(interactive)
@ -676,8 +637,7 @@
(calc-edit-mode (list 'calc-finish-selection-edit
num (list 'quote sel) reselect))
(insert str "\n"))))
(calc-show-edit-buffer)
)
(calc-show-edit-buffer))
(defun calc-finish-selection-edit (num sel reselect)
(let ((buf (current-buffer))
@ -703,8 +663,7 @@
num
(list (and reselect val)))
(calc-push val)
(error "Original selection has been lost"))))))
)
(error "Original selection has been lost")))))))
(defun calc-sel-evaluate (arg)
(interactive "p")
@ -723,8 +682,7 @@
(car entry) sel val))
num
(list (and reselect val))))))
(calc-handle-whys)))
)
(calc-handle-whys))))
(defun calc-sel-expand-formula (arg)
(interactive "p")
@ -749,8 +707,7 @@
(car entry) sel val))
num
(list (and reselect val))))))
(calc-handle-whys)))
)
(calc-handle-whys))))
(defun calc-sel-mult-both-sides (no-simp &optional divide)
(interactive "P")
@ -811,13 +768,11 @@
expr sel alg))
num
(list (and reselect alg)))))
(calc-handle-whys)))
)
(calc-handle-whys))))
(defun calc-sel-div-both-sides (no-simp)
(interactive "P")
(calc-sel-mult-both-sides no-simp t)
)
(calc-sel-mult-both-sides no-simp t))
(defun calc-sel-add-both-sides (no-simp &optional subtract)
(interactive "P")
@ -857,11 +812,10 @@
expr sel alg))
num
(list (and reselect alg)))))
(calc-handle-whys)))
)
(calc-handle-whys))))
(defun calc-sel-sub-both-sides (no-simp)
(interactive "P")
(calc-sel-add-both-sides no-simp t)
)
(calc-sel-add-both-sides no-simp t))
;;; calc-sel.el ends here

138
lisp/calc/calc-stat.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-stat.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -34,36 +34,31 @@
(defun calc-vector-count (arg)
(interactive "P")
(calc-slow-wrapper
(calc-vector-op "coun" 'calcFunc-vcount arg))
)
(calc-vector-op "coun" 'calcFunc-vcount arg)))
(defun calc-vector-sum (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-vector-op "vprd" 'calcFunc-vprod arg)
(calc-vector-op "vsum" 'calcFunc-vsum arg)))
)
(calc-vector-op "vsum" 'calcFunc-vsum arg))))
(defun calc-vector-product (arg)
(interactive "P")
(calc-hyperbolic-func)
(calc-vector-sum arg)
)
(calc-vector-sum arg))
(defun calc-vector-max (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-inverse)
(calc-vector-op "vmin" 'calcFunc-vmin arg)
(calc-vector-op "vmax" 'calcFunc-vmax arg)))
)
(calc-vector-op "vmax" 'calcFunc-vmax arg))))
(defun calc-vector-min (arg)
(interactive "P")
(calc-invert-func)
(calc-vector-max arg)
)
(calc-vector-max arg))
(defun calc-vector-mean (arg)
(interactive "P")
@ -74,35 +69,30 @@
(calc-vector-op "medn" 'calcFunc-vmedian arg))
(if (calc-is-inverse)
(calc-vector-op "meae" 'calcFunc-vmeane arg)
(calc-vector-op "mean" 'calcFunc-vmean arg))))
)
(calc-vector-op "mean" 'calcFunc-vmean arg)))))
(defun calc-vector-mean-error (arg)
(interactive "P")
(calc-invert-func)
(calc-vector-mean arg)
)
(calc-vector-mean arg))
(defun calc-vector-median (arg)
(interactive "P")
(calc-hyperbolic-func)
(calc-vector-mean arg)
)
(calc-vector-mean arg))
(defun calc-vector-harmonic-mean (arg)
(interactive "P")
(calc-invert-func)
(calc-hyperbolic-func)
(calc-vector-mean arg)
)
(calc-vector-mean arg))
(defun calc-vector-geometric-mean (arg)
(interactive "P")
(calc-slow-wrapper
(if (calc-is-hyperbolic)
(calc-binary-op "geom" 'calcFunc-agmean arg)
(calc-vector-op "geom" 'calcFunc-vgmean arg)))
)
(calc-vector-op "geom" 'calcFunc-vgmean arg))))
(defun calc-vector-sdev (arg)
(interactive "P")
@ -113,27 +103,23 @@
(calc-vector-op "var" 'calcFunc-vvar arg))
(if (calc-is-inverse)
(calc-vector-op "psdv" 'calcFunc-vpsdev arg)
(calc-vector-op "sdev" 'calcFunc-vsdev arg))))
)
(calc-vector-op "sdev" 'calcFunc-vsdev arg)))))
(defun calc-vector-pop-sdev (arg)
(interactive "P")
(calc-invert-func)
(calc-vector-sdev arg)
)
(calc-vector-sdev arg))
(defun calc-vector-variance (arg)
(interactive "P")
(calc-hyperbolic-func)
(calc-vector-sdev arg)
)
(calc-vector-sdev arg))
(defun calc-vector-pop-variance (arg)
(interactive "P")
(calc-invert-func)
(calc-hyperbolic-func)
(calc-vector-sdev arg)
)
(calc-vector-sdev arg))
(defun calc-vector-covariance (arg)
(interactive "P")
@ -146,28 +132,24 @@
(calc-enter-result n "pcov" (cons 'calcFunc-vpcov
(calc-top-list-n n)))
(calc-enter-result n "cov" (cons 'calcFunc-vcov
(calc-top-list-n n)))))))
)
(calc-top-list-n n))))))))
(defun calc-vector-pop-covariance (arg)
(interactive "P")
(calc-invert-func)
(calc-vector-covariance arg)
)
(calc-vector-covariance arg))
(defun calc-vector-correlation (arg)
(interactive "P")
(calc-hyperbolic-func)
(calc-vector-covariance arg)
)
(calc-vector-covariance arg))
(defun calc-vector-op (name func arg)
(setq calc-aborted-prefix name
arg (prefix-numeric-value arg))
(if (< arg 0)
(error "Negative arguments not allowed"))
(calc-enter-result arg name (cons func (calc-top-list-n arg)))
)
(calc-enter-result arg name (cons func (calc-top-list-n arg))))
@ -180,12 +162,10 @@
;;; non-vectors.
(defun calcFunc-vsum (&rest vecs)
(math-reduce-many-vecs 'calcFunc-add 'calcFunc-vsum vecs 0)
)
(math-reduce-many-vecs 'calcFunc-add 'calcFunc-vsum vecs 0))
(defun calcFunc-vprod (&rest vecs)
(math-reduce-many-vecs 'calcFunc-mul 'calcFunc-vprod vecs 1)
)
(math-reduce-many-vecs 'calcFunc-mul 'calcFunc-vprod vecs 1))
(defun calcFunc-vmax (&rest vecs)
(if (eq (car-safe (car vecs)) 'sdev)
@ -193,8 +173,7 @@
(if (eq (car-safe (car vecs)) 'intv)
(nth 3 (math-fix-int-intv (car vecs)))
(math-reduce-many-vecs 'calcFunc-max 'calcFunc-vmax vecs
'(neg (var inf var-inf)))))
)
'(neg (var inf var-inf))))))
(defun calcFunc-vmin (&rest vecs)
(if (eq (car-safe (car vecs)) 'sdev)
@ -202,8 +181,7 @@
(if (eq (car-safe (car vecs)) 'intv)
(nth 2 (math-fix-int-intv (car vecs)))
(math-reduce-many-vecs 'calcFunc-min 'calcFunc-vmin vecs
'(var inf var-inf))))
)
'(var inf var-inf)))))
(defun math-reduce-many-vecs (func whole-func vecs ident)
(let ((const-part nil)
@ -236,8 +214,7 @@
(if symb-part
(funcall func const-part (cons whole-func symb-part))
const-part))
(if symb-part (cons whole-func symb-part) ident)))
)
(if symb-part (cons whole-func symb-part) ident))))
;;; Return the number of data elements among the arguments.
@ -256,8 +233,7 @@
(symbol-value (nth 2 (car vecs)))))
(math-reject-arg (car vecs) 'numvecp))))
vecs (cdr vecs)))
count)
)
count))
(defun math-count-elements (vec)
(let ((count 0))
@ -265,8 +241,7 @@
(setq count (if (Math-vectorp (car vec))
(+ count (math-count-elements (car vec)))
(1+ count))))
count)
)
count))
(defun math-flatten-many-vecs (vecs)
@ -285,12 +260,10 @@
(nth 2 (car p))))
(math-reject-arg (car p) 'numvecp)))))
p (cdr p)))
vec)
)
vec))
(defun calcFunc-vflat (&rest vecs)
(math-flatten-many-vecs vecs)
)
(math-flatten-many-vecs vecs))
(defun math-split-sdev-vec (vec zero-ok)
(let ((means (list 'vec))
@ -317,8 +290,7 @@
exact t))
(setq means (cons p means)))))
(list (nreverse means)
(and wts (nreverse wts)))))
)
(and wts (nreverse wts))))))
;;; Return the arithmetic mean of the argument numbers or vectors.
@ -344,16 +316,14 @@
(calcFunc-map '(var div var-div)
means sqrwts))
suminvsqrwts))
(math-div (calcFunc-reduce '(var add var-add) means) len))))))
)
(math-div (calcFunc-reduce '(var add var-add) means) len)))))))
(defun math-fix-int-intv (x)
(if (math-floatp x)
x
(list 'intv 3
(if (memq (nth 1 x) '(2 3)) (nth 2 x) (math-add (nth 2 x) 1))
(if (memq (nth 1 x) '(1 3)) (nth 3 x) (math-sub (nth 3 x) 1))))
)
(if (memq (nth 1 x) '(1 3)) (nth 3 x) (math-sub (nth 3 x) 1)))))
;;; Compute the mean with an error estimate.
(defun calcFunc-vmeane (&rest vecs)
@ -390,8 +360,7 @@
means
(math-neg mean)))
2))
(math-mul len (1- len))))))))))
)
(math-mul len (1- len)))))))))))
;;; Compute the median of a list of values.
@ -413,8 +382,7 @@
(setq flat (sort flat 'math-lessp))
(if (= (% len 2) 0)
(math-div (math-add (nth (1- hlen) flat) (nth hlen flat)) 2)
(nth hlen flat)))))
)
(nth hlen flat))))))
(defun calcFunc-vgmean (&rest vecs)
@ -426,8 +394,7 @@
(let ((x (calcFunc-reduce '(var mul math-mul) flat)))
(if (= len 2)
(math-sqrt x)
(math-pow x (list 'frac 1 len)))))))
)
(math-pow x (list 'frac 1 len))))))))
(defun calcFunc-agmean (a b)
@ -446,8 +413,7 @@
(setq mean (math-mul-float (math-add-float a b) '(float 5 -1))
b (math-sqrt-float (math-mul-float a b))
a mean))
a))))
)
a)))))
(defun calcFunc-vhmean (&rest vecs)
@ -458,8 +424,7 @@
(math-with-extra-prec 2
(math-div len
(calcFunc-reduce '(var add math-add)
(calcFunc-map '(var inv var-inv) flat))))))
)
(calcFunc-map '(var inv var-inv) flat)))))))
@ -471,8 +436,7 @@
(if (eq (car-safe (car vecs)) 'intv)
(math-intv-variance (car vecs) nil)
(math-sqr (nth 2 (car vecs))))
(math-covariance vecs nil nil 0))
)
(math-covariance vecs nil nil 0)))
(defun calcFunc-vsdev (&rest vecs)
(if (and (= (length vecs) 1)
@ -483,8 +447,7 @@
(math-sqrt-12))
(math-sqrt (calcFunc-vvar (car vecs))))
(nth 2 (car vecs)))
(math-sqrt (math-covariance vecs nil nil 0)))
)
(math-sqrt (math-covariance vecs nil nil 0))))
;;; Compute the population variance or std deviation of numbers or vectors.
(defun calcFunc-vpvar (&rest vecs)
@ -493,8 +456,7 @@
(if (eq (car-safe (car vecs)) 'intv)
(math-intv-variance (car vecs) t)
(math-sqr (nth 2 (car vecs))))
(math-covariance vecs nil t 0))
)
(math-covariance vecs nil t 0)))
(defun calcFunc-vpsdev (&rest vecs)
(if (and (= (length vecs) 1)
@ -505,8 +467,7 @@
(math-sqrt-12))
(math-sqrt (calcFunc-vpvar (car vecs))))
(nth 2 (car vecs)))
(math-sqrt (math-covariance vecs nil t 0)))
)
(math-sqrt (math-covariance vecs nil t 0))))
(defun math-intv-variance (x pop)
(or (math-constp x) (math-reject-arg x 'constp))
@ -521,21 +482,17 @@
(calcFunc-sum '(^ (- (var X var-X) (/ 1 2)) 2)
'(var X var-X)
(math-neg hlen) (math-add hlen 1)))
(if pop (math-add len 1) len))))
)
(if pop (math-add len 1) len)))))
;;; Compute the covariance and linear correlation coefficient.
(defun calcFunc-vcov (vec1 &optional vec2)
(math-covariance (list vec1) (list vec2) nil 1)
)
(math-covariance (list vec1) (list vec2) nil 1))
(defun calcFunc-vpcov (vec1 &optional vec2)
(math-covariance (list vec1) (list vec2) t 1)
)
(math-covariance (list vec1) (list vec2) t 1))
(defun calcFunc-vcorr (vec1 &optional vec2)
(math-covariance (list vec1) (list vec2) nil 2)
)
(math-covariance (list vec1) (list vec2) nil 2))
(defun math-covariance (vec1 vec2 pop mode)
@ -621,9 +578,6 @@
(if pop
suminvsqrwts
(math-div (math-mul suminvsqrwts (1- len)) len))
(if pop len (1- len))))))))
)
(if pop len (1- len)))))))))
;;; calc-stat.el ends here

155
lisp/calc/calc-store.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-store.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -34,8 +34,7 @@
(defun calc-store (&optional var)
(interactive)
(let ((calc-store-keep t))
(calc-store-into var))
)
(calc-store-into var)))
(setq calc-store-keep nil)
(defun calc-store-into (&optional var)
@ -62,58 +61,47 @@
(calc-store-value (car (car var)) (cdr (car var))
(if (not (cdr var)) "")
(if (not (cdr var)) 1))
(setq var (cdr var)))))))
)
(setq var (cdr var))))))))
(defun calc-store-plus (&optional var)
(interactive)
(calc-store-binary var "+" '+)
)
(calc-store-binary var "+" '+))
(defun calc-store-minus (&optional var)
(interactive)
(calc-store-binary var "-" '-)
)
(calc-store-binary var "-" '-))
(defun calc-store-times (&optional var)
(interactive)
(calc-store-binary var "*" '*)
)
(calc-store-binary var "*" '*))
(defun calc-store-div (&optional var)
(interactive)
(calc-store-binary var "/" '/)
)
(calc-store-binary var "/" '/))
(defun calc-store-power (&optional var)
(interactive)
(calc-store-binary var "^" '^)
)
(calc-store-binary var "^" '^))
(defun calc-store-concat (&optional var)
(interactive)
(calc-store-binary var "|" '|)
)
(calc-store-binary var "|" '|))
(defun calc-store-neg (n &optional var)
(interactive "p")
(calc-store-binary var "n" '/ (- n))
)
(calc-store-binary var "n" '/ (- n)))
(defun calc-store-inv (n &optional var)
(interactive "p")
(calc-store-binary var "&" '^ (- n))
)
(calc-store-binary var "&" '^ (- n)))
(defun calc-store-incr (n &optional var)
(interactive "p")
(calc-store-binary var "n" '- (- n))
)
(calc-store-binary var "n" '- (- n)))
(defun calc-store-decr (n &optional var)
(interactive "p")
(calc-store-binary var "n" '- n)
)
(calc-store-binary var "n" '- n))
(defun calc-store-value (var value tag &optional pop)
(if var
@ -131,15 +119,13 @@
(null old)
(message "(Note: %s has built-in meanings which may interfere)"
var))
(calc-refresh-evaltos var)))
)
(calc-refresh-evaltos var))))
(defun calc-var-name (var)
(if (symbolp var) (setq var (symbol-name var)))
(if (string-match "\\`var-." var)
(substring var 4)
var)
)
var))
(defun calc-store-binary (var tag func &optional val)
(calc-wrapper
@ -160,8 +146,7 @@
(list func value old)
(list func old value)))
tag (and (not val) 1))
(message "Stored to variable \"%s\"" (calc-var-name var))))))
)
(message "Stored to variable \"%s\"" (calc-var-name var)))))))
(defun calc-read-var-name (prompt &optional calc-store-opers)
(setq calc-given-value nil
@ -184,8 +169,7 @@
(error "Bad format: %s" (nth 2 calc-given-value)))
(setq calc-given-value (math-evaluate-expr calc-given-value))
svar))
(intern var))))
)
(intern var)))))
(setq calc-given-value-flag nil)
(defvar calc-var-name-map nil "Keymap for reading Calc variable names.")
@ -202,8 +186,7 @@
(lambda (x)
(define-key calc-var-name-map (char-to-string x)
'calcVar-oper)))
"+-*/^|")
)
"+-*/^|"))
(defun calcVar-digit ()
(interactive)
@ -212,8 +195,7 @@
(beep)
(insert "q")
(self-insert-and-exit))
(self-insert-command 1))
)
(self-insert-command 1)))
(defun calcVar-oper ()
(interactive)
@ -222,8 +204,7 @@
(progn
(erase-buffer)
(self-insert-and-exit))
(self-insert-command 1))
)
(self-insert-command 1)))
(defun calc-store-map (&optional oper var)
(interactive)
@ -256,8 +237,7 @@
(calc-store-value var
(calc-normalize (cons (nth 1 oper) values))
(nth 2 oper)
(+ calc-dollar-used (1- nargs)))))))
)
(+ calc-dollar-used (1- nargs))))))))
(defun calc-store-exchange (&optional var)
(interactive)
@ -275,8 +255,7 @@
(setq top (or calc-given-value (calc-top 1)))
(calc-store-value var top nil)
(calc-pop-push-record calc-given-value-flag
(concat "<>" (calc-var-name var)) value)))))
)
(concat "<>" (calc-var-name var)) value))))))
(defun calc-unstore (&optional var)
(interactive)
@ -291,8 +270,7 @@
(message "Unstored variable \"%s\"" (calc-var-name var))
(message "Variable \"%s\" remains unstored" (calc-var-name var)))
(makunbound var)
(calc-refresh-evaltos var))))
)
(calc-refresh-evaltos var)))))
(defun calc-let (&optional var)
(interactive)
@ -331,8 +309,7 @@
(makunbound (car (car var))))
(setq saved-val (cdr saved-val)
var (cdr var)))
(calc-handle-whys)))))))
)
(calc-handle-whys))))))))
(defun calc-is-assignments (value)
(if (memq (car-safe value) '(calcFunc-eq calcFunc-assign))
@ -348,8 +325,7 @@
(nth 2 (car value)))
vv)))
(and (not value)
vv))))
)
vv)))))
(defun calc-recall (&optional var)
(interactive)
@ -366,23 +342,19 @@
(setq value (calc-normalize value))
(let ((calc-full-trail-vectors nil))
(calc-record value (concat "<" (calc-var-name var))))
(calc-push value))))
)
(calc-push value)))))
(defun calc-store-quick ()
(interactive)
(calc-store (intern (format "var-q%c" last-command-char)))
)
(calc-store (intern (format "var-q%c" last-command-char))))
(defun calc-store-into-quick ()
(interactive)
(calc-store-into (intern (format "var-q%c" last-command-char)))
)
(calc-store-into (intern (format "var-q%c" last-command-char))))
(defun calc-recall-quick ()
(interactive)
(calc-recall (intern (format "var-q%c" last-command-char)))
)
(calc-recall (intern (format "var-q%c" last-command-char))))
(defun calc-copy-variable (&optional var1 var2)
(interactive)
@ -395,8 +367,7 @@
(or var2 (setq var2 (calc-read-var-name
(format "Copy variable: %s, to: " var1))))
(if var2
(calc-store-value var2 value "")))))
)
(calc-store-value var2 value ""))))))
(defun calc-edit-variable (&optional var)
(interactive)
@ -416,75 +387,61 @@
t
(concat "Editing " (calc-var-name var)))
(and value
(insert (math-format-nice-expr value (screen-width)) "\n")))))
(calc-show-edit-buffer)
)
(insert (math-format-nice-expr value (frame-width)) "\n")))))
(calc-show-edit-buffer))
(setq calc-last-edited-variable nil)
(defun calc-edit-Decls ()
(interactive)
(calc-edit-variable 'var-Decls)
)
(calc-edit-variable 'var-Decls))
(defun calc-edit-EvalRules ()
(interactive)
(calc-edit-variable 'var-EvalRules)
)
(calc-edit-variable 'var-EvalRules))
(defun calc-edit-FitRules ()
(interactive)
(calc-edit-variable 'var-FitRules)
)
(calc-edit-variable 'var-FitRules))
(defun calc-edit-GenCount ()
(interactive)
(calc-edit-variable 'var-GenCount)
)
(calc-edit-variable 'var-GenCount))
(defun calc-edit-Holidays ()
(interactive)
(calc-edit-variable 'var-Holidays)
)
(calc-edit-variable 'var-Holidays))
(defun calc-edit-IntegLimit ()
(interactive)
(calc-edit-variable 'var-IntegLimit)
)
(calc-edit-variable 'var-IntegLimit))
(defun calc-edit-LineStyles ()
(interactive)
(calc-edit-variable 'var-LineStyles)
)
(calc-edit-variable 'var-LineStyles))
(defun calc-edit-PointStyles ()
(interactive)
(calc-edit-variable 'var-PointStyles)
)
(calc-edit-variable 'var-PointStyles))
(defun calc-edit-PlotRejects ()
(interactive)
(calc-edit-variable 'var-PlotRejects)
)
(calc-edit-variable 'var-PlotRejects))
(defun calc-edit-AlgSimpRules ()
(interactive)
(calc-edit-variable 'var-AlgSimpRules)
)
(calc-edit-variable 'var-AlgSimpRules))
(defun calc-edit-TimeZone ()
(interactive)
(calc-edit-variable 'var-TimeZone)
)
(calc-edit-variable 'var-TimeZone))
(defun calc-edit-Units ()
(interactive)
(calc-edit-variable 'var-Units)
)
(calc-edit-variable 'var-Units))
(defun calc-edit-ExtSimpRules ()
(interactive)
(calc-edit-variable 'var-ExtSimpRules)
)
(calc-edit-variable 'var-ExtSimpRules))
(defun calc-declare-variable (&optional var)
(interactive)
@ -554,8 +511,7 @@
(list (list 'vec
(math-build-var-name var)
decl)))))))
(calc-refresh-evaltos 'var-Decls)))
)
(calc-refresh-evaltos 'var-Decls))))
(defun calc-permanent-variable (&optional var)
(interactive)
@ -575,8 +531,7 @@
(calc-var-value x)
(not (eq (car-safe (symbol-value x)) 'special-const))
(calc-insert-permanent-variable x))))))
(save-buffer)))
)
(save-buffer))))
(defvar calc-dont-insert-variables '(var-FitRules var-FactorRules
var-CommuteRules var-JumpRules
var-DistribRules var-MergeRules
@ -613,8 +568,7 @@
" ')\n")
(backward-char 2))
(insert (prin1-to-string (calc-var-value var)))
(forward-line 1)
)
(forward-line 1))
(defun calc-insert-variables (buf)
(interactive "bBuffer in which to save variable values: ")
@ -640,24 +594,21 @@
'flat
calc-language)))
(math-format-value (symbol-value x) 100000)))
")\n"))))))
)
")\n")))))))
(defun calc-assign (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op ":=" 'calcFunc-assign arg))
)
(calc-binary-op ":=" 'calcFunc-assign arg)))
(defun calc-evalto (arg)
(interactive "P")
(calc-slow-wrapper
(calc-unary-op "=>" 'calcFunc-evalto arg))
)
(calc-unary-op "=>" 'calcFunc-evalto arg)))
(defun calc-subscript (arg)
(interactive "P")
(calc-slow-wrapper
(calc-binary-op "sub" 'calcFunc-subscr arg))
)
(calc-binary-op "sub" 'calcFunc-subscr arg)))
;;; calc-store.el ends here

48
lisp/calc/calc-stuff.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-stuff.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -43,8 +43,7 @@ With a prefix, push that prefix as a number onto the stack."
(error "Argument must be a small integer"))
(calc-pop-stack 1)
(setq prefix-arg num)
(message "%d-" num)))) ; a (lame) simulation of the real thing...
)
(message "%d-" num))))) ; a (lame) simulation of the real thing...
(defun calc-more-recursion-depth (n)
@ -56,8 +55,7 @@ With a prefix, push that prefix as a number onto the stack."
(if (> n 1)
(setq max-specpdl-size (* max-specpdl-size n)
max-lisp-eval-depth (* max-lisp-eval-depth n))))
(message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)))
)
(message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))))
(defun calc-less-recursion-depth (n)
(interactive "P")
@ -67,8 +65,7 @@ With a prefix, push that prefix as a number onto the stack."
(max (/ max-specpdl-size n) 600)
max-lisp-eval-depth
(max (/ max-lisp-eval-depth n) 200))))
(message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)
)
(message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))
(defun calc-explain-why (why &optional more)
@ -137,8 +134,7 @@ With a prefix, push that prefix as a number onto the stack."
(car why)
(math-format-flat-expr (car why) 0)))
punc ", ")))
(message "%s%s" msg (if more " [w=more]" "")))
)
(message "%s%s" msg (if more " [w=more]" ""))))
(defun calc-why ()
(interactive)
@ -154,8 +150,7 @@ With a prefix, push that prefix as a number onto the stack."
(progn
(message "(No further explanations available)")
(setq calc-which-why calc-why))
(message "No explanations available")))
)
(message "No explanations available"))))
(setq calc-which-why nil)
(setq calc-last-why-command nil)
@ -184,8 +179,7 @@ With a prefix, push that prefix as a number onto the stack."
math-format-date-cache nil
math-holidays-cache-tag t)
(mapcar (function (lambda (x) (set x -100))) math-cache-list)
(message "All internal calculator caches have been reset."))
)
(message "All internal calculator caches have been reset.")))
;;; Conversions.
@ -203,8 +197,7 @@ With a prefix, push that prefix as a number onto the stack."
(if (<= n 0)
(+ n calc-internal-prec)
n)))
(list func (calc-top-n 1)))))))
)
(list func (calc-top-n 1))))))))
(defun calc-clean-num (num)
(interactive "P")
@ -213,8 +206,7 @@ With a prefix, push that prefix as a number onto the stack."
(if (and (>= last-command-char ?0)
(<= last-command-char ?9))
(- last-command-char ?0)
(error "Number required")))))
)
(error "Number required"))))))
(defun calcFunc-clean (a &optional prec) ; [X X S] [Public]
@ -257,27 +249,22 @@ With a prefix, push that prefix as a number onto the stack."
a))
((Math-objectp a) a)
((math-infinitep a) a)
(t (list 'calcFunc-clean a))))
)
(t (list 'calcFunc-clean a)))))
(setq math-chopping-small nil)
(defun calcFunc-pclean (a &optional prec)
(math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
a)
)
a))
(defun calcFunc-pfloat (a)
(math-map-over-constants 'math-float a)
)
(math-map-over-constants 'math-float a))
(defun calcFunc-pfrac (a &optional tol)
(math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
a)
)
a))
(defun math-map-over-constants (func expr)
(math-map-over-constants-rec expr)
)
(math-map-over-constants-rec expr))
(defun math-map-over-constants-rec (expr)
(cond ((or (Math-primp expr)
@ -292,9 +279,6 @@ With a prefix, push that prefix as a number onto the stack."
(list (car expr)
(math-map-over-constants-rec (nth 1 expr))
(nth 2 expr)))
(t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr)))))
)
(t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr))))))
;;; calc-stuff.el ends here

50
lisp/calc/calc-trail.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-trail.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -34,8 +34,7 @@
(defun calc-trail-in ()
(interactive)
(let ((win (get-buffer-window (calc-trail-display t))))
(and win (select-window win)))
)
(and win (select-window win))))
(defun calc-trail-out ()
(interactive)
@ -45,38 +44,33 @@
(progn
(select-window win)
(calc-align-stack-window))
(calc)))
)
(calc))))
(defun calc-trail-next (n)
(interactive "p")
(calc-with-trail-buffer
(forward-line n)
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-previous (n)
(interactive "p")
(calc-with-trail-buffer
(forward-line (- n))
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-first (n)
(interactive "p")
(calc-with-trail-buffer
(goto-char (point-min))
(forward-line n)
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-last (n)
(interactive "p")
(calc-with-trail-buffer
(goto-char (point-max))
(forward-line (- n))
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-scroll-left (n)
(interactive "P")
@ -86,8 +80,7 @@
(progn
(select-window (get-buffer-window (current-buffer)))
(calc-scroll-left n))
(select-window curwin))))
)
(select-window curwin)))))
(defun calc-trail-scroll-right (n)
(interactive "P")
@ -97,22 +90,19 @@
(progn
(select-window (get-buffer-window (current-buffer)))
(calc-scroll-right n))
(select-window curwin))))
)
(select-window curwin)))))
(defun calc-trail-forward (n)
(interactive "p")
(calc-with-trail-buffer
(forward-line (* n (1- (window-height))))
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-backward (n)
(interactive "p")
(calc-with-trail-buffer
(forward-line (- (* n (1- (window-height)))))
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-isearch-forward ()
(interactive)
@ -121,8 +111,7 @@
(select-window (get-buffer-window (current-buffer)))
(let ((search-exit-char ?\r))
(isearch-forward)))
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-isearch-backward ()
(interactive)
@ -131,8 +120,7 @@
(select-window (get-buffer-window (current-buffer)))
(let ((search-exit-char ?\r))
(isearch-backward)))
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-yank (arg)
(interactive "P")
@ -158,8 +146,7 @@
(math-read-plain-expr str))))
(if (eq (car-safe val) 'error)
(error "Can't yank that line: %s" (nth 2 val))
val)))))
)
val))))))
(defun calc-trail-marker (str)
(interactive "sText to insert in trail: ")
@ -168,8 +155,7 @@
(let ((buffer-read-only nil))
(insert "---- " str "\n"))
(forward-line -1)
(calc-trail-here))
)
(calc-trail-here)))
(defun calc-trail-kill (n)
(interactive "p")
@ -183,8 +169,6 @@
(point))
(point-max))
(kill-line n)))
(calc-trail-here))
)
(calc-trail-here)))
;;; calc-trail.el ends here

32
lisp/calc/calc-undo.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-undo.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -49,8 +49,7 @@
(let ((calc-stack-top 0))
(calc-handle-undos calc-undo-list n))
(setq calc-stack-top saved-stack-top))))
(message "Undo!")))
)
(message "Undo!"))))
(defun calc-handle-undos (cl n)
(if (> n 0)
@ -59,8 +58,7 @@
(setq calc-undo-list nil)
(calc-handle-undo (car cl))
(setq calc-redo-list (append calc-undo-list old-redo)))
(calc-handle-undos (cdr cl) (1- n))))
)
(calc-handle-undos (cdr cl) (1- n)))))
(defun calc-handle-undo (list)
(and list
@ -88,8 +86,7 @@
(calc-record-undo (append (list 'eval (nth 2 action) (nth 1 action))
(cdr (cdr (cdr action)))))
(apply (nth 1 action) (cdr (cdr (cdr action))))))
(calc-handle-undo (cdr list))))
)
(calc-handle-undo (cdr list)))))
(defun calc-redo (n)
(interactive "p")
@ -107,8 +104,7 @@
(let ((calc-stack-top 0))
(calc-handle-redos calc-redo-list n))
(setq calc-stack-top saved-stack-top))))
(message "Redo!")))
)
(message "Redo!"))))
(defun calc-handle-redos (cl n)
(if (> n 0)
@ -117,8 +113,7 @@
(setq calc-undo-list nil)
(calc-handle-undo (car cl))
(setq calc-undo-list (append calc-undo-list old-undo)))
(calc-handle-redos (cdr cl) (1- n))))
)
(calc-handle-redos (cdr cl) (1- n)))))
(defun calc-last-args (n)
(interactive "p")
@ -128,8 +123,7 @@
(let ((urec (calc-find-last-x calc-undo-list n)))
(if urec
(calc-handle-last-x urec)
(error "Not enough undo information available"))))
)
(error "Not enough undo information available")))))
(defun calc-handle-last-x (list)
(and list
@ -137,8 +131,7 @@
(if (eq (car action) 'pop)
(calc-pop-push-record-list 0 "larg"
(delq 'top-of-stack (nth 2 action))))
(calc-handle-last-x (cdr list))))
)
(calc-handle-last-x (cdr list)))))
(defun calc-find-last-x (ul n)
(and ul
@ -146,14 +139,11 @@
(if (<= n 1)
(car ul)
(calc-find-last-x (cdr ul) (1- n)))
(calc-find-last-x (cdr ul) n)))
)
(calc-find-last-x (cdr ul) n))))
(defun calc-undo-does-pushes (list)
(and list
(or (eq (car (car list)) 'pop)
(calc-undo-does-pushes (cdr list))))
)
(calc-undo-does-pushes (cdr list)))))
;;; calc-undo.el ends here

378
lisp/calc/calc-vec.el
View File

File diff suppressed because it is too large Load Diff

73
lisp/calc/calc-yank.el
View File

@ -55,28 +55,24 @@
(if (not no-delete)
(calc-pop-stack n (- num n -1))))
(setq calc-last-kill (cons (car kill-ring) stuff)))))
(kill-line nn))
)
(kill-line nn)))
(defun calc-force-refresh ()
(if (or calc-executing-macro calc-display-dirty)
(let ((calc-executing-macro nil))
(calc-refresh)))
)
(calc-refresh))))
(defun calc-locate-cursor-element (pt)
(save-excursion
(goto-char (point-max))
(calc-locate-cursor-scan (- calc-stack-top) calc-stack pt))
)
(calc-locate-cursor-scan (- calc-stack-top) calc-stack pt)))
(defun calc-locate-cursor-scan (n stack pt)
(if (or (<= (point) pt)
(null stack))
n
(forward-line (- (nth 1 (car stack))))
(calc-locate-cursor-scan (1+ n) (cdr stack) pt))
)
(calc-locate-cursor-scan (1+ n) (cdr stack) pt)))
(defun calc-kill-region (top bot &optional no-delete)
(interactive "r")
@ -94,18 +90,15 @@
(calc-pop-stack num bot-num))))
(if no-delete
(copy-region-as-kill top bot)
(kill-region top bot)))
)
(kill-region top bot))))
(defun calc-copy-as-kill (n)
(interactive "P")
(calc-kill n t)
)
(calc-kill n t))
(defun calc-copy-region-as-kill (top bot)
(interactive "r")
(calc-kill-region top bot t)
)
(calc-kill-region top bot t))
;;; This function uses calc-last-kill if possible to get an exact result,
;;; otherwise it just parses the yanked string.
@ -128,8 +121,7 @@
(if (eq (car-safe val) 'error)
(error "Bad format in yanked data")
val))
val)))))))
)
val))))))))
(defun calc-clean-newlines (s)
(cond
@ -144,8 +136,7 @@
(calc-clean-newlines (concat (math-match-substring s 1) ","
(math-match-substring s 2))))
(t s))
)
(t s)))
(defun calc-do-grab-region (top bot arg)
@ -191,8 +182,7 @@
(forward-char (+ (nth 1 vals) (if single 0 1)))
(error (nth 2 vals))))
(calc-slow-wrapper
(calc-enter-result 0 "grab" vals)))
)
(calc-enter-result 0 "grab" vals))))
(defun calc-do-grab-rectangle (top bot arg &optional reduce)
@ -273,8 +263,7 @@
(if reduce
(calc-enter-result 0 "grb+" (list reduce '(var add var-add)
(nreverse mat)))
(calc-enter-result 0 "grab" (nreverse mat)))))
)
(calc-enter-result 0 "grab" (nreverse mat))))))
(defun calc-copy-to-buffer (nn)
@ -354,8 +343,7 @@
(not thebuf)
(progn
(calc-quit t)
(switch-to-buffer newbuf))))
)
(switch-to-buffer newbuf)))))
(defun calc-overwrite-string (str eat-lnums)
(if (string-match "\n\\'" str)
@ -379,8 +367,7 @@
(forward-char 1))
(if eat-lnums (setq i (+ i 4)))))
(self-insert-command 1))
(setq i (1+ i)))))
)
(setq i (1+ i))))))
;;; First, require that buffer is visible and does not begin with "*"
;;; Second, require only that it not begin with "*Calc"
@ -392,8 +379,7 @@
(or (string-match "\\`\\*.*" (buffer-name (car buf)))
(not (get-buffer-window (car buf))))))
(calc-find-writable-buffer (cdr buf) mode)
(car buf)))
)
(car buf))))
(defun calc-edit (n)
@ -418,16 +404,14 @@
(while list
(insert (car list) "\n")
(setq list (cdr list)))))
(calc-show-edit-buffer)
)
(calc-show-edit-buffer))
(defun calc-alg-edit (str)
(calc-edit-mode '(calc-finish-stack-edit 0))
(calc-show-edit-buffer)
(insert str "\n")
(backward-char 1)
(calc-set-command-flag 'do-edit)
)
(calc-set-command-flag 'do-edit))
(defvar calc-edit-mode-map nil "Keymap for use by the calc-edit command.")
(if calc-edit-mode-map
@ -435,8 +419,7 @@
(setq calc-edit-mode-map (make-sparse-keymap))
(define-key calc-edit-mode-map "\n" 'calc-edit-finish)
(define-key calc-edit-mode-map "\r" 'calc-edit-return)
(define-key calc-edit-mode-map "\C-c\C-c" 'calc-edit-finish)
)
(define-key calc-edit-mode-map "\C-c\C-c" 'calc-edit-finish))
(defun calc-edit-mode (&optional handler allow-ret title)
"Calculator editing mode. Press RET, LFD, or C-c C-c to finish.
@ -476,8 +459,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch)
"M-# x"
"C-x k RET")
" to cancel.\n"))
)
" to cancel.\n")))
(put 'calc-edit-mode 'mode-class 'special)
(defun calc-show-edit-buffer ()
@ -495,15 +477,13 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(delete-window win))))
(set-buffer-modified-p nil)
(goto-char (point-min))
(forward-line 1))
)
(forward-line 1)))
(defun calc-edit-return ()
(interactive)
(if (and (boundp 'calc-allow-ret) calc-allow-ret)
(newline)
(calc-edit-finish))
)
(calc-edit-finish)))
(defun calc-edit-finish (&optional keep)
"Finish calc-edit mode. Parse buffer contents and push them on the stack."
@ -543,16 +523,14 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(if disp-trail
(calc-wrapper
(calc-trail-display 1 t)))
(message ""))
)
(message "")))
(defun calc-edit-cancel ()
"Cancel calc-edit mode. Ignore the Calc Edit buffer and don't change stack."
(interactive)
(let ((calc-edit-handler nil))
(calc-edit-finish))
(message "(Cancelled)")
)
(message "(Cancelled)"))
(defun calc-finish-stack-edit (num)
(let ((buf (current-buffer))
@ -585,9 +563,6 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
calc-simplify-mode)))
(if (>= num 0)
(calc-enter-result num "edit" vals)
(calc-enter-result 1 "edit" vals (- num)))))))))
)
(calc-enter-result 1 "edit" vals (- num))))))))))
;;; calc-yank.el ends here

355
lisp/calc/calc.el
View File

File diff suppressed because it is too large Load Diff

270
lisp/calc/calcalg2.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-alg-2.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -46,8 +46,7 @@
expr (calc-top-n 1)))
(while (>= (setq num (1- num)) 0)
(setq expr (list func expr var)))
(calc-enter-result n "derv" expr)))
)
(calc-enter-result n "derv" expr))))
(defun calc-integral (var)
(interactive "sIntegration variable: ")
@ -61,38 +60,32 @@
(error "Bad format in expression: %s" (nth 1 var)))
(calc-enter-result 1 "intg" (list 'calcFunc-integ
(calc-top-n 1)
var)))))
)
var))))))
(defun calc-num-integral (&optional varname lowname highname)
(interactive "sIntegration variable: ")
(calc-tabular-command 'calcFunc-ninteg "Integration" "nint"
nil varname lowname highname)
)
nil varname lowname highname))
(defun calc-summation (arg &optional varname lowname highname)
(interactive "P\nsSummation variable: ")
(calc-tabular-command 'calcFunc-sum "Summation" "sum"
arg varname lowname highname)
)
arg varname lowname highname))
(defun calc-alt-summation (arg &optional varname lowname highname)
(interactive "P\nsSummation variable: ")
(calc-tabular-command 'calcFunc-asum "Summation" "asum"
arg varname lowname highname)
)
arg varname lowname highname))
(defun calc-product (arg &optional varname lowname highname)
(interactive "P\nsIndex variable: ")
(calc-tabular-command 'calcFunc-prod "Index" "prod"
arg varname lowname highname)
)
arg varname lowname highname))
(defun calc-tabulate (arg &optional varname lowname highname)
(interactive "P\nsIndex variable: ")
(calc-tabular-command 'calcFunc-table "Index" "tabl"
arg varname lowname highname)
)
arg varname lowname highname))
(defun calc-tabular-command (func prompt prefix arg varname lowname highname)
(calc-slow-wrapper
@ -150,8 +143,7 @@
(setq step (prefix-numeric-value arg)))))
(setq expr (calc-top-n num))
(calc-enter-result num prefix (append (list func expr var low high)
(and step (list step))))))
)
(and step (list step)))))))
(defun calc-solve-for (var)
(interactive "sVariable to solve for: ")
@ -171,8 +163,7 @@
(error "Bad format in expression: %s" (nth 1 var)))
(calc-enter-result 1 "solv" (list func
(calc-top-n 1)
var))))))
)
var)))))))
(defun calc-poly-roots (var)
(interactive "sVariable to solve for: ")
@ -189,8 +180,7 @@
(error "Bad format in expression: %s" (nth 1 var)))
(calc-enter-result 1 "prts" (list 'calcFunc-roots
(calc-top-n 1)
var)))))
)
var))))))
(defun calc-taylor (var nterms)
(interactive "sTaylor expansion variable: \nNNumber of terms: ")
@ -201,8 +191,7 @@
(calc-enter-result 1 "tylr" (list 'calcFunc-taylor
(calc-top-n 1)
var
(prefix-numeric-value nterms)))))
)
(prefix-numeric-value nterms))))))
(defun math-derivative (expr) ; uses global values: deriv-var, deriv-total.
@ -332,8 +321,7 @@
(throw 'math-deriv nil)
(cons func (cdr expr))))))))))
(setq n (1+ n)))
accum)))))
)
accum))))))
(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
(let* ((deriv-total nil)
@ -344,8 +332,7 @@
(and res
(if deriv-value
(math-expr-subst res deriv-var deriv-value)
res)))
)
res))))
(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb)
(math-setup-declarations)
@ -357,8 +344,7 @@
(and res
(if deriv-value
(math-expr-subst res deriv-var deriv-value)
res)))
)
res))))
(put 'calcFunc-inv\' 'math-derivative-1
(function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
@ -492,8 +478,7 @@
(defun math-deriv-gamma (a x scale)
(math-mul scale
(math-mul (math-pow x (math-add a -1))
(list 'calcFunc-exp (math-neg x))))
)
(list 'calcFunc-exp (math-neg x)))))
(put 'calcFunc-betaB\' 'math-derivative-3
(function (lambda (x a b) (math-deriv-beta x a b 1))))
@ -507,8 +492,7 @@
(defun math-deriv-beta (x a b scale)
(math-mul (math-mul (math-pow x (math-add a -1))
(math-pow (math-sub 1 x) (math-add b -1)))
scale)
)
scale))
(put 'calcFunc-erf\' 'math-derivative-1
(function (lambda (x) (math-div 2
@ -632,8 +616,7 @@
;;(list 'condition-case 'err
(cons 'insert parts)
;; '(error (insert (prin1-to-string err))))
'(sit-for 0)))
)
'(sit-for 0))))
;;; The following wrapper caches results and avoids infinite recursion.
;;; Each cache entry is: ( A B ) Integral of A is B;
@ -724,8 +707,7 @@
" is "
(math-format-value val 1000)
"\n")
val)
)
val))
(defvar math-integral-cache nil)
(defvar math-integral-cache-state nil)
@ -736,8 +718,7 @@
(listp (nth 2 expr)))
(while (and (setq expr (cdr expr))
(not (math-integral-contains-parts (car expr)))))
expr)
)
expr))
(defun math-replace-integral-parts (expr)
(or (Math-primp expr)
@ -751,8 +732,7 @@
(setcar expr (nth 1 (nth 2 (car expr))))
(math-replace-integral-parts (cons 'foo expr)))
(setcar (cdr cur-record) 'cancelled)))
(math-replace-integral-parts (car expr))))))
)
(math-replace-integral-parts (car expr)))))))
(defun math-do-integral (expr)
(let (t1 t2)
@ -974,8 +954,7 @@
;; Try expanding the function's definition.
(let ((res (math-expand-formula expr)))
(and res
(math-integral res)))))
)
(math-integral res))))))
(defun math-sub-integration (expr &rest rest)
(or (if (or (not rest)
@ -986,8 +965,7 @@
(and (or (= math-integ-level math-integral-limit)
(not (math-expr-calls res 'calcFunc-integ)))
res)))
(list 'calcFunc-integfailed expr))
)
(list 'calcFunc-integfailed expr)))
(defun math-do-integral-methods (expr)
(let ((so-far math-integ-var-list-list)
@ -1074,8 +1052,7 @@
(math-integ-try-parts expr)
;; Give up.
nil))
)
nil)))
(defun math-integ-parts-easy (expr)
(cond ((Math-primp expr) t)
@ -1090,8 +1067,7 @@
(math-integ-parts-easy (nth 1 expr))))
((eq (car expr) 'neg)
(math-integ-parts-easy (nth 1 expr)))
(t t))
)
(t t)))
(defun math-integ-try-parts (expr &optional math-good-parts)
;; Integration by parts:
@ -1117,8 +1093,7 @@
(and (eq (car expr) '^)
(math-integrate-by-parts (math-pow (nth 1 expr)
(math-sub (nth 2 expr) 1))
(nth 1 expr))))
)
(nth 1 expr)))))
(defun math-integrate-by-parts (u vprime)
(let ((math-integ-level (if (or math-good-parts
@ -1149,16 +1124,14 @@
(math-solve-for (math-sub v temp) 0 v nil)))
(and temp (not (integerp temp))
(math-simplify-extended temp)))))
(setcar (cdr cur-record) 'busy))))
)
(setcar (cdr cur-record) 'busy)))))
;;; This tries two different formulations, hoping the algebraic simplifier
;;; will be strong enough to handle at least one.
(defun math-integrate-by-substitution (expr u &optional user uinv uinvprime)
(and (> math-integ-level 0)
(let ((math-integ-level (max (- math-integ-level 2) 0)))
(math-integrate-by-good-substitution expr u user uinv uinvprime)))
)
(math-integrate-by-good-substitution expr u user uinv uinvprime))))
(defun math-integrate-by-good-substitution (expr u &optional user
uinv uinvprime)
@ -1208,8 +1181,7 @@
deriv)
'yes)))))
(math-simplify-extended
(math-expr-subst temp math-integ-var u))))
)
(math-expr-subst temp math-integ-var u)))))
;;; Look for substitutions of the form u = a x + b.
(defun math-integ-try-linear-substitutions (sub-expr)
@ -1234,8 +1206,7 @@
(while (and (setq sub-expr (cdr sub-expr))
(not (setq res (math-integ-try-linear-substitutions
(car sub-expr))))))
res)))
)
res))))
;;; Recursively try different substitutions based on various sub-expressions.
(defun math-integ-try-substitutions (sub-expr &optional allow-rat)
@ -1260,14 +1231,12 @@
(while (and (setq sub-expr (cdr sub-expr))
(not (setq res (math-integ-try-substitutions
(car sub-expr) allow-rat)))))
res)))
)
res))))
(defun math-expr-rational-in (expr)
(let ((parts nil))
(math-expr-rational-in-rec expr)
(mapcar 'car parts))
)
(mapcar 'car parts)))
(defun math-expr-rational-in-rec (expr)
(cond ((Math-primp expr)
@ -1284,8 +1253,7 @@
(t
(and (not (assoc expr parts))
(math-expr-contains expr math-integ-var)
(setq parts (cons (list expr) parts)))))
)
(setq parts (cons (list expr) parts))))))
(defun math-expr-calls (expr funcs &optional arg-contains)
(if (consp expr)
@ -1300,8 +1268,7 @@
(while (and (setq expr (cdr expr))
(not (setq res (math-expr-calls
(car expr) funcs arg-contains)))))
res))))
)
res)))))
(defun math-fix-const-terms (expr except-vars)
(cond ((not (math-expr-depends expr except-vars)) 0)
@ -1312,8 +1279,7 @@
((eq (car expr) '-)
(math-sub (math-fix-const-terms (nth 1 expr) except-vars)
(math-fix-const-terms (nth 2 expr) except-vars)))
(t expr))
)
(t expr)))
;; Command for debugging the Calculator's symbolic integrator.
(defun calc-dump-integral-cache (&optional arg)
@ -1336,8 +1302,7 @@
"\n")
(setq p (cdr p)))
(goto-char (point-min)))
(set-buffer buf)))
)
(set-buffer buf))))
(defun math-try-integral (expr)
(let ((math-integ-level math-integral-limit)
@ -1355,8 +1320,7 @@
(and (> math-max-integral-limit math-integral-limit)
(setq math-integral-limit math-max-integral-limit
math-integ-level math-integral-limit)
(math-integral expr 'yes))))
)
(math-integral expr 'yes)))))
(defun calcFunc-integ (expr var &optional low high)
(cond
@ -1468,8 +1432,7 @@
(math-expr-subst res math-integ-var var)))))
(append (list 'calcFunc-integ expr var)
(and low (list low))
(and high (list high)))))))
)
(and high (list high))))))))
(math-defintegral calcFunc-inv
@ -1682,8 +1645,7 @@
(math-mul n (math-mul q (math-pow v n)))))
(math-mul-thru (math-div (math-mul b (1- (* 2 n)))
(math-mul n q))
(math-integral-q02 a b c v n)))))))
)
(math-integral-q02 a b c v n))))))))
(defun math-integral-q02 (a b c v vpow)
(let (q rq part)
@ -1722,8 +1684,7 @@
(math-div (math-mul 2 (math-to-radians-2
(list 'calcFunc-arctan
(math-div part rq))))
rq))))
)
rq)))))
(math-defintegral calcFunc-erf
@ -1798,8 +1759,7 @@
(and (not (and (equal low '(neg (var inf var-inf)))
(equal high '(var inf var-inf))))
(list low high))
(and step (list step)))))
)
(and step (list step))))))
(setq math-tabulate-initial nil)
(setq math-tabulate-function nil)
@ -1822,8 +1782,7 @@
high (math-min high (math-floor high-val)))))
(t
(while (setq x (cdr x))
(math-scan-for-limits (car x)))))
)
(math-scan-for-limits (car x))))))
(defun calcFunc-sum (expr var &optional low high step)
@ -1831,8 +1790,7 @@
(let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2)))
(math-sum-rec expr var low high step)))
(math-disable-sums t))
(math-normalize res))
)
(math-normalize res)))
(setq math-disable-sums nil)
(defun math-sum-rec (expr var &optional low high step)
@ -1937,8 +1895,7 @@
(or val
(let* ((math-tabulate-initial 0)
(math-tabulate-function 'calcFunc-sum))
(calcFunc-table expr var low high))))
)
(calcFunc-table expr var low high)))))
(defun calcFunc-asum (expr var low &optional high step no-mul-flag)
(or high (setq high low low 1))
@ -1960,8 +1917,7 @@
(math-simplify (math-div (math-sub high low)
step))))))
(math-mul (if no-mul-flag 1 (math-pow -1 low))
(calcFunc-sum (math-mul (math-pow -1 var) expr) var low high)))
)
(calcFunc-sum (math-mul (math-pow -1 var) expr) var low high))))
(defun math-sum-const-factors (expr var)
(let ((const nil)
@ -1983,8 +1939,7 @@
(let ((temp (or (car not-const) 1)))
(while (setq not-const (cdr not-const))
(setq temp (list '* (car not-const) temp)))
temp))))
)
temp)))))
;; Following is from CRC Math Tables, 27th ed, pp. 52-53.
(defun math-sum-integer-power (pow)
@ -2007,8 +1962,7 @@
(setq math-sum-int-pow-cache
(nconc math-sum-int-pow-cache (list (nreverse new)))
n (1+ n))))
(nth pow math-sum-int-pow-cache))
)
(nth pow math-sum-int-pow-cache)))
(setq math-sum-int-pow-cache (list '(0 1)))
(defun math-to-exponentials (expr)
@ -2046,8 +2000,7 @@
(list '^ '(var e var-e) x)
(list '^ '(var e var-e) (list 'neg x)))
2))
(t nil))))
)
(t nil)))))
(defun math-to-exps (expr)
(cond (calc-symbolic-mode expr)
@ -2057,8 +2010,7 @@
(equal (nth 1 expr) '(var e var-e)))
(list 'calcFunc-exp (nth 2 expr)))
(t
(cons (car expr) (mapcar 'math-to-exps (cdr expr)))))
)
(cons (car expr) (mapcar 'math-to-exps (cdr expr))))))
(defun calcFunc-prod (expr var &optional low high step)
@ -2066,8 +2018,7 @@
(let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2)))
(math-prod-rec expr var low high step)))
(math-disable-prods t))
(math-normalize res))
)
(math-normalize res)))
(setq math-disable-prods nil)
(defun math-prod-rec (expr var &optional low high step)
@ -2209,8 +2160,7 @@
(or val
(let* ((math-tabulate-initial 1)
(math-tabulate-function 'calcFunc-prod))
(calcFunc-table expr var low high))))
)
(calcFunc-table expr var low high)))))
@ -2359,8 +2309,7 @@
(math-try-solve-for t1 rhs sign))
(t
(calc-record-why "*No inverse known" lhs)
nil)))
)
nil))))
(setq math-solve-ranges nil)
@ -2470,8 +2419,7 @@
(and sign
(math-oddp (nth 2 lhs))
(math-solve-sign sign (nth 2 lhs)))))))))
(t nil))
)
(t nil)))
(defun math-solve-prod (lsoln rsoln)
(cond ((null lsoln)
@ -2485,8 +2433,7 @@
(list 'calcFunc-gt (math-solve-get-sign 1) 0)
lsoln
rsoln))
(t lsoln))
)
(t lsoln)))
;;; This deals with negative, fractional, and symbolic powers of "x".
(defun math-solve-poly-funny-powers (sub-rhs) ; uses "t1", "t2"
@ -2503,8 +2450,7 @@
(setq t2 (math-mul (or math-poly-mult-powers 1)
(let ((calc-prefer-frac t))
(math-div 1 math-poly-frac-powers)))
t1 (math-is-polynomial (math-simplify (calcFunc-expand t1)) b 50)))
)
t1 (math-is-polynomial (math-simplify (calcFunc-expand t1)) b 50))))
;;; This converts "a x^8 + b x^5 + c x^2" to "(a (x^3)^2 + b (x^3) + c) * x^2".
(defun math-solve-crunch-poly (max-degree) ; uses "t1", "t3"
@ -2533,8 +2479,7 @@
t1 new-t1))))
(setq scale (1- scale)))
(setq t3 (list (math-mul (car t3) t2) (math-mul count t2)))
(<= (1- (length t1)) max-degree))))
)
(<= (1- (length t1)) max-degree)))))
(defun calcFunc-poly (expr var &optional degree)
(if degree
@ -2545,8 +2490,7 @@
(if (equal p '(0))
(list 'vec)
(cons 'vec p))
(math-reject-arg expr "Expected a polynomial")))
)
(math-reject-arg expr "Expected a polynomial"))))
(defun calcFunc-gpoly (expr var &optional degree)
(if degree
@ -2556,8 +2500,7 @@
(d (math-decompose-poly expr var degree nil)))
(if d
(cons 'vec d)
(math-reject-arg expr "Expected a polynomial")))
)
(math-reject-arg expr "Expected a polynomial"))))
(defun math-decompose-poly (lhs solve-var degree sub-rhs)
(let ((rhs (or sub-rhs 1))
@ -2589,15 +2532,13 @@
(cons 'vec t1)
(if sub-rhs
(math-pow t2 (nth 1 t3))
(math-div (math-pow t2 (nth 1 t3)) rhs)))))
)
(math-div (math-pow t2 (nth 1 t3)) rhs))))))
(defun math-solve-linear (var sign b a)
(math-try-solve-for var
(math-div (math-neg b) a)
(math-solve-sign sign a)
t)
)
t))
(defun math-solve-quadratic (var c b a)
(math-try-solve-for
@ -2622,8 +2563,7 @@
(math-add (math-sqr b)
(math-mul 4 (math-mul (math-neg c) a)))))))
(math-mul 2 a)))
nil t)
)
nil t))
(defun math-solve-cubic (var d c b a)
(let* ((p (math-div b a))
@ -2665,8 +2605,7 @@
calc-symbolic-mode))))
3))))
(math-div p 3))
nil t))))
)
nil t)))))
(defun math-solve-quartic (var d c b a aa)
(setq a (math-div a aa))
@ -2715,8 +2654,7 @@
(math-sub (math-add (math-mul sign1 (math-div r 2))
(math-solve-get-sign (math-div de 2)))
(math-div a 4))))
nil t)
)
nil t))
(defun math-poly-all-roots (var p &optional math-factoring)
(catch 'ouch
@ -2811,8 +2749,7 @@
(list 'calcFunc-subscr
vec
(math-solve-get-int 1 (1- (length orig-p)) 1))
vec)))))
)
vec))))))
(setq math-symbolic-solve nil)
(defun math-lcm-denoms (&rest fracs)
@ -2821,8 +2758,7 @@
(if (eq (car-safe (car fracs)) 'frac)
(setq den (calcFunc-lcm den (nth 2 (car fracs)))))
(setq fracs (cdr fracs)))
den)
)
den))
(defun math-poly-any-root (p x polish) ; p is a reverse poly coeff list
(let* ((newt (if (math-zerop x)
@ -2838,8 +2774,7 @@
(math-poly-laguerre-root p x polish)))))
(and math-symbolic-solve (math-floatp res)
(throw 'ouch nil))
res)
)
res))
(defun math-poly-newton-root (p x iters)
(let* ((calc-prefer-frac nil)
@ -2869,8 +2804,7 @@
(math-nearly-zerop dx (math-abs-approx x))))
(progn (setq dx 0) nil)))))
(cons x (if (math-zerop x)
1 (math-div (math-abs-approx dx) (math-abs-approx x)))))
)
1 (math-div (math-abs-approx dx) (math-abs-approx x))))))
(defun math-poly-integer-root (x)
(and (math-lessp (calcFunc-xpon (math-abs-approx x)) calc-internal-prec)
@ -2935,8 +2869,7 @@
(let ((calc-symbolic-mode math-symbolic-solve))
(math-mul (math-sqrt (math-sub (math-sqr aa)
rnd0))
(if (math-negp xim) -1 1))))))))))
)
(if (math-negp xim) -1 1)))))))))))
(setq math-int-coefs nil)
;;; The following routine is from Numerical Recipes, section 9.5.
@ -3018,8 +2951,7 @@
dxold))))
(or (and (math-floatp x)
(math-poly-integer-root x))
x))
)
x)))
(defun math-solve-above-dummy (x)
(and (not (Math-primp x))
@ -3029,8 +2961,7 @@
(let ((res nil))
(while (and (setq x (cdr x))
(not (setq res (math-solve-above-dummy (car x))))))
res)))
)
res))))
(defun math-solve-find-root-term (x neg) ; sets "t2", "t3"
(if (math-solve-find-root-in-prod x)
@ -3039,8 +2970,7 @@
(and (memq (car-safe x) '(+ -))
(or (math-solve-find-root-term (nth 1 x) neg)
(math-solve-find-root-term (nth 2 x)
(if (eq (car x) '-) (not neg) neg)))))
)
(if (eq (car x) '-) (not neg) neg))))))
(defun math-solve-find-root-in-prod (x)
(and (consp x)
@ -3057,8 +2987,7 @@
(or (and (not (math-expr-contains (nth 1 x) solve-var))
(math-solve-find-root-in-prod (nth 2 x)))
(and (not (math-expr-contains (nth 2 x) solve-var))
(math-solve-find-root-in-prod (nth 1 x)))))))
)
(math-solve-find-root-in-prod (nth 1 x))))))))
(defun math-solve-system (exprs solve-vars solve-full)
@ -3071,8 +3000,7 @@
(or (let ((math-solve-simplifying nil))
(math-solve-system-rec exprs solve-vars nil))
(let ((math-solve-simplifying t))
(math-solve-system-rec exprs solve-vars nil)))
)
(math-solve-system-rec exprs solve-vars nil))))
;;; The following backtracking solver works by choosing a variable
;;; and equation, and trying to solve the equation for the variable.
@ -3167,8 +3095,7 @@
(cons 'vec
(if solns
(mapcar (function (lambda (x) (cons 'calcFunc-eq x))) solns)
(mapcar 'car eqn-list))))))
)
(mapcar 'car eqn-list)))))))
(defun math-solve-system-subst (x) ; uses "res" and "v"
(let ((accum nil)
@ -3184,8 +3111,7 @@
(car res2)))
x (cdr x)
res2 (cdr res2)))
accum)
)
accum))
(defun math-get-from-counter (name)
@ -3194,8 +3120,7 @@
(setcdr ctr (1+ (cdr ctr)))
(setq ctr (cons name 1)
calc-command-flags (cons ctr calc-command-flags)))
(cdr ctr))
)
(cdr ctr)))
(defun math-solve-get-sign (val)
(setq val (math-simplify val))
@ -3222,8 +3147,7 @@
math-solve-ranges)))
(math-mul var2 val)))
(calc-record-why "*Choosing positive solution")
val))
)
val)))
(defun math-solve-get-int (val &optional range first)
(if solve-full
@ -3243,8 +3167,7 @@
math-solve-ranges)))
(math-mul val var2)))
(calc-record-why "*Choosing 0 for arbitrary integer in solution")
0)
)
0))
(defun math-solve-sign (sign expr)
(and sign
@ -3252,15 +3175,13 @@
(cond ((memq s1 '(4 6))
sign)
((memq s1 '(1 3))
(- sign)))))
)
(- sign))))))
(defun math-looks-evenp (expr)
(if (Math-integerp expr)
(math-evenp expr)
(if (memq (car expr) '(* /))
(math-looks-evenp (nth 1 expr))))
)
(math-looks-evenp (nth 1 expr)))))
(defun math-solve-for (lhs rhs solve-var solve-full &optional sign)
(if (math-expr-contains rhs solve-var)
@ -3287,8 +3208,7 @@
(format
"*Omitted %d complex solutions"
(- old-len new-len)))))))
res))))
)
res)))))
(defun math-solve-eqn (expr var full)
(if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt
@ -3308,51 +3228,44 @@
(list 'calcFunc-neq var res))))))
(let ((res (math-solve-for expr 0 var full)))
(and res
(list 'calcFunc-eq var res))))
)
(list 'calcFunc-eq var res)))))
(defun math-reject-solution (expr var func)
(if (math-expr-contains expr var)
(or (equal (car calc-next-why) '(* "Unable to find a symbolic solution"))
(calc-record-why "*Unable to find a solution")))
(list func expr var)
)
(list func expr var))
(defun calcFunc-solve (expr var)
(or (if (or (Math-vectorp expr) (Math-vectorp var))
(math-solve-system expr var nil)
(math-solve-eqn expr var nil))
(math-reject-solution expr var 'calcFunc-solve))
)
(math-reject-solution expr var 'calcFunc-solve)))
(defun calcFunc-fsolve (expr var)
(or (if (or (Math-vectorp expr) (Math-vectorp var))
(math-solve-system expr var t)
(math-solve-eqn expr var t))
(math-reject-solution expr var 'calcFunc-fsolve))
)
(math-reject-solution expr var 'calcFunc-fsolve)))
(defun calcFunc-roots (expr var)
(let ((math-solve-ranges nil))
(or (if (or (Math-vectorp expr) (Math-vectorp var))
(math-solve-system expr var 'all)
(math-solve-for expr 0 var 'all))
(math-reject-solution expr var 'calcFunc-roots)))
)
(math-reject-solution expr var 'calcFunc-roots))))
(defun calcFunc-finv (expr var)
(let ((res (math-solve-for expr math-integ-var var nil)))
(if res
(math-normalize (math-expr-subst res math-integ-var var))
(math-reject-solution expr var 'calcFunc-finv)))
)
(math-reject-solution expr var 'calcFunc-finv))))
(defun calcFunc-ffinv (expr var)
(let ((res (math-solve-for expr math-integ-var var t)))
(if res
(math-normalize (math-expr-subst res math-integ-var var))
(math-reject-solution expr var 'calcFunc-finv)))
)
(math-reject-solution expr var 'calcFunc-finv))))
(put 'calcFunc-inv 'math-inverse
@ -3499,9 +3412,6 @@
nfac))))
(and fprime
(math-normalize accum))))
(list 'calcFunc-taylor expr var num)))
)
(list 'calcFunc-taylor expr var num))))
;;; calcalg2.el ends here

153
lisp/calc/calcalg3.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-alg-3.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -47,8 +47,7 @@
(calc-enter-result 1 "root" (list func
(calc-top-n 2)
var
(calc-top-n 1)))))))
)
(calc-top-n 1))))))))
(defun calc-find-minimum (var)
(interactive "sVariable(s) to minimize over: ")
@ -73,14 +72,12 @@
(calc-enter-result 1 tag (list func
(calc-top-n 2)
var
(calc-top-n 1)))))))
)
(calc-top-n 1))))))))
(defun calc-find-maximum (var)
(interactive "sVariable to maximize over: ")
(calc-invert-func)
(calc-find-minimum var)
)
(calc-find-minimum var))
(defun calc-poly-interp (arg)
@ -94,8 +91,7 @@
(if (calc-is-hyperbolic)
(calc-enter-result 1 "rati" (list 'calcFunc-ratint data (calc-top 1)))
(calc-enter-result 1 "poli" (list 'calcFunc-polint data
(calc-top 1))))))
)
(calc-top 1)))))))
(defun calc-curve-fit (arg &optional model coefnames varnames)
@ -312,16 +308,13 @@
coefnames)
data))
(if (consp calc-fit-to-trail)
(calc-record (calc-normalize calc-fit-to-trail) "parm")))))
)
(calc-record (calc-normalize calc-fit-to-trail) "parm"))))))
(defun calc-invent-independent-variables (n &optional but)
(calc-invent-variables n but '(x y z t) "x")
)
(calc-invent-variables n but '(x y z t) "x"))
(defun calc-invent-parameter-variables (n &optional but)
(calc-invent-variables n but '(a b c d) "a")
)
(calc-invent-variables n but '(a b c d) "a"))
(defun calc-invent-variables (num but names base)
(let ((vars nil)
@ -337,8 +330,7 @@
(or (symbolp names) (setq names (cdr names))))
(if (= n 0)
(nreverse vars)
(calc-invent-variables num but t base)))
)
(calc-invent-variables num but t base))))
(defun calc-get-fit-variables (nv nc &optional defv defc with-y homog)
(or (= nv (if with-y (1+ nvars) nvars))
@ -394,8 +386,7 @@
(if coefnames
(setq model (math-multi-subst model (cdr coefnames) (cdr coefs))))
(setq varnames vars
coefnames coefs))
)
coefnames coefs)))
@ -422,8 +413,7 @@
limit)
(math-newton-root expr deriv next orig-guess limit)
(math-reject-arg next "*Newton's method failed to converge"))))
(math-reject-arg next "*Newton's method encountered a singularity")))
)
(math-reject-arg next "*Newton's method encountered a singularity"))))
;;; Inspired by "rtsafe"
(defun math-newton-search-root (expr deriv guess vguess ostep oostep
@ -494,8 +484,7 @@
(and (Math-negp vlow) (Math-negp vhigh)))
(math-search-root expr deriv low vlow high vhigh)
(math-newton-search-root expr deriv nil nil nil ostep
low vlow high vhigh)))))
)
low vlow high vhigh))))))
;;; Search for a root in an interval with no overt zero crossing.
(defun math-search-root (expr deriv low vlow high vhigh)
@ -579,8 +568,7 @@
low vlow high vhigh)
(math-bisect-root expr low vlow high vhigh))))
(math-reject-arg (list 'intv 3 low high)
"*Unable to find a sign change in this interval")))
)
"*Unable to find a sign change in this interval"))))
;;; "rtbis" (but we should be using Brent's method)
(defun math-bisect-root (expr low vlow high vhigh)
@ -602,8 +590,7 @@
vhigh vmid)
(setq low mid
vlow vmid)))
(list 'vec mid vmid))
)
(list 'vec mid vmid)))
;;; "mnewt"
(defun math-newton-multi (expr jacob n guess orig-guess limit)
@ -628,8 +615,7 @@
limit)
(math-newton-multi expr jacob n next orig-guess limit)
(math-reject-arg nil "*Newton's method failed to converge"))
(list 'vec next expr-val)))
)
(list 'vec next expr-val))))
(defvar math-root-vars [(var DUMMY var-DUMMY)])
@ -746,16 +732,13 @@
(not (Math-numberp vlow))
(not (Math-numberp vhigh)))
(math-search-root expr deriv low vlow high vhigh)
(math-bisect-root expr low vlow high vhigh)))))))))
)
(math-bisect-root expr low vlow high vhigh))))))))))
(defun calcFunc-root (expr var guess)
(math-find-root expr var guess nil)
)
(math-find-root expr var guess nil))
(defun calcFunc-wroot (expr var guess)
(math-find-root expr var guess t)
)
(math-find-root expr var guess t))
@ -773,8 +756,7 @@
(math-float a)
(if (eq (car a) 'float)
a
(math-reject-arg a 'realp)))
)
(math-reject-arg a 'realp))))
;;; A bracket for a minimum is a < b < c where f(b) < f(a) and f(b) < f(c).
@ -842,8 +824,7 @@
c u vc vu))
(if (math-lessp-float a c)
(list a va b vb c vc)
(list c vc b vb a va)))
)
(list c vc b vb a va))))
(defun math-narrow-min (expr a c intv)
(let ((xvals (list a c))
@ -893,8 +874,7 @@
(and (not yvals)
(list (nth 3 intv) min)))))
(math-reject-arg nil (format "*Unable to find a %s in the interval"
math-min-or-max)))))
)
math-min-or-max))))))
;;; "brent"
(defun math-brent-min (expr prec a va x vx b vb)
@ -986,8 +966,7 @@
(setq v w vv vw
w x vw vx
x u vx vu)))
(list 'vec x vx))
)
(list 'vec x vx)))
;;; "powell"
(defun math-powell-min (expr n guesses prec)
@ -1047,8 +1026,7 @@
(while (<= (setq i (1+ i)) n)
(setcar (nthcdr ibig (nth i xi))
(nth i (nth 1 res)))))))
(list 'vec p fret))
)
(list 'vec p fret)))
(defun math-line-min-func (expr n)
(let ((m -1))
@ -1059,8 +1037,7 @@
'(var DUMMY var-DUMMY)
(list 'calcFunc-mrow '(var line-xi line-xi) (1+ m)))
(list 'calcFunc-mrow '(var line-p line-p) (1+ m)))))
(math-evaluate-expr expr))
)
(math-evaluate-expr expr)))
(defun math-line-min (f1dim line-p line-xi n prec)
(let* ((var-DUMMY nil)
@ -1068,8 +1045,7 @@
(params (math-widen-min expr '(float 0 0) '(float 1 0)))
(res (apply 'math-brent-min expr prec params))
(xi (math-mul (nth 1 res) line-xi)))
(list (math-add line-p xi) xi (nth 2 res)))
)
(list (math-add line-p xi) xi (nth 2 res))))
(defvar math-min-vars [(var DUMMY var-DUMMY)])
@ -1168,8 +1144,7 @@
(setq guesses (cdr guesses)))
(if isvec
(list 'vec vec (nth 2 res))
(list 'vec (nth 1 vec) (nth 2 res))))))
)
(list 'vec (nth 1 vec) (nth 2 res)))))))
(setq math-min-or-max "minimum")
(defun calcFunc-minimize (expr var guess)
@ -1177,16 +1152,14 @@
(math-min-or-max "minimum"))
(math-find-minimum (math-normalize expr)
(math-normalize var)
(math-normalize guess) nil))
)
(math-normalize guess) nil)))
(defun calcFunc-wminimize (expr var guess)
(let ((calc-internal-prec (max (/ calc-internal-prec 2) 3))
(math-min-or-max "minimum"))
(math-find-minimum (math-normalize expr)
(math-normalize var)
(math-normalize guess) t))
)
(math-normalize guess) t)))
(defun calcFunc-maximize (expr var guess)
(let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3))
@ -1194,8 +1167,7 @@
(res (math-find-minimum (math-normalize (math-neg expr))
(math-normalize var)
(math-normalize guess) nil)))
(list 'vec (nth 1 res) (math-neg (nth 2 res))))
)
(list 'vec (nth 1 res) (math-neg (nth 2 res)))))
(defun calcFunc-wmaximize (expr var guess)
(let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3))
@ -1203,8 +1175,7 @@
(res (math-find-minimum (math-normalize (math-neg expr))
(math-normalize var)
(math-normalize guess) t)))
(list 'vec (nth 1 res) (math-neg (nth 2 res))))
)
(list 'vec (nth 1 res) (math-neg (nth 2 res)))))
@ -1223,8 +1194,7 @@
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp))
(math-with-extra-prec 2
(cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x
nil))))
)
nil)))))
(put 'calcFunc-polint 'math-expandable t)
@ -1240,8 +1210,7 @@
(or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp))
(math-with-extra-prec 2
(cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x
(cdr (cdr (cdr (nth 1 data))))))))
)
(cdr (cdr (cdr (nth 1 data)))))))))
(put 'calcFunc-ratint 'math-expandable t)
@ -1295,8 +1264,7 @@
(setq ns (1- ns)
dy (nth ns d)))
(setq y (math-add y dy)))
(list y dy)))
)
(list y dy))))
@ -1335,8 +1303,7 @@
(math-ninteg-romberg
'math-ninteg-midpoint expr
(math-float lo) (math-float hi) nil))))
sum))
)
sum)))
;;; Open Romberg method; "qromo" in section 4.4.
@ -1365,8 +1332,7 @@
h (cdr h)))
(setq curh (math-div-float curh '(float 9 0))))
ss
(math-reject-arg nil (format "*Integral failed to converge")))))
)
(math-reject-arg nil (format "*Integral failed to converge"))))))
(defun math-ninteg-evaluate (expr x mode)
@ -1378,8 +1344,7 @@
(math-reject-arg res "*Integrand does not evaluate to a number"))
(if (eq mode 'inf)
(setq res (math-mul res (math-sqr x))))
res)
)
res))
(defun math-ninteg-midpoint (expr lo hi mode) ; uses "integ-temp"
@ -1417,8 +1382,7 @@
expr
(math-mul (math-add lo hi) '(float 5 -1))
mode)))))
(nth 1 integ-temp)
)
(nth 1 integ-temp))
@ -1437,28 +1401,24 @@
(set (nth 2 (aref math-dummy-vars math-dummy-counter)) nil)
(prog1
(aref math-dummy-vars math-dummy-counter)
(setq math-dummy-counter (1+ math-dummy-counter)))
)
(setq math-dummy-counter (1+ math-dummy-counter))))
(defun calcFunc-fit (expr vars &optional coefs data)
(let ((math-in-fit 10))
(math-with-extra-prec 2
(math-general-fit expr vars coefs data nil)))
)
(math-general-fit expr vars coefs data nil))))
(defun calcFunc-efit (expr vars &optional coefs data)
(let ((math-in-fit 10))
(math-with-extra-prec 2
(math-general-fit expr vars coefs data 'sdev)))
)
(math-general-fit expr vars coefs data 'sdev))))
(defun calcFunc-xfit (expr vars &optional coefs data)
(let ((math-in-fit 10))
(math-with-extra-prec 2
(math-general-fit expr vars coefs data 'full)))
)
(math-general-fit expr vars coefs data 'full))))
(defun math-general-fit (expr vars coefs data mode)
(let ((calc-simplify-mode nil)
@ -1746,8 +1706,7 @@
(if (and have-sdevs (> n mm))
(list 'calcFunc-utpc chisq (- n mm))
'(var nan var-nan)))
expr)))
)
expr))))
(setq math-in-fit 0)
(setq calc-fit-to-trail nil)
@ -1757,38 +1716,33 @@
(progn
(setq x (aref math-dummy-vars (+ first-var x -1)))
(or (calc-var-value (nth 2 x)) x))
(math-reject-arg x))
)
(math-reject-arg x)))
(defun calcFunc-fitparam (x)
(if (>= math-in-fit 2)
(progn
(setq x (aref math-dummy-vars (+ first-coef x -1)))
(or (calc-var-value (nth 2 x)) x))
(math-reject-arg x))
)
(math-reject-arg x)))
(defun calcFunc-fitdummy (x)
(if (= math-in-fit 3)
(nth x new-coefs)
(math-reject-arg x))
)
(math-reject-arg x)))
(defun calcFunc-hasfitvars (expr)
(if (Math-primp expr)
0
(if (eq (car expr) 'calcFunc-fitvar)
(nth 1 expr)
(apply 'max (mapcar 'calcFunc-hasfitvars (cdr expr)))))
)
(apply 'max (mapcar 'calcFunc-hasfitvars (cdr expr))))))
(defun calcFunc-hasfitparams (expr)
(if (Math-primp expr)
0
(if (eq (car expr) 'calcFunc-fitparam)
(nth 1 expr)
(apply 'max (mapcar 'calcFunc-hasfitparams (cdr expr)))))
)
(apply 'max (mapcar 'calcFunc-hasfitparams (cdr expr))))))
(defun math-all-vars-but (expr but)
@ -1798,15 +1752,13 @@
(setq vars (delq (assoc (car-safe p) vars) vars)
p (cdr p)))
(sort (mapcar 'car vars)
(function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
)
(function (lambda (x y) (string< (nth 1 x) (nth 1 y)))))))
(defun math-all-vars-in (expr)
(let ((vars nil)
found)
(math-all-vars-rec expr)
vars)
)
vars))
(defun math-all-vars-rec (expr)
(if (Math-primp expr)
@ -1816,9 +1768,6 @@
(setcdr found (1+ (cdr found)))
(setq vars (cons (cons expr 1) vars)))))
(while (setq expr (cdr expr))
(math-all-vars-rec (car expr))))
)
(math-all-vars-rec (car expr)))))
;;; calcalg3.el ends here

150
lisp/calc/calccomp.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-comp.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -878,8 +878,7 @@
(if (eq calc-language 'eqn)
" , " ", ")
0)
right))))))))
)
right)))))))))
(defconst math-eqn-special-funcs
'( calcFunc-log
@ -894,14 +893,12 @@
(defun math-prod-first-term (x)
(while (eq (car-safe x) '*)
(setq x (nth 1 x)))
x
)
x)
(defun math-prod-last-term (x)
(while (eq (car-safe x) '*)
(setq x (nth 2 x)))
x
)
x)
(defun math-compose-vector (a sep prec)
(if a
@ -918,13 +915,11 @@
(cons (list 'break math-compose-level)
(cons sep c)))))
(nreverse c))))
"")
)
""))
(defun math-vector-no-parens (a)
(or (cdr (cdr a))
(not (eq (car-safe (nth 1 a)) '*)))
)
(not (eq (car-safe (nth 1 a)) '*))))
(defun math-compose-matrix (a col cols base)
(let ((col 0)
@ -943,8 +938,7 @@
(concat comma-spc " ")))))
a)))
res)))
(nreverse res))
)
(nreverse res)))
(defun math-compose-rows (a count first)
(if (cdr a)
@ -962,16 +956,14 @@
(list (list 'horiz
(if first (concat left-bracket " ") " ")
(math-compose-expr (car a) vector-prec)
(concat " " right-bracket))))
)
(concat " " right-bracket)))))
(defun math-compose-tex-matrix (a)
(if (cdr a)
(cons (math-compose-vector (cdr (car a)) " & " 0)
(cons " \\\\ "
(math-compose-tex-matrix (cdr a))))
(list (math-compose-vector (cdr (car a)) " & " 0)))
)
(list (math-compose-vector (cdr (car a)) " & " 0))))
(defun math-compose-eqn-matrix (a)
(if a
@ -989,8 +981,7 @@
(cons
" } "
(math-compose-eqn-matrix (cdr a)))))))
nil)
)
nil))
(defun math-vector-is-string (a)
(while (and (setq a (cdr a))
@ -1000,8 +991,7 @@
(natnump (nth 1 (car a)))
(eq (nth 2 (car a)) 0)
(<= (nth 1 (car a)) 255)))))
(null a)
)
(null a))
(defun math-vector-to-string (a &optional quoted)
(setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
@ -1024,8 +1014,7 @@
p (+ p 2))))))
(if quoted
(concat "\"" a "\"")
a)
)
a))
(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
( ?\\ . "\\\\" )
( ?\a . "\\a" )
@ -1042,8 +1031,7 @@
(if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
(math-to-underscores
(concat (math-match-substring x 1) "_" (math-match-substring x 2)))
x)
)
x))
(defun math-tex-expr-is-flat (a)
(or (Math-integerp a)
@ -1054,8 +1042,7 @@
(math-tex-expr-is-flat (car a))))
(null a)))
(and (memq (car a) '(^ calcFunc-subscr))
(math-tex-expr-is-flat (nth 1 a))))
)
(math-tex-expr-is-flat (nth 1 a)))))
(put 'calcFunc-log 'math-compose-big 'math-compose-log)
(defun math-compose-log (a prec)
@ -1066,8 +1053,7 @@
(math-compose-expr (nth 2 a) 1000)))
"("
(math-compose-expr (nth 1 a) 1000)
")"))
)
")")))
(put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
(defun math-compose-log10 (a prec)
@ -1076,8 +1062,7 @@
(list 'subscr "log" "10")
"("
(math-compose-expr (nth 1 a) 1000)
")"))
)
")")))
(put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
(put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
@ -1092,8 +1077,7 @@
(list 'vec
'(calcFunc-string (vec ?d))
(nth 2 a))))
prec))
)
prec)))
(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
(defun math-compose-sqrt (a prec)
@ -1114,8 +1098,7 @@
(make-list (1- h) " |")
'("\\|")))
" "
c))))
)
c)))))
(put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
(defun math-compose-choose (a prec)
@ -1126,8 +1109,7 @@
(list 'vcent
(math-comp-height a1)
a1 " " a2)
")"))
)
")")))
(put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
(defun math-compose-integ (a prec)
@ -1164,8 +1146,7 @@
(if over
""
(list 'horiz " d" var))
(if parens ")" ""))))
)
(if parens ")" "")))))
(put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
(defun math-compose-sum (a prec)
@ -1190,8 +1171,7 @@
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
expr
(if (memq prec '(180 201)) ")" ""))))
)
(if (memq prec '(180 201)) ")" "")))))
(put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
(defun math-compose-prod (a prec)
@ -1215,8 +1195,7 @@
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
expr
(if (memq prec '(196 201)) ")" ""))))
)
(if (memq prec '(196 201)) ")" "")))))
(defun math-stack-value-offset-fancy ()
@ -1251,8 +1230,7 @@
(or (< off 0)
(and calc-display-origin
(> calc-line-breaking calc-display-origin)))
(setq wid calc-line-breaking)))
)
(setq wid calc-line-breaking))))
@ -1265,8 +1243,7 @@
(if (math-comp-is-flat c)
(math-comp-to-string-flat c width)
(math-vert-comp-to-string
(math-comp-simplify c width))))
)
(math-comp-simplify c width)))))
(defun math-comp-is-flat (c) ; check if c's height is 1.
(cond ((not (consp c)) t)
@ -1281,8 +1258,7 @@
(math-comp-is-flat (nth 2 c))))
((eq (car c) 'tag)
(math-comp-is-flat (nth 2 c)))
(t nil))
)
(t nil)))
;;; Convert a one-line composition to a string. Break into multiple
@ -1315,8 +1291,7 @@
(aset comp-buf (1+ k) ?\n)
(setq prefix " "))
(setq prefix "\n"))))
(concat comp-buf prefix str))))
)
(concat comp-buf prefix str)))))
(setq math-comp-buf-string (make-vector 10 ""))
(setq math-comp-buf-margin (make-vector 10 0))
(setq math-comp-buf-level (make-vector 10 0))
@ -1415,8 +1390,7 @@
(math-comp-to-string-flat-term (nth 2 c))))
(t (math-comp-to-string-flat-term (nth 2 c)))))
(t (math-comp-to-string-flat-term (nth 2 c))))
)
(t (math-comp-to-string-flat-term (nth 2 c)))))
(defun math-comp-highlight-string (s)
(setq s (copy-sequence s))
@ -1424,8 +1398,7 @@
(while (>= (setq i (1- i)) 0)
(or (memq (aref s i) '(32 ?\n))
(aset s i (if calc-show-selections ?\. ?\#)))))
s
)
s)
(defun math-comp-sel-flat-term (c)
(cond ((not (consp c))
@ -1442,8 +1415,7 @@
(setq math-comp-sel-tag c
math-comp-sel-cpos 1000000)))
(math-comp-sel-flat-term (nth 2 c))))
(t (math-comp-sel-flat-term (nth 2 c))))
)
(t (math-comp-sel-flat-term (nth 2 c)))))
;;; Simplify a composition to a canonical form consisting of
@ -1459,8 +1431,7 @@
(comp-highlight (and math-comp-selected calc-show-selections))
(comp-tag nil))
(math-comp-simplify-term c)
(cons 'vleft (cons comp-base comp-buf)))
)
(cons 'vleft (cons comp-base comp-buf))))
(defun math-comp-add-string (s h v)
(and (> (length s) 0)
@ -1481,8 +1452,7 @@
(make-string (- h (length (car str))) 32)
(if comp-highlight
(math-comp-highlight-string s)
s)))))))
)
s))))))))
(defun math-comp-add-string-sel (x y w h)
(if (and (<= y math-comp-sel-vpos)
@ -1490,8 +1460,7 @@
(<= x math-comp-sel-hpos)
(> (+ x w) math-comp-sel-hpos))
(setq math-comp-sel-tag comp-tag
math-comp-sel-vpos 10000))
)
math-comp-sel-vpos 10000)))
(defun math-comp-simplify-term (c)
(cond ((stringp c)
@ -1561,8 +1530,7 @@
(let ((comp-highlight nil))
(math-comp-simplify-term (nth 2 c))))
(t (let ((comp-tag c))
(math-comp-simplify-term (nth 2 c)))))))
)
(math-comp-simplify-term (nth 2 c))))))))
;;; Measuring a composition.
@ -1576,8 +1544,7 @@
(math-comp-is-null (car c))))
(and c (math-comp-first-char (car c))))
((eq (car c) 'tag)
(math-comp-first-char (nth 2 c))))
)
(math-comp-first-char (nth 2 c)))))
(defun math-comp-first-string (c)
(cond ((stringp c)
@ -1588,8 +1555,7 @@
(math-comp-is-null (car c))))
(and c (math-comp-first-string (car c))))
((eq (car c) 'tag)
(math-comp-first-string (nth 2 c))))
)
(math-comp-first-string (nth 2 c)))))
(defun math-comp-last-char (c)
(cond ((stringp c)
@ -1601,8 +1567,7 @@
(setq c (cdr c)))
(and c (math-comp-last-char (car c)))))
((eq (car c) 'tag)
(math-comp-last-char (nth 2 c))))
)
(math-comp-last-char (nth 2 c)))))
(defun math-comp-is-null (c)
(cond ((stringp c) (= (length c) 0))
@ -1612,8 +1577,7 @@
(null c))
((eq (car c) 'tag)
(math-comp-is-null (nth 2 c)))
((memq (car c) '(set break)) t))
)
((memq (car c) '(set break)) t)))
(defun math-comp-width (c)
(cond ((not (consp c)) (length c))
@ -1630,14 +1594,12 @@
accum))
((eq (car c) 'tag)
(math-comp-width (nth 2 c)))
(t 0))
)
(t 0)))
(defun math-comp-height (c)
(if (stringp c)
1
(+ (math-comp-ascent c) (math-comp-descent c)))
)
(+ (math-comp-ascent c) (math-comp-descent c))))
(defun math-comp-ascent (c)
(cond ((not (consp c)) 1)
@ -1654,8 +1616,7 @@
(math-comp-ascent (nth 1 c)))
((eq (car c) 'tag)
(math-comp-ascent (nth 2 c)))
(t 1))
)
(t 1)))
(defun math-comp-descent (c)
(cond ((not (consp c)) 0)
@ -1676,13 +1637,11 @@
(+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
((eq (car c) 'tag)
(math-comp-descent (nth 2 c)))
(t 0))
)
(t 0)))
(defun calcFunc-cwidth (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
(math-comp-width (math-compose-expr a (or prec 0)))
)
(math-comp-width (math-compose-expr a (or prec 0))))
(defun calcFunc-cheight (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
@ -1690,8 +1649,7 @@
(memq (length a) '(2 3))
(eq (nth 1 a) 0))
0
(math-comp-height (math-compose-expr a (or prec 0))))
)
(math-comp-height (math-compose-expr a (or prec 0)))))
(defun calcFunc-cascent (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
@ -1699,13 +1657,11 @@
(memq (length a) '(2 3))
(eq (nth 1 a) 0))
0
(math-comp-ascent (math-compose-expr a (or prec 0))))
)
(math-comp-ascent (math-compose-expr a (or prec 0)))))
(defun calcFunc-cdescent (a &optional prec)
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
(math-comp-descent (math-compose-expr a (or prec 0)))
)
(math-comp-descent (math-compose-expr a (or prec 0))))
;;; Convert a simplified composition into string form.
@ -1713,14 +1669,12 @@
(defun math-vert-comp-to-string (c)
(if (stringp c)
c
(math-vert-comp-to-string-step (cdr (cdr c))))
)
(math-vert-comp-to-string-step (cdr (cdr c)))))
(defun math-vert-comp-to-string-step (c)
(if (cdr c)
(concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
(car c))
)
(car c)))
;;; Convert a composition to a string in "raw" form (for debugging).
@ -1738,8 +1692,7 @@
(math-comp-to-string-raw (nth 1 c) next-indent)
(math-comp-to-string-raw-step (cdr (cdr c))
next-indent)
")"))))
)
")")))))
(defun math-comp-to-string-raw-step (cl indent)
(if cl
@ -1747,9 +1700,6 @@
(make-string indent 32)
(math-comp-to-string-raw (car cl) indent)
(math-comp-to-string-raw-step (cdr cl) indent))
"")
)
""))
;;; calccomp.el ends here

36
lisp/calc/calcsel2.el
View File

@ -1,5 +1,5 @@
;; Calculator for GNU Emacs, part II [calc-sel-2.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
;; Written by Dave Gillespie, daveg@synaptics.com.
;; This file is part of GNU Emacs.
@ -109,8 +109,7 @@
(list (calc-replace-sub-formula expr parent new))
num
(list (and (or (not (eq arg 0)) reselect)
sel)))))))))
)
sel))))))))))
(defun calc-commute-right (arg)
(interactive "p")
@ -193,8 +192,7 @@
(list (calc-replace-sub-formula expr parent new))
num
(list (and (or (not (eq arg 0)) reselect)
sel)))))))))
)
sel))))))))))
(defun calc-build-assoc-term (op lhs rhs)
(cond ((and (eq op '+) (or (math-looks-negp rhs)
@ -215,8 +213,7 @@
(or (math-equal-int (nth 1 rhs) 1)
(equal (nth 1 rhs) '(cplx 1 0)))))
(list '/ lhs (nth 2 rhs)))
(t (list op lhs rhs)))
)
(t (list op lhs rhs))))
(defun calc-sel-unpack ()
(interactive)
@ -234,8 +231,7 @@
(list (calc-replace-sub-formula
expr sel (nth 1 sel)))
num
(list (and reselect (nth 1 sel))))))
)
(list (and reselect (nth 1 sel)))))))
(defun calc-sel-isolate ()
(interactive)
@ -266,38 +262,32 @@
expr eqn soln))
num
(list (and reselect sel)))
(calc-handle-whys)))
)
(calc-handle-whys))))
(defun calc-sel-commute (many)
(interactive "P")
(let ((calc-assoc-selections nil))
(calc-rewrite-selection "CommuteRules" many "cmut"))
(calc-set-mode-line)
)
(calc-set-mode-line))
(defun calc-sel-jump-equals (many)
(interactive "P")
(calc-rewrite-selection "JumpRules" many "jump")
)
(calc-rewrite-selection "JumpRules" many "jump"))
(defun calc-sel-distribute (many)
(interactive "P")
(calc-rewrite-selection "DistribRules" many "dist")
)
(calc-rewrite-selection "DistribRules" many "dist"))
(defun calc-sel-merge (many)
(interactive "P")
(calc-rewrite-selection "MergeRules" many "merg")
)
(calc-rewrite-selection "MergeRules" many "merg"))
(defun calc-sel-negate (many)
(interactive "P")
(calc-rewrite-selection "NegateRules" many "jneg")
)
(calc-rewrite-selection "NegateRules" many "jneg"))
(defun calc-sel-invert (many)
(interactive "P")
(calc-rewrite-selection "InvertRules" many "jinv")
)
(calc-rewrite-selection "InvertRules" many "jinv"))
;;; calcsel2.el ends here