;; 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.
(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)
(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")
(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)
"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")
(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")
(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)
(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
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.
(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
(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)
(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))
(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))
(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))
(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)
(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))
(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,
(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
(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)
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.
(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 ()
(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.
(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)
(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)
(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)
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]
iters (if (eq (car res) 'maybe)
(1- iters)
0)))
- res)
-)
+ res))
(defvar math-prime-test-cache '(-1))
(defun calcFunc-prime (n &optional iters)
(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).
(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)
(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)
(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)
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)
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))
(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
4987 4993 4999 5003])
-
-
+;;; calc-comb.el ends here
;; 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.
(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 ()
(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))))))
(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)
(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.
((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]
(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)
(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)
(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))))
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]
((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.
((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)
((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)
(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]
'(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)))
(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.
((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)
((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
(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."))))
(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)
(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)
(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)
(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))
(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)
(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)
(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)
(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.
(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))
(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.
(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."
(save-excursion
(calc-embedded-mark-formula)
(copy-region-as-kill (point) (mark))
- (pop-mark))
-)
+ (pop-mark)))
(defun calc-embedded-duplicate ()
(interactive)
(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")
(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)
(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)
(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))
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 ()
(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)
(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
(progn
(setcdr found (cons info (cdr found)))
(calc-embedded-active-state 'more)))
- info)
-)
+ info))
(defun calc-embedded-find-vars (x)
(cond ((Math-primp x)
(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)
(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))
(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)
(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
(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))))))
(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 ()
(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
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)))
(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)
"(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
;; 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.
(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)
(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)
(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)
(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)
(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)
(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.
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
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)
t)))
(if (math-vectorp root)
(nth 1 root)
- root))
-)
+ root)))
(defun calcFunc-ratel (num pmt amount)
(or (math-objectp num) math-expand-formulas
(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))
t)))
(if (math-vectorp root)
(nth 1 root)
- root))
-)
+ root)))
(defun math-check-financial (rate num)
(or (math-objectp rate) math-expand-formulas
(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)
(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)
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)
(if (Math-lessp book salvage)
(setq res (math-add res (math-sub book salvage))
book salvage)))
- res))
-)
-
-
+ res)))
+;;; calc-fin.el ends here
;; 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.
(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")
(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)
"%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")
(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): ")
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: ")
(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
(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
(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.
(<= (+ (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]
(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))
(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]
'(float 6 1))
(nth 2 a))
60)
- (nth 1 a))))
-)
-
-
+ (nth 1 a)))))
;;;; Date forms.
(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))
(* (nth 4 dt) 60))
(nth 5 dt))
'(float 864 2)))
- date))
-)
+ date)))
(defun math-date-parts (value &optional offset)
(let* ((date (math-floor value))
(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)
(= (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)))))
(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))
(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
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)
(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)
(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)
(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))
(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)
hour minute second))
(if yearday
(setq day (math-add day (1- yearday))))
- day))))
-)
+ day)))))
(defun calcFunc-now (&optional zone)
'(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)))
(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)
(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)
(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
(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.
(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
(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)
((= (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.
(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)
(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)
(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))
(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))
(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))
(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)))
(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)
(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)
(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.
(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)
(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)))
(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)
((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"))))
(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))
(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)
(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))
(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)))
(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)
(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)))
(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 ()
(throw 'syntax (nth 2 res)))
(setq exp-pos (1+ last))
(math-read-token)
- res)
-)
+ res))
+;;; calc-forms.el ends here
;; 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.
(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)
(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)
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)
(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."))))
(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)
(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)
(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)
(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))))
(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)))
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))
(setq temp (math-add (math-mul (car cf) n) d)
d n
n temp))
- (math-div n d))
-)
+ (math-div n d)))
(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
;; 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.
(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
(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))))))
(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
xinv
(math-sqr xinv)
'(float 0 0)
- 2))))))
-)
+ 2)))))))
(defun math-gamma-series (sum x xinvsqr oterm n)
(math-working "gamma" sum)
(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.
(> 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))
(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))
'(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)
'(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)
(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)
(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)
(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))
(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.
(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))
(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)
(if (eq (car-safe x) 'cplx)
(list 'cplx (math-neg (nth 1 x)) (nth 2 x))
(math-neg x))
- x))
-)
+ x)))
;;; Beta function.
(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.
((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
(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)
(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)))
(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.
(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)
(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)))
(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))
(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)
bym)
bym by
by byp))
- by)))))
-)
+ by))))))
(defun math-besY0 (x)
(cond ((Math-lessp (math-abs-approx x) '(float 8 0))
(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))
(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.
(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))
(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)))
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)
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)!
(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.
(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.
(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)
(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.)
'(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
(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")
(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))
(beginning-of-line)))
(or before
(re-search-forward ",[ \t]+")))
- t))
-)
+ t)))
(defun calc-graph-add (many)
(interactive "P")
(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")
(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))
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)
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")
(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
(while (search-forward "," nil t)
(setq num (1+ num)))
num)
- 0))
-)
+ 0)))
(defun calc-graph-do-juggle ()
(let (base)
(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")
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))
(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
(cdr ycacheptr)))
(setq ycacheptr (cdr (cdr ycacheptr))))
(setq yp ycache
- numsteps 1000000)
-)
+ numsteps 1000000))
(defun calc-graph-recompute-2d ()
(setq ycacheptr ycache)
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))
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)
(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))
(if (<= num 0)
(char-to-string (- ?A num))
(int-to-string num))))
- nil))))
-)
+ nil)))))
(defun calc-graph-delete-temps ()
(while calc-graph-file-cache
(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.
(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)
(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 "$")
(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") ""))
(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)
" " (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")
(and (if flag
(<= (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "noxzeroaxis")))
- " "))
-)
+ " ")))
(defun calc-graph-zero-y (flag)
(interactive "P")
(and (if flag
(<= (prefix-numeric-value flag) 0)
(not (calc-graph-find-command "noyzeroaxis")))
- " "))
-)
+ " ")))
(defun calc-graph-name (name)
(interactive "sTitle for current curve: ")
(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")
(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")
(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")
(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")
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")
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: ")
(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\"): ")
(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)
(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)
(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: ")
(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)
(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)
(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)
(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 ()
(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)
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 ()
(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)
(eq (char-after (1- (point-max))) ?\n)
(progn
(goto-char (point-max))
- (insert "\n")))))
-)
+ (insert "\n"))))))
+;;; calc-graph.el ends here
;; 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.
(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:
(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)
(let ((case-fold-search nil))
(search-forward " NO WARRANTY"))
(beginning-of-line)
- (recenter 0)
-)
+ (recenter 0))
(defun calc-describe-bindings ()
(interactive)
(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: ")
(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)
(calc-describe-thing (if (string-match "\\`calcFunc-." func)
(substring func 9)
func)
- "Function Index"))
-)
+ "Function Index")))
(defun calc-describe-variable (&optional var)
(interactive)
(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)
(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)
(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)
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)
"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)
"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)
"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 ()
"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 ()
"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 ()
"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 ()
"relations: =, # (not =), <, >, [ (< or =), ] (> or =)"
"logical: & (and), | (or), ! (not); : (if)"
"misc: { (in-set); . (rmeq)")
- "algebra" ?a)
-)
+ "algebra" ?a))
(defun calc-b-prefix-help ()
"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 ()
(calc-do-prefix-help
'("Deg, Rad, HMS; Float; Polar/rect; Clean, 0-9; %"
"SHIFT + Fraction")
- "convert" ?c)
-)
+ "convert" ?c))
(defun calc-d-prefix-help ()
"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 ()
"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 ()
"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 ()
"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 ()
"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 ()
"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 ()
"SHIFT + sets: : (span), # (card), + (rdup)"
"<, =, > (justification); , (commas); [, {, ( (brackets)"
"} (matrix brackets); . (abbreviate); / (multi-lines)")
- "vec/mat" ?v)
-)
+ "vec/mat" ?v))
+;;; calc-help.el ends here
;; 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.
(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)
(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)
(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)
(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)
(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 ?.)
(erase-buffer)
(exit-minibuffer)))
;; just ignore extra decimal point, anticipating ".."
- (delete-backward-char 1))
-)
+ (delete-backward-char 1)))
(defun calc-dots ()
(interactive)
(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)
((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))
(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
(interactive)
(if calc-standalone-flag
(save-buffers-kill-emacs nil)
- (calc-keypad))
-)
+ (calc-keypad)))
(defun calc-keypad-redraw ()
(set-buffer calc-keypad-buffer)
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)
(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)
(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."
(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)
(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)
(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)))))
;;; |----+----+----+----+----+----|
( "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
( "TAN" calc-tan )
( "SQRT" calc-sqrt )
( "y^x" calc-power )
- ( "1/x" calc-inv ) ) )
-)
+ ( "1/x" calc-inv ) ) ))
;;; |----+----+----+----+----+----|
;;; |IGAM|BETA|IBET|ERF |BESJ|BESY|
( "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 |
( "C" ("C") )
( "D" ("D") )
( "E" ("E") )
- ( "F" ("F") ) ) )
-)
+ ( "F" ("F") ) ) ))
;;; |----+----+----+----+----+----|
;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$|
( "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 | |
( "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
;; 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.
(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 )
( "|||" 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 )
( 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 "{}")
(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 )
( "&&&" 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)
(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))
((> calc-language-option 0)
(upcase str))
(t
- (downcase str)))
-)
+ (downcase str))))
(defun calc-fortran-language (n)
(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 )
( "|||" 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 "//")
( 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)
(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
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)
(while args
(setq sym (list 'calcFunc-subscr sym (car args))
args (cdr args)))
- sym
-)
+ sym)
(defun calc-tex-language (n)
(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 )
( "\\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 )
( \\sqrt . calcFunc-sqrt )
( \\tanh . calcFunc-tanh )
( \\phi . calcFunc-totient )
- ( \\mu . calcFunc-moebius )
-))
+ ( \\mu . calcFunc-moebius )))
(put 'tex 'math-variable-table
'( ( \\pi . var-pi )
( \\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)
(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)
(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 )
( "->" 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 )
( 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)
(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)
(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 )
(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 )
(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))))
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)
(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))
(< 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)
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))
(memq (aref line h) '(?\) ?\])))
(setq count (1- count))))
(setq h (1+ h))))
- h)
-)
-
-
-
+ h))
+;;; calc-lang.el ends here
;; 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.
(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.
(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)
(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]
(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)
(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]
(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)
(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)
(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
;; 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.
(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)
(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)
(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)
(setq end (point-max))))
(apply old-write-region start end filename append 'quietly rest)
(message "Wrote %s" filename)
- nil
-)
+ nil)
(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)
(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."
"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"))
(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
(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)
\(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
;; 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.
(nth 2 oper))
(list 'calcFunc-apply
(math-calcFunc-to-var (nth 1 oper))
- expr))))
-)
+ expr)))))
(defun calc-reduce (&optional oper accum)
(interactive)
"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)
(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)
(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)
(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)
(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)
(char-to-string key))))
(if (> (length name) 3)
(substring name 0 3)
- name)))))
-)
+ name))))))
(setq calc-verify-arglist t)
(setq calc-mapping-dir nil)
(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)
(list 'var
(intern base)
(intern (concat "var-" base))))
- f)
-)
+ f))
;;; Expand a function call using "lambda" notation.
(defun math-build-call (f args)
( 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)
(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))
(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))))
(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))
(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)
(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))
(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))
(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)
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))
(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)
(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))
(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))
(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))
(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)
(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)
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)
(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)
(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
(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")
(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)
(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")
(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")
(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")
((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")
((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: ")
(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: ")
(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")
"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: ")
(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")
(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")
(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)
(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")
(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."))))
;; 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
(t 1))
(cond ((eq calc-infinite-mode 1) 0)
(calc-infinite-mode 1)
- (t -1)))
-)
+ (t -1))))
(defun calc-get-modes (n)
(interactive "P")
(< n (length modes)))
(nth n modes)
(error "Prefix out of range"))
- modes))))
-)
+ modes)))))
(defun calc-shift-prefix (arg)
(interactive "P")
(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")
(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")
'(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")
"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")
(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")
(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")
"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
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")
((= 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")
(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")
(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)
(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)
(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)
(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): ")
(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
;; 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.
(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]
(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))
(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.
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)
(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))))
(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.
(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.
(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)
(setcdr r1prev row2)
(setcdr row2 (cdr row1))
(setcdr row1 r2next)))
- m
-)
+ m)
(defun math-lud-solve (lud b &optional need)
(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)
(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
;; 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.
(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)
(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)
((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) '*)
(let ((p (math-is-polynomial expr var)))
(if (cdr p)
(nth (1- (length p)) p)
- 1))))
-)
+ 1)))))
(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)
(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.
(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.
(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)
(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) '+)
((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)
(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)
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)
(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.
(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)
(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)
(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)
(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)))
(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.
(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.
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.
(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).
(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) ... ).
(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)
(if exponent
(setq mpb-total-base (cons (list subexpr exponent)
mpb-total-base)))))
- nil
-)
+ nil)
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)
(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)
(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))
(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) '*)
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
(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)
(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)
(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)
(if (and (eq (car-safe x) '^)
(natnump (nth 2 x)))
(* (math-factor-contains (nth 1 x) a) (nth 2 x))
- 0)))
-)
+ 0))))
(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)
((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)
(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)
(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))
res (math-add res (math-div num (car dlist)))
num nil))
(setq dlist (cdr dlist)))
- (math-normalize res))))))
-)
+ (math-normalize res)))))))
(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)
(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
(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)))))
(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)
(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)
(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)
(assq (upcase key) kmap)
(assq (downcase key) kmap)
(error "No such user key is defined"))
- kmap)))
-)
+ kmap))))
(defun calc-user-define-formula ()
(interactive)
(if old
(setcdr old cmd)
(setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
- (message ""))
-)
+ (message "")))
(defun calc-default-formula-arglist (form)
(if (consp form)
(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)
(cons 'list
(cons (list 'quote (car f))
(mapcar 'calc-fix-user-formula (cdr f)))))))
- f)
-)
+ f))
(defun calc-user-define-composition ()
(interactive)
(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)
(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 ()
(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))
(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))
(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
(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))
(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)
((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)
(not (eq (car last) quoted))
(setcar last
(list '\? (list (car last)) '("$$"))))))))
- part)
-)
+ part))
(defun calc-user-define-invocation ()
(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)
(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)
(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 ()
(MacEdit-unread-chars ch))
(insert "type \"")
(MacEdit-insert-string str)
- (insert "\"\n")))))
-)
+ (insert "\"\n"))))))
(defun calc-macro-edit-algebraic ()
(MacEdit-unread-chars key-last)
(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)
(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)
(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)
(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)))
(while (and def
(not (eq (car (car def)) 'math-normalize)))
(setq def (cdr def)))
- (car def))))
-)
+ (car def)))))
(defun calc-get-user-defn ()
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 ()
(prin1-to-string cmd)
")\n")))
(insert "))\n")
- (save-buffer)))
-)
+ (save-buffer))))
(defun calc-stack-command-p (cmd)
(if (and cmd (symbolp cmd))
(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)
(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)))
(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)))
(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 ()
(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)
(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 ()
(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")
(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")
(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)
(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)
(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 ()
(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)
(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)))))
(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
(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)
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)))
(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)))
(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)))
(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)))
(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)
(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)
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)
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)
(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)
(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)
(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)
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)
((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)
(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))
(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
(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)
(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)
(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)
(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)
(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)
((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
(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))
(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)
(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)))
'+
'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)
(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))
(+ (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
;; 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.
(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)
(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))))))
(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")
(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))))))
(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)
(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)
(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)
(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)))))
(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)
(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)
calcFunc-pand))))
(or (Math-primp expr)
(math-rewrite-heads-rec expr))
- heads)
-)
+ heads))
(defun math-rewrite-heads-rec (expr)
(or (memq (car expr) skips)
(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
(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)
(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)
(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)
(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))
(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)
(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))
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))
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)
(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)
(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)
(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)
(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)
(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)
(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)))
(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) '(* /))
(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))
(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)) '(+ -))
(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)
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))
(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)
(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.
(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!
'(setcar rules (quote (nil nil nil no-phase)))
(list 'unwind-protect
form
- '(setcar rules orig)))
-)
+ '(setcar rules orig))))
(setq math-rewrite-phase 1)
(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)
(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)
(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)
(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))))
(list (list 'same 0 1)
(list 'done new nil))
nil nil)
- (cdr rules))))))
-)
-
+ (cdr rules)))))))
+;;; calc-rewr.el ends here
;; 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.
(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"
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"
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"
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"
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"
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"
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 ()
:: 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)
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)
:: 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
(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)
(car entry) sel)))
sel)
(calc-grow-assoc-formula (car entry) found)))
- (car entry)))))
-)
+ (car entry))))))
(defun calc-select-more (num)
(interactive "P")
(>= (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")
(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")
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
(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))
(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")
(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")
(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)
(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
(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)
(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)
(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")
(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+\\'")
(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")
(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")
(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))))
(+ (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!
(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)
(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))
(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))
(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
(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)
(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)
(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)
(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)
(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)
expr sel alg))
num
(list (and reselect alg))))))
- (calc-handle-whys)))
-)
+ (calc-handle-whys))))
(defun calc-edit-selection ()
(interactive)
(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))
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")
(car entry) sel val))
num
(list (and reselect val))))))
- (calc-handle-whys)))
-)
+ (calc-handle-whys))))
(defun calc-sel-expand-formula (arg)
(interactive "p")
(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")
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")
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
;; 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.
(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")
(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")
(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")
(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))))
;;; 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)
(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)
(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)
(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.
(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))
(setq count (if (Math-vectorp (car vec))
(+ count (math-count-elements (car vec)))
(1+ count))))
- count)
-)
+ count))
(defun math-flatten-many-vecs (vecs)
(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))
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.
(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)
means
(math-neg mean)))
2))
- (math-mul len (1- len))))))))))
-)
+ (math-mul len (1- len)))))))))))
;;; Compute the median of a list of values.
(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)
(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)
(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)
(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)))))))
(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)
(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)
(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)
(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))
(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)
(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
;; 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.
(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)
(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
(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
(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
(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.")
(lambda (x)
(define-key calc-var-name-map (char-to-string x)
'calcVar-oper)))
- "+-*/^|")
-)
+ "+-*/^|"))
(defun calcVar-digit ()
(interactive)
(beep)
(insert "q")
(self-insert-and-exit))
- (self-insert-command 1))
-)
+ (self-insert-command 1)))
(defun calcVar-oper ()
(interactive)
(progn
(erase-buffer)
(self-insert-and-exit))
- (self-insert-command 1))
-)
+ (self-insert-command 1)))
(defun calc-store-map (&optional oper var)
(interactive)
(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)
(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)
(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)
(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))
(nth 2 (car value)))
vv)))
(and (not value)
- vv))))
-)
+ vv)))))
(defun calc-recall (&optional var)
(interactive)
(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)
(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)
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)
(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)
(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
" ')\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: ")
'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
;; 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.
(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)
(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")
(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)
(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)
(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)
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.
(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")
(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]
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)
(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
;; 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.
(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)
(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")
(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")
(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)
(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)
(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")
(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: ")
(let ((buffer-read-only nil))
(insert "---- " str "\n"))
(forward-line -1)
- (calc-trail-here))
-)
+ (calc-trail-here)))
(defun calc-trail-kill (n)
(interactive "p")
(point))
(point-max))
(kill-line n)))
- (calc-trail-here))
-)
-
-
+ (calc-trail-here)))
+;;; calc-trail.el ends here
;; 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.
(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)
(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
(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")
(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)
(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")
(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
(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
(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
;; Calculator for GNU Emacs, part II [calc-vec.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.
(calc-wrapper
(message (if (calc-change-mode 'calc-display-strings n t t)
"Displaying vectors of integers as quoted strings."
- "Displaying vectors of integers normally.")))
-)
+ "Displaying vectors of integers normally."))))
(defun calc-pack (n)
(error "Packing mode must be an integer or vector of integers"))))
(num (calc-pack-size mode))
(items (calc-top-list num nn)))
- (calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items))))
-)
+ (calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items)))))
(defun calc-pack-size (mode)
(cond ((consp mode)
size)))
((>= mode 0) mode)
(t (or (cdr (assq mode '((-3 . 3) (-13 . 1) (-14 . 3) (-15 . 6))))
- 2)))
-)
+ 2))))
(defun calc-pack-items (mode items)
(cond ((consp mode)
(list 'calcFunc-float (car items))
(nth 1 items)))))
(t
- (error "Invalid packing mode: %d" mode)))
-)
+ (error "Invalid packing mode: %d" mode))))
(defun calc-unpack (mode)
(interactive "P")
(calc-pop-push-record-list 1 "unpk" (calc-unpack-item
(and mode
(prefix-numeric-value mode))
- (calc-top)))))
-)
+ (calc-top))))))
(defun calc-unpack-type (item)
(cond ((eq (car-safe item) 'vec)
(hms . -3) (sdev . -4) (mod . -5)
(frac . -10) (float . -11)
(date . -13) )))
- (error "Argument must be a composite object"))))
-)
+ (error "Argument must be a composite object")))))
(defun calc-unpack-item (mode item)
(cond ((not mode)
(list (calcFunc-mant item) (calcFunc-xpon item))
(error "Expected a floating-point number")))
(t
- (error "Invalid unpacking mode: %d" mode)))
-)
+ (error "Invalid unpacking mode: %d" mode))))
(setq calc-unpack-with-type nil)
(defun calc-diag (n)
(calc-enter-result 1 "diag" (if n
(list 'calcFunc-diag (calc-top-n 1)
(prefix-numeric-value n))
- (list 'calcFunc-diag (calc-top-n 1)))))
-)
+ (list 'calcFunc-diag (calc-top-n 1))))))
(defun calc-ident (n)
(interactive "NDimension of identity matrix = ")
(calc-enter-result 0 "idn" (if (eq n 0)
'(calcFunc-idn 1)
(list 'calcFunc-idn 1
- (prefix-numeric-value n)))))
-)
+ (prefix-numeric-value n))))))
(defun calc-index (n &optional stack)
(interactive "NSize of vector = \nP")
(if (consp stack)
(calc-enter-result 3 "indx" (cons 'calcFunc-index (calc-top-list-n 3)))
(calc-enter-result 0 "indx" (list 'calcFunc-index
- (prefix-numeric-value n)))))
-)
+ (prefix-numeric-value n))))))
(defun calc-build-vector (n)
(interactive "NSize of vector = ")
(calc-wrapper
(calc-enter-result 1 "bldv" (list 'calcFunc-cvec
(calc-top-n 1)
- (prefix-numeric-value n))))
-)
+ (prefix-numeric-value n)))))
(defun calc-cons (arg)
(interactive "P")
(calc-wrapper
(if (calc-is-hyperbolic)
(calc-binary-op "rcns" 'calcFunc-rcons arg)
- (calc-binary-op "cons" 'calcFunc-cons arg)))
-)
+ (calc-binary-op "cons" 'calcFunc-cons arg))))
(defun calc-head (arg)
(calc-unary-op "tail" 'calcFunc-tail arg))
(if (calc-is-hyperbolic)
(calc-unary-op "rhed" 'calcFunc-rhead arg)
- (calc-unary-op "head" 'calcFunc-head arg))))
-)
+ (calc-unary-op "head" 'calcFunc-head arg)))))
(defun calc-tail (arg)
(interactive "P")
(calc-invert-func)
- (calc-head arg)
-)
+ (calc-head arg))
(defun calc-vlength (arg)
(interactive "P")
(calc-wrapper
(if (calc-is-hyperbolic)
(calc-unary-op "dims" 'calcFunc-mdims arg)
- (calc-unary-op "len" 'calcFunc-vlen arg)))
-)
+ (calc-unary-op "len" 'calcFunc-vlen arg))))
(defun calc-arrange-vector (n)
(interactive "NNumber of columns = ")
(calc-wrapper
(calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1)
- (prefix-numeric-value n))))
-)
+ (prefix-numeric-value n)))))
(defun calc-vector-find (arg)
(interactive "P")
(let ((func (cons 'calcFunc-find (calc-top-list-n 2))))
(calc-enter-result
2 "find"
- (if arg (append func (list (prefix-numeric-value arg))) func))))
-)
+ (if arg (append func (list (prefix-numeric-value arg))) func)))))
(defun calc-subvector ()
(interactive)
(if (calc-is-inverse)
(calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec
(calc-top-list-n 3)))
- (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3)))))
-)
+ (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3))))))
(defun calc-reverse-vector (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "rev" 'calcFunc-rev arg))
-)
+ (calc-unary-op "rev" 'calcFunc-rev arg)))
(defun calc-mask-vector (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "vmsk" 'calcFunc-vmask arg))
-)
+ (calc-binary-op "vmsk" 'calcFunc-vmask arg)))
(defun calc-expand-vector (arg)
(interactive "P")
(calc-wrapper
(if (calc-is-hyperbolic)
(calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3)))
- (calc-binary-op "vexp" 'calcFunc-vexp arg)))
-)
+ (calc-binary-op "vexp" 'calcFunc-vexp arg))))
(defun calc-sort ()
(interactive)
(calc-slow-wrapper
(if (calc-is-inverse)
(calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1)))
- (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1)))))
-)
+ (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1))))))
(defun calc-grade ()
(interactive)
(calc-slow-wrapper
(if (calc-is-inverse)
(calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1)))
- (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1)))))
-)
+ (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))))
(defun calc-histogram (n)
(interactive "NNumber of bins: ")
(prefix-numeric-value n)))
(calc-enter-result 1 "hist" (list 'calcFunc-histogram
(calc-top-n 1)
- (prefix-numeric-value n)))))
-)
+ (prefix-numeric-value n))))))
(defun calc-transpose (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "trn" 'calcFunc-trn arg))
-)
+ (calc-unary-op "trn" 'calcFunc-trn arg)))
(defun calc-conj-transpose (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "ctrn" 'calcFunc-ctrn arg))
-)
+ (calc-unary-op "ctrn" 'calcFunc-ctrn arg)))
(defun calc-cross (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "cros" 'calcFunc-cross arg))
-)
+ (calc-binary-op "cros" 'calcFunc-cross arg)))
(defun calc-remove-duplicates (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "rdup" 'calcFunc-rdup arg))
-)
+ (calc-unary-op "rdup" 'calcFunc-rdup arg)))
(defun calc-set-union (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup))
-)
+ (calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup)))
(defun calc-set-intersect (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup))
-)
+ (calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup)))
(defun calc-set-difference (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup))
-)
+ (calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup)))
(defun calc-set-xor (arg)
(interactive "P")
(calc-wrapper
- (calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup))
-)
+ (calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup)))
(defun calc-set-complement (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "cmpl" 'calcFunc-vcompl arg))
-)
+ (calc-unary-op "cmpl" 'calcFunc-vcompl arg)))
(defun calc-set-floor (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "vflr" 'calcFunc-vfloor arg))
-)
+ (calc-unary-op "vflr" 'calcFunc-vfloor arg)))
(defun calc-set-enumerate (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "enum" 'calcFunc-venum arg))
-)
+ (calc-unary-op "enum" 'calcFunc-venum arg)))
(defun calc-set-span (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "span" 'calcFunc-vspan arg))
-)
+ (calc-unary-op "span" 'calcFunc-vspan arg)))
(defun calc-set-cardinality (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "card" 'calcFunc-vcard arg))
-)
+ (calc-unary-op "card" 'calcFunc-vcard arg)))
(defun calc-unpack-bits (arg)
(interactive "P")
(calc-wrapper
(if (calc-is-inverse)
(calc-unary-op "bpck" 'calcFunc-vpack arg)
- (calc-unary-op "bupk" 'calcFunc-vunpack arg)))
-)
+ (calc-unary-op "bupk" 'calcFunc-vunpack arg))))
(defun calc-pack-bits (arg)
(interactive "P")
(calc-invert-func)
- (calc-unpack-bits arg)
-)
+ (calc-unpack-bits arg))
(defun calc-rnorm (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "rnrm" 'calcFunc-rnorm arg))
-)
+ (calc-unary-op "rnrm" 'calcFunc-rnorm arg)))
(defun calc-cnorm (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "cnrm" 'calcFunc-cnorm arg))
-)
+ (calc-unary-op "cnrm" 'calcFunc-cnorm arg)))
(defun calc-mrow (n &optional nn)
(interactive "NRow number: \nP")
(calc-enter-result 1 "rrow" (list 'calcFunc-mrrow
(calc-top-n 1) (- n)))
(calc-enter-result 1 "mrow" (list 'calcFunc-mrow
- (calc-top-n 1) n))))))
-)
+ (calc-top-n 1) n)))))))
(defun calc-mcol (n &optional nn)
(interactive "NColumn number: \nP")
(calc-enter-result 1 "rcol" (list 'calcFunc-mrcol
(calc-top-n 1) (- n)))
(calc-enter-result 1 "mcol" (list 'calcFunc-mcol
- (calc-top-n 1) n))))))
-)
+ (calc-top-n 1) n)))))))
;;;; Vectors.
(defun calcFunc-mdims (m)
(or (math-vectorp m)
(math-reject-arg m 'vectorp))
- (cons 'vec (math-mat-dimens m))
-)
+ (cons 'vec (math-mat-dimens m)))
;;; Apply a function elementwise to vector A. [V X V; N X N] [Public]
(defun math-map-vec (f a)
(if (math-vectorp a)
(cons 'vec (mapcar f (cdr a)))
- (funcall f a))
-)
+ (funcall f a)))
(defun math-dimension-error ()
(calc-record-why "*Dimension error")
- (signal 'wrong-type-argument nil)
-)
+ (signal 'wrong-type-argument nil))
;;; Build a vector out of a list of objects. [Public]
(defun calcFunc-vec (&rest objs)
- (cons 'vec objs)
-)
+ (cons 'vec objs))
;;; Build a constant vector or matrix. [Public]
(defun calcFunc-cvec (obj &rest dims)
- (math-make-vec-dimen obj dims)
-)
+ (math-make-vec-dimen obj dims))
(defun math-make-vec-dimen (obj dims)
(if dims
(math-make-vec-dimen obj (cdr dims)))))
(cons 'vec (make-list (car dims) obj)))
(math-reject-arg (car dims) 'fixnatnump))
- obj)
-)
+ obj))
(defun calcFunc-head (vec)
(if (and (Math-vectorp vec)
(cdr vec))
(nth 1 vec)
(calc-record-why 'vectorp vec)
- (list 'calcFunc-head vec))
-)
+ (list 'calcFunc-head vec)))
(defun calcFunc-tail (vec)
(if (and (Math-vectorp vec)
(cdr vec))
(cons 'vec (cdr (cdr vec)))
(calc-record-why 'vectorp vec)
- (list 'calcFunc-tail vec))
-)
+ (list 'calcFunc-tail vec)))
(defun calcFunc-cons (head tail)
(if (Math-vectorp tail)
(cons 'vec (cons head (cdr tail)))
(calc-record-why 'vectorp tail)
- (list 'calcFunc-cons head tail))
-)
+ (list 'calcFunc-cons head tail)))
(defun calcFunc-rhead (vec)
(if (and (Math-vectorp vec)
(setcdr (nthcdr (- (length vec) 2) vec) nil)
vec)
(calc-record-why 'vectorp vec)
- (list 'calcFunc-rhead vec))
-)
+ (list 'calcFunc-rhead vec)))
(defun calcFunc-rtail (vec)
(if (and (Math-vectorp vec)
(cdr vec))
(nth (1- (length vec)) vec)
(calc-record-why 'vectorp vec)
- (list 'calcFunc-rtail vec))
-)
+ (list 'calcFunc-rtail vec)))
(defun calcFunc-rcons (head tail)
(if (Math-vectorp head)
(append head (list tail))
(calc-record-why 'vectorp head)
- (list 'calcFunc-rcons head tail))
-)
+ (list 'calcFunc-rcons head tail)))
(while (setq b (cdr b))
(setq v (cons (funcall f a (car b)) v)))
(cons 'vec (nreverse v)))
- (funcall f a b)))
-)
+ (funcall f a b))))
(setq accum (funcall f accum (car a))))
accum)
0)
- a)
-)
+ a))
;;; Reduce a function over the columns of matrix A. [V X V] [Public]
(defun math-reduce-cols (f a)
(if (math-matrixp a)
(cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a))))
- a)
-)
+ a))
(defun math-reduce-cols-col-step (f a col cols)
(and (< col cols)
(cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a))
- (math-reduce-cols-col-step f a (1+ col) cols)))
-)
+ (math-reduce-cols-col-step f a (1+ col) cols))))
(defun math-reduce-cols-row-step (f tot col a)
(if a
(funcall f tot (nth col (car a)))
col
(cdr a))
- tot)
-)
+ tot))
(while (setq a (cdr a) b (cdr b))
(setq accum (math-add accum (math-mul (car a) (car b)))))
accum)
- 0)
-)
+ 0))
;;; Return the number of elements in vector V. [Public]
(1- (length v))
(if (math-objectp v)
0
- (list 'calcFunc-vlen v)))
-)
+ (list 'calcFunc-vlen v))))
;;; Get the Nth row of a matrix.
(defun calcFunc-mrow (mat n) ; [Public]
(or (Math-vectorp mat)
(math-reject-arg mat 'vectorp))
(or (nth n mat)
- (math-reject-arg n "*Index out of range"))))
-)
+ (math-reject-arg n "*Index out of range")))))
(defun calcFunc-subscr (mat n &optional m)
(setq mat (calcFunc-mrow mat n))
(if (math-num-integerp n)
(calcFunc-mrow mat m)
(calcFunc-mcol mat m))
- mat)
-)
+ mat))
;;; Get the Nth column of a matrix.
(defun math-mat-col (mat n)
- (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat)))
-)
+ (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat))))
(defun calcFunc-mcol (mat n) ; [Public]
(if (Math-vectorp n)
(and (< n (length (nth 1 mat)))
(math-mat-col mat n))
(nth n mat))
- (math-reject-arg n "*Index out of range"))))
-)
+ (math-reject-arg n "*Index out of range")))))
;;; Remove the Nth row from a matrix.
(defun math-mat-less-row (mat n)
(if (<= n 0)
(cdr mat)
(cons (car mat)
- (math-mat-less-row (cdr mat) (1- n))))
-)
+ (math-mat-less-row (cdr mat) (1- n)))))
(defun calcFunc-mrrow (mat n) ; [Public]
(and (integerp (setq n (math-check-integer n)))
(> n 0)
(< n (length mat))
- (math-mat-less-row mat n))
-)
+ (math-mat-less-row mat n)))
;;; Remove the Nth column from a matrix.
(defun math-mat-less-col (mat n)
(cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n)))
- (cdr mat)))
-)
+ (cdr mat))))
(defun calcFunc-mrcol (mat n) ; [Public]
(and (integerp (setq n (math-check-integer n)))
(if (math-matrixp mat)
(and (< n (length (nth 1 mat)))
(math-mat-less-col mat n))
- (math-mat-less-row mat n)))
-)
+ (math-mat-less-row mat n))))
(defun calcFunc-getdiag (mat) ; [Public]
(if (math-square-matrixp mat)
(cons 'vec (math-get-diag-step (cdr mat) 1))
(calc-record-why 'square-matrixp mat)
- (list 'calcFunc-getdiag mat))
-)
+ (list 'calcFunc-getdiag mat)))
(defun math-get-diag-step (row n)
(and row
(cons (nth n (car row))
- (math-get-diag-step (cdr row) (1+ n))))
-)
+ (math-get-diag-step (cdr row) (1+ n)))))
(defun math-transpose (mat) ; [Public]
(let ((m nil)
(col (length (nth 1 mat))))
(while (> (setq col (1- col)) 0)
(setq m (cons (math-mat-col mat col) m)))
- (cons 'vec m))
-)
+ (cons 'vec m)))
(defun calcFunc-trn (mat)
(if (math-vectorp mat)
(math-col-matrix mat))
(if (math-numberp mat)
mat
- (math-reject-arg mat 'matrixp)))
-)
+ (math-reject-arg mat 'matrixp))))
(defun calcFunc-ctrn (mat)
- (calcFunc-conj (calcFunc-trn mat))
-)
+ (calcFunc-conj (calcFunc-trn mat)))
(defun calcFunc-pack (mode els)
(or (Math-vectorp els) (math-reject-arg els 'vectorp))
(if (= (calc-pack-size mode) (1- (length els)))
(calc-pack-items mode (cdr els))
(math-reject-arg els "*Wrong number of elements"))
- (error (math-reject-arg els (nth 1 err))))
-)
+ (error (math-reject-arg els (nth 1 err)))))
(defun calcFunc-unpack (mode thing)
(or (integerp mode) (math-reject-arg mode 'fixnump))
(condition-case err
(cons 'vec (calc-unpack-item mode thing))
- (error (math-reject-arg thing (nth 1 err))))
-)
+ (error (math-reject-arg thing (nth 1 err)))))
(defun calcFunc-unpackt (mode thing)
(let ((calc-unpack-with-type 'pair))
- (calcFunc-unpack mode thing))
-)
+ (calcFunc-unpack mode thing)))
(defun calcFunc-arrange (vec cols) ; [Public]
(setq cols (math-check-fixnum cols t))
flat next))
(if flat
(setq mat (nconc mat (list (cons 'vec flat)))))
- mat)))
-)
+ mat))))
(defun math-flatten-vector (vec) ; [L V]
(if (math-vectorp vec)
(apply 'append (mapcar 'math-flatten-vector (cdr vec)))
- (list vec))
-)
+ (list vec)))
(defun calcFunc-vconcat (a b)
- (math-normalize (list '| a b))
-)
+ (math-normalize (list '| a b)))
(defun calcFunc-vconcatrev (a b)
- (math-normalize (list '| b a))
-)
+ (math-normalize (list '| b a)))
(defun calcFunc-append (v1 v2)
(if (and (math-vectorp v1) (math-vectorp v2))
(append v1 (cdr v2))
- (list 'calcFunc-append v1 v2))
-)
+ (list 'calcFunc-append v1 v2)))
(defun calcFunc-appendrev (v1 v2)
- (calcFunc-append v2 v1)
-)
+ (calcFunc-append v2 v1))
;;; Copy a matrix. [Public]
(defun math-copy-matrix (m)
(if (math-vectorp (nth 1 m))
(cons 'vec (mapcar 'copy-sequence (cdr m)))
- (copy-sequence m))
-)
+ (copy-sequence m)))
;;; Convert a scalar or vector into an NxN diagonal matrix. [Public]
(defun calcFunc-diag (a &optional n)
(cons 'vec (math-diag-step (cdr a) 0 (1- (length a))))))
(if n
(cons 'vec (math-diag-step (make-list n a) 0 n))
- (list 'calcFunc-diag a)))
-)
+ (list 'calcFunc-diag a))))
(defun calcFunc-idn (a &optional n)
(if n
(calcFunc-diag a n))
(if (integerp calc-matrix-mode)
(calcFunc-idn a calc-matrix-mode)
- (list 'calcFunc-idn a)))
-)
+ (list 'calcFunc-idn a))))
(defun math-mimic-ident (a m)
(if (math-square-matrixp m)
a)))
(cdr m)))
(math-dimension-error))
- (calcFunc-idn a)))
-)
+ (calcFunc-idn a))))
(defun math-diag-step (a n m)
(if (< n m)
(cons (car a)
(make-list (1- (- m n)) 0))))
(math-diag-step (cdr a) (1+ n) m))
- nil)
-)
+ nil))
;;; Create a vector of consecutive integers. [Public]
(defun calcFunc-index (n &optional start incr)
(while (>= i n)
(setq vec (cons i vec)
i (1- i))))))
- (cons 'vec vec)))
-)
+ (cons 'vec vec))))
;;; Find an element in a vector.
(defun calcFunc-find (vec x &optional start)
(while (and vec (not (Math-equal x (car vec))))
(setq n (1+ n)
vec (cdr vec)))
- (if vec n 0))
-)
+ (if vec n 0)))
;;; Return a subvector of a vector.
(defun calcFunc-subvec (vec start &optional end)
(if (<= end len)
(let ((chop (nthcdr (- end start 1) (setq vec (copy-sequence vec)))))
(setcdr chop nil)))
- (cons 'vec vec)))
-)
+ (cons 'vec vec))))
;;; Remove a subvector from a vector.
(defun calcFunc-rsubvec (vec start &optional end)
(let ((tail (nthcdr end vec))
(chop (nthcdr (1- start) (setq vec (copy-sequence vec)))))
(setcdr chop nil)
- (append vec tail))))
-)
+ (append vec tail)))))
;;; Reverse the order of the elements of a vector.
(defun calcFunc-rev (vec)
(if (math-vectorp vec)
(cons 'vec (reverse (cdr vec)))
- (math-reject-arg vec 'vectorp))
-)
+ (math-reject-arg vec 'vectorp)))
;;; Compress a vector according to a mask vector.
(defun calcFunc-vmask (mask vec)
(while (setq mask (cdr mask) vec (cdr vec))
(or (math-zerop (car mask))
(setq new (cons (car vec) new))))
- (cons 'vec (nreverse new))))
-)
+ (cons 'vec (nreverse new)))))
;;; Expand a vector according to a mask vector.
(defun calcFunc-vexp (mask vec &optional filler)
(car mask)) new))
(setq vec (cdr vec)
new (cons (or (car vec) (car mask)) new))))
- (cons 'vec (nreverse new)))
-)
+ (cons 'vec (nreverse new))))
;;; Compute the row and column norms of a vector or matrix. [Public]
(math-reduce-vec 'math-max (math-map-vec 'calcFunc-cnorm a))
(math-reduce-vec 'math-max (math-map-vec 'math-abs a)))
(calc-record-why 'vectorp a)
- (list 'calcFunc-rnorm a))
-)
+ (list 'calcFunc-rnorm a)))
(defun calcFunc-cnorm (a)
(if (and (Math-vectorp a)
(math-reduce-cols 'math-add-abs a))
(math-reduce-vec 'math-add-abs a))
(calc-record-why 'vectorp a)
- (list 'calcFunc-cnorm a))
-)
+ (list 'calcFunc-cnorm a)))
(defun math-add-abs (a b)
- (math-add (math-abs a) (math-abs b))
-)
+ (math-add (math-abs a) (math-abs b)))
;;; Sort the elements of a vector into increasing order.
(defun calcFunc-sort (vec) ; [Public]
(if (math-vectorp vec)
(cons 'vec (sort (copy-sequence (cdr vec)) 'math-beforep))
- (math-reject-arg vec 'vectorp))
-)
+ (math-reject-arg vec 'vectorp)))
(defun calcFunc-rsort (vec) ; [Public]
(if (math-vectorp vec)
(cons 'vec (nreverse (sort (copy-sequence (cdr vec)) 'math-beforep)))
- (math-reject-arg vec 'vectorp))
-)
+ (math-reject-arg vec 'vectorp)))
(defun calcFunc-grade (grade-vec)
(if (math-vectorp grade-vec)
(let* ((len (1- (length grade-vec))))
(cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep)))
- (math-reject-arg grade-vec 'vectorp))
-)
+ (math-reject-arg grade-vec 'vectorp)))
(defun calcFunc-rgrade (grade-vec)
(if (math-vectorp grade-vec)
(let* ((len (1- (length grade-vec))))
(cons 'vec (nreverse (sort (cdr (calcFunc-index len))
'math-grade-beforep))))
- (math-reject-arg grade-vec 'vectorp))
-)
+ (math-reject-arg grade-vec 'vectorp)))
(defun math-grade-beforep (i j)
- (math-beforep (nth i grade-vec) (nth j grade-vec))
-)
+ (math-beforep (nth i grade-vec) (nth j grade-vec)))
;;; Compile a histogram of data from a vector.
(< bin n)
(aset res bin (math-add (aref res bin)
(if wvec (car (setq wp (cdr wp))) wts)))))
- (cons 'vec (append res nil)))
-)
+ (cons 'vec (append res nil))))
;;; Set operations.
(setq b (list b))
(or (math-vectorp b) (math-reject-arg b 'vectorp))
(setq b (cdr b)))
- (calcFunc-rdup (append a b))
-)
+ (calcFunc-rdup (append a b)))
(defun calcFunc-vint (a b)
(if (and (math-simple-set a) (math-simple-set b))
(setq b (cdr b))))
(nreverse vec)))
(calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a)
- (calcFunc-vcompl b))))
-)
+ (calcFunc-vcompl b)))))
(defun calcFunc-vdiff (a b)
(if (and (math-simple-set a) (math-simple-set b))
(setq vec (cons (car a) vec)
a (cdr a))))
(nreverse vec)))
- (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b)))
-)
+ (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b))))
(defun calcFunc-vxor (a b)
(if (and (math-simple-set a) (math-simple-set b))
(let ((ca (calcFunc-vcompl a))
(cb (calcFunc-vcompl b)))
(calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b))
- (calcFunc-vcompl (calcFunc-vunion a cb)))))
-)
+ (calcFunc-vcompl (calcFunc-vunion a cb))))))
(defun calcFunc-vcompl (a)
(setq a (math-prepare-set a))
(setq vec (cons (list 'intv (+ closed 1)
prev '(var inf var-inf))
vec)))
- (math-clean-set (nreverse vec)))
-)
+ (math-clean-set (nreverse vec))))
(defun calcFunc-vspan (a)
(setq a (math-prepare-set a))
(logand (nth 1 last) 1))
(nth 2 (nth 1 a))
(nth 3 last)))
- '(intv 2 0 0))
-)
+ '(intv 2 0 0)))
(defun calcFunc-vfloor (a &optional always-vec)
(setq a (math-prepare-set a))
(or (Math-lessp b a)
(setq vec (cons (setq prev (list 'intv mask a b)) vec)))))
(setq vec (nreverse vec))
- (math-clean-set vec always-vec))
-)
+ (math-clean-set vec always-vec)))
(defun calcFunc-vcard (a)
(setq a (calcFunc-vfloor a t))
(setq count (math-add count (math-sub (nth 3 (car a))
(nth 2 (car a))))))
(setq count (math-add count 1)))
- count)
-)
+ count))
(defun calcFunc-venum (a)
(setq a (calcFunc-vfloor a t))
(nth 2 (nth 1 p))))
(cdr (cdr p)))))
(setq p next))
- a)
-)
+ a))
(defun calcFunc-vpack (a)
(setq a (calcFunc-vfloor a t))
(math-power-of-2 (1+ (nth 3 (car a))))
(math-power-of-2 (nth 2 (car a)))))))
(setq accum (math-add accum (math-power-of-2 (car a))))))
- accum)
-)
+ accum))
(defun calcFunc-vunpack (a &optional w)
(or (math-num-integerp a) (math-reject-arg a 'integerp))
vec))))
(if neg
(setq vec (cons (list 'intv 2 len '(var inf var-inf)) vec)))
- (math-clean-set (nreverse vec)))
-)
+ (math-clean-set (nreverse vec))))
(defun calcFunc-rdup (a)
(if (math-simple-set a)
(setcdr p (cdr (cdr p)))
(setq p (cdr p)))))
(cons 'vec a))
- (math-clean-set (math-prepare-set a)))
-)
+ (math-clean-set (math-prepare-set a))))
(defun math-prepare-set (a)
(if (Math-objectp a)
(nth 3 (nth 1 p))
(nth 3 (nth 2 p))))
(cdr (cdr (cdr p))))))))
- a
-)
+ a)
(defun math-clean-set (a &optional always-vec)
(let ((p a) res)
(eq (car-safe (nth 1 a)) 'intv)
(not always-vec))
(nth 1 a)
- a))
-)
+ a)))
(defun math-simple-set (a)
(or (and (Math-objectp a)
(progn
(while (and (setq a (cdr a))
(not (eq (car-safe (car a)) 'intv))))
- (null a))))
-)
+ (null a)))))
(math-sub (math-mul (nth 1 a) (nth 2 b))
(math-mul (nth 2 a) (nth 1 b))))
(math-reject-arg b "*Three-vector expected"))
- (math-reject-arg a "*Three-vector expected"))
-)
+ (math-reject-arg a "*Three-vector expected")))
(throw 'syntax "Expected `]'")))
(or (eq exp-token 'end)
(math-read-token))
- vals))
-)
+ vals)))
(defun math-check-for-commas (&optional balancing)
(let ((count 0)
(setq count (1- count)))))
(if balancing
pos
- (and pos (= (aref exp-str pos) ?,))))
-)
+ (and pos (= (aref exp-str pos) ?,)))))
(defun math-read-vector ()
(let* ((val (list (math-read-expr-level 0)))
(let ((rest (list (math-read-expr-level 0))))
(setcdr last rest)
(setq last rest)))
- (cons 'vec val))
-)
+ (cons 'vec val)))
(defun math-read-matrix (mat)
(while (equal exp-data ";")
(while (eq exp-token 'space)
(math-read-token))
(setq mat (nconc mat (list (math-read-vector)))))
- mat
-)
+ mat)
+;;; calc-vec.el ends here
(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")
(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.
(if (eq (car-safe val) 'error)
(error "Bad format in yanked data")
val))
- val)))))))
-)
+ val))))))))
(defun calc-clean-newlines (s)
(cond
(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)
(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)
(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)
(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)
(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"
(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)
(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
(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.
(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 ()
(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."
(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))
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
report-calc-bug)
))
-
)
(calc-init-base)
(define-key calc-dispatch-map (substring keys 0 1) nil))
(define-key calc-dispatch-map keys 'calc-same-interface))))
(error nil))
- (calc-do-dispatch arg)
-)
+ (calc-do-dispatch arg))
(defun calc-do-dispatch (arg)
(let ((key (calc-read-key-sequence
(progn
(or (commandp key) (calc-extensions))
(call-interactively key))
- (beep)))
-)
+ (beep))))
(setq calc-dispatch-help nil)
(defun calc-read-key-sequence (prompt map)
(char-to-string (cdr key)))))
"" prompt2)))
(use-global-map glob)
- (use-local-map loc))))
-)
+ (use-local-map loc)))))
(eval (cons 'progn calc-defs))
(setq calc-defs nil)
(calc-set-mode-line)))
- (calc-check-defines)
-)
+ (calc-check-defines))
(defun calc-check-defines ()
(if (symbol-plist 'calc-define)
(setq plist (cdr (cdr plist))))
;; See if this has added any more calc-define properties.
(calc-check-defines))
- (setplist 'calc-define nil))))
-)
+ (setplist 'calc-define nil)))))
(setq calc-check-defines 'calc-check-defines) ; suitable for run-hooks
(defun calc-trail-mode (&optional buf)
(let ((buffer-read-only nil))
(insert "Emacs Calculator v" calc-version " by Dave Gillespie, "
"installed " calc-installed-date "\n")))
- (run-hooks 'calc-trail-mode-hook)
-)
+ (run-hooks 'calc-trail-mode-hook))
(defun calc-create-buffer ()
(set-buffer (get-buffer-create "*Calculator*"))
(if calc-language
(progn
(calc-extensions)
- (calc-set-language calc-language calc-language-option t)))
-)
+ (calc-set-language calc-language calc-language-option t))))
;;;###autoload
(defun calc (&optional arg full-display interactive)
(progn
(sit-for 2)
(message "")))
- (setq calc-said-hello t))))
-)
+ (setq calc-said-hello t)))))
;;;###autoload
(defun full-calc ()
"Invoke the Calculator and give it a full-sized window."
(interactive)
- (calc nil t (interactive-p))
-)
+ (calc nil t (interactive-p)))
(defun calc-same-interface (arg)
"Invoke the Calculator using the most recent interface (calc or calc-keypad)."
(MacEdit-finish-edit)
(if calc-was-keypad-mode
(calc-keypad)
- (calc arg calc-full-mode t)))))
-)
+ (calc arg calc-full-mode t))))))
(defun calc-quit (&optional non-fatal)
(delete-windows-on kbuf))
(bury-buffer buf)
(bury-buffer calc-trail-buffer)
- (and kbuf (bury-buffer kbuf))))))
-)
+ (and kbuf (bury-buffer kbuf)))))))
;;;###autoload
(defun quick-calc ()
"Do a quick calculation in the minibuffer without invoking full Calculator."
(interactive)
- (calc-do-quick-calc)
-)
+ (calc-do-quick-calc))
;;;###autoload
(defun calc-eval (str &optional separator &rest args)
"Do a quick calculation and return the result as a string.
Return value will either be the formatted result in string form,
or a list containing a character position and an error message in string form."
- (calc-do-calc-eval str separator args)
-)
+ (calc-do-calc-eval str separator args))
;;;###autoload
(defun calc-keypad ()
Or, position the cursor manually and do M-x calc-keypad-press."
(interactive)
(calc-extensions)
- (calc-do-keypad calc-full-mode (interactive-p))
-)
+ (calc-do-keypad calc-full-mode (interactive-p)))
;;;###autoload
(defun full-calc-keypad ()
See calc-keypad for details."
(interactive)
(calc-extensions)
- (calc-do-keypad t (interactive-p))
-)
+ (calc-do-keypad t (interactive-p)))
;;; Note that modifications to this function may break calc-pass-errors.
(calc-set-mode-line)
(and calc-embedded-info
(calc-embedded-finish-command))))
- (identity nil) ; allow a GC after timing is done
-)
+ (identity nil)) ; allow a GC after timing is done
+
(setq calc-aborted-prefix nil)
(setq calc-start-time nil)
(defun calc-set-command-flag (f)
(if (not (memq f calc-command-flags))
- (setq calc-command-flags (cons f calc-command-flags)))
-)
+ (setq calc-command-flags (cons f calc-command-flags))))
(defun calc-select-buffer ()
(or (eq major-mode 'calc-mode)
(let ((buf (get-buffer "*Calculator*")))
(if buf
(set-buffer buf)
- (error "Calculator buffer not available")))))
-)
+ (error "Calculator buffer not available"))))))
(defun calc-cursor-stack-index (&optional index)
(goto-char (point-max))
- (forward-line (- (calc-substack-height (or index 1))))
-)
+ (forward-line (- (calc-substack-height (or index 1)))))
(defun calc-stack-size ()
- (- (length calc-stack) calc-stack-top)
-)
+ (- (length calc-stack) calc-stack-top))
(defun calc-substack-height (n)
(let ((sum 0)
(setq sum (+ sum (nth 1 (car stack)))
n (1- n)
stack (cdr stack)))
- sum)
-)
+ sum))
(defun calc-set-mode-line ()
(save-excursion
nil
(setq mode-line-buffer-identification new-mode-string)
(set-buffer-modified-p (buffer-modified-p))
- (and calc-embedded-info (calc-embedded-mode-line-change)))))
-)
+ (and calc-embedded-info (calc-embedded-mode-line-change))))))
(defun calc-align-stack-window ()
(if (eq major-mode 'calc-mode)
(goto-char (1- (match-end 0)))))
(save-excursion
(calc-select-buffer)
- (calc-align-stack-window)))
-)
+ (calc-align-stack-window))))
(defun calc-check-stack (n)
(if (> n (calc-stack-size))
(error "Too few elements on stack"))
(if (< n 0)
- (error "Invalid argument"))
-)
+ (error "Invalid argument")))
(defun calc-push-list (vals &optional m sels)
(while vals
(calc-record-undo (list 'push mm))
(calc-set-command-flag 'renum-stack))))
(setq vals (cdr vals)
- sels (cdr sels)))
-)
+ sels (cdr sels))))
(defun calc-pop-push-list (n vals &optional m sels)
(if (and calc-any-selections (null sels))
(calc-replace-selections n vals m)
(calc-pop-stack n m sels)
- (calc-push-list vals m sels))
-)
+ (calc-push-list vals m sels)))
(defun calc-pop-push-record-list (n prefix vals &optional m sels)
(or (and (consp vals)
(if (cdr vals)
(calc-record-list vals prefix)
(calc-record (car vals) prefix)))
- (calc-pop-push-list n vals m sels)
-)
+ (calc-pop-push-list n vals m sels))
(defun calc-enter-result (n prefix vals &optional m)
(setq calc-aborted-prefix prefix)
(if (equal vals '((nil)))
(setq vals nil))
(calc-pop-push-record-list n prefix vals m)
- (calc-handle-whys)
-)
+ (calc-handle-whys))
(defun calc-normalize (val)
(if (memq calc-simplify-mode '(nil none num))
(math-normalize val)
(calc-extensions)
- (calc-normalize-fancy val))
-)
+ (calc-normalize-fancy val)))
(defun calc-handle-whys ()
(if calc-next-why
- (calc-do-handle-whys))
-)
+ (calc-do-handle-whys)))
(defun calc-pop-stack (&optional n m sel-ok) ; pop N objs at level M of stack.
(calc-cursor-stack-index n)
(setq calc-stack (nthcdr n calc-stack))
(delete-region (point) (point-max))))
- (calc-set-command-flag 'renum-stack)))))
-)
+ (calc-set-command-flag 'renum-stack))))))
(defun calc-get-stack-element (x)
(cond ((eq sel-mode 'entry)
(car x))
(sel-mode
(calc-sel-error))
- (t (nth 2 x)))
-)
+ (t (nth 2 x))))
;; Get the Nth element of the stack (N=1 is the top element).
(defun calc-top (&optional n sel-mode)
(or n (setq n 1))
(calc-check-stack n)
- (calc-get-stack-element (nth (+ n calc-stack-top -1) calc-stack))
-)
+ (calc-get-stack-element (nth (+ n calc-stack-top -1) calc-stack)))
(defun calc-top-n (&optional n sel-mode) ; in case precision has changed
- (math-check-complete (calc-normalize (calc-top n sel-mode)))
-)
+ (math-check-complete (calc-normalize (calc-top n sel-mode))))
(defun calc-top-list (&optional n m sel-mode)
(or n (setq n 1))
(let ((top (copy-sequence (nthcdr (+ m calc-stack-top -1)
calc-stack))))
(setcdr (nthcdr (1- n) top) nil)
- (nreverse (mapcar 'calc-get-stack-element top))))
-)
+ (nreverse (mapcar 'calc-get-stack-element top)))))
(defun calc-top-list-n (&optional n m sel-mode)
(mapcar 'math-check-complete
- (mapcar 'calc-normalize (calc-top-list n m sel-mode)))
-)
+ (mapcar 'calc-normalize (calc-top-list n m sel-mode))))
(defun calc-renumber-stack ()
(beginning-of-line)
(setq lnum (1+ lnum)
stack (cdr stack))))))
- (and calc-embedded-info (calc-embedded-stack-change))
-)
+ (and calc-embedded-info (calc-embedded-stack-change)))
(defun calc-refresh (&optional align)
(interactive)
(save-excursion
(set-buffer (aref calc-embedded-info 1))
(calc-refresh align)))
- (setq calc-refresh-count (1+ calc-refresh-count))
-)
+ (setq calc-refresh-count (1+ calc-refresh-count)))
(defun calc-x-paste-text (arg)
(if (eq (car-safe val) 'error)
(error "%s in yanked data" (nth 2 val)))))
(calc-enter-result 0 "Xynk" val))))
- (x-paste-text arg))
-)
+ (x-paste-text arg)))
(save-excursion
(let ((win (get-buffer-window (current-buffer))))
(and win
- (pos-visible-in-window-p (1- (point-max)) win))))
-)
+ (pos-visible-in-window-p (1- (point-max)) win)))))
(defun calc-trail-buffer ()
(and (or (null calc-trail-buffer)
(set-buffer calc-trail-buffer)
(goto-line 2)
(setq calc-trail-pointer (point-marker))))
- calc-trail-buffer
-)
+ calc-trail-buffer)
(defun calc-record (val &optional prefix)
(setq calc-aborted-prefix nil)
(if (and aligned win (not (memq 'hold-trail calc-command-flags)))
(calc-trail-here))
(goto-char (1- (point-max))))))))
- val
-)
+ val)
(defun calc-trail-display (flag &optional no-refresh)
(if (interactive-p)
(calc-do-refresh)
(calc-refresh))))))))
- calc-trail-buffer
-)
+ calc-trail-buffer)
(defun calc-trail-here ()
(interactive)
(set-buffer calc-main-buffer)
(setq overlay-arrow-string calc-trail-overlay
overlay-arrow-position calc-trail-pointer))))))
- (error "Not in Calc Trail buffer"))
-)
+ (error "Not in Calc Trail buffer")))
(cdr calc-undo-list)))
(setq calc-undo-list (cons (list rec) calc-undo-list)
calc-redo-list nil)
- (calc-set-command-flag 'undo)))
-)
+ (calc-set-command-flag 'undo))))
(mapcar 'math-check-complete
(calc-top-list 2))))
(calc-extensions)
- (calc-binary-op-fancy name func arg ident unary))
-)
+ (calc-binary-op-fancy name func arg ident unary)))
(defun calc-unary-op (name func arg &optional func2)
(setq calc-aborted-prefix name)
(calc-enter-result 1 name (list (or func2 func)
(math-check-complete (calc-top 1))))
(calc-extensions)
- (calc-unary-op-fancy name func arg))
-)
+ (calc-unary-op-fancy name func arg)))
(defun calc-plus (arg)
(interactive "P")
(calc-slow-wrapper
- (calc-binary-op "+" 'calcFunc-add arg 0 nil '+))
-)
+ (calc-binary-op "+" 'calcFunc-add arg 0 nil '+)))
(defun calc-minus (arg)
(interactive "P")
(calc-slow-wrapper
- (calc-binary-op "-" 'calcFunc-sub arg 0 'neg '-))
-)
+ (calc-binary-op "-" 'calcFunc-sub arg 0 'neg '-)))
(defun calc-times (arg)
(interactive "P")
(calc-slow-wrapper
- (calc-binary-op "*" 'calcFunc-mul arg 1 nil '*))
-)
+ (calc-binary-op "*" 'calcFunc-mul arg 1 nil '*)))
(defun calc-divide (arg)
(interactive "P")
(calc-slow-wrapper
- (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv '/))
-)
+ (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv '/)))
(defun calc-change-sign (arg)
(interactive "P")
(calc-wrapper
- (calc-unary-op "chs" 'neg arg))
-)
+ (calc-unary-op "chs" 'neg arg)))
((= n 0)
(calc-push-list (calc-top-list (calc-stack-size))))
(t
- (calc-push-list (calc-top-list n)))))
-)
+ (calc-push-list (calc-top-list n))))))
(defun calc-pop (n)
(= nn 1)
(calc-top-selected 1 1))
(calc-delete-selection 1)
- (calc-pop-stack nn))))))
-)
+ (calc-pop-stack nn)))))))
(if (eq calc-prev-char 'dots)
(progn
(calc-extensions)
- (calc-dots))))))
-)
+ (calc-dots)))))))
(defsubst calc-minibuffer-size ()
(- (point-max) (minibuffer-prompt-end)))
(>= last-input-char 128))
last-input-char
nil))))
- (exit-minibuffer))
-)
+ (exit-minibuffer)))
(defun calc-minibuffer-contains (rex)
(save-excursion
(goto-char (minibuffer-prompt-end))
- (looking-at rex))
-)
+ (looking-at rex)))
(defun calcDigit-key ()
(interactive)
(beep)
(calc-temp-minibuffer-message " [Bad format]"))))))
(setq calc-prev-prev-char calc-prev-char
- calc-prev-char last-command-char)
-)
+ calc-prev-char last-command-char))
(defun calcDigit-backspace ()
(if (= (calc-minibuffer-size) 0)
(progn
(setq last-command-char 13)
- (calcDigit-nondigit)))
-)
+ (calcDigit-nondigit))))
(calc-record-why "*Variable is void" (nth 1 err)))))
(if (consp (car a))
(math-dimension-error)
- (cons (car a) args)))))))
-)
+ (cons (car a) args))))))))
(math-floatp (nth 2 a))
(and (eq (car a) 'intv) (math-floatp (nth 3 a)))))
((eq (car-safe a) 'date)
- (math-floatp (nth 1 a))))
-)
+ (math-floatp (nth 1 a)))))
((eq (car-safe a) 'incomplete)
(calc-incomplete-error a))
((consp a) a)
- (t (error "Invalid data object encountered")))
-)
+ (t (error "Invalid data object encountered"))))
(defun math-bignum (a)
(if (>= a 0)
(cons 'bigpos (math-bignum-big a))
- (cons 'bigneg (math-bignum-big (- a))))
-)
+ (cons 'bigneg (math-bignum-big (- a)))))
(defun math-bignum-big (a) ; [L s]
(if (= a 0)
nil
- (cons (% a 1000) (math-bignum-big (/ a 1000))))
-)
+ (cons (% a 1000) (math-bignum-big (/ a 1000)))))
;;; Build a normalized floating-point number. [F I S]
(if (and (>= exp 3000000)
(>= (+ exp (math-numdigs mant) -1) 4000000))
(signal 'math-overflow nil)
- (list 'float mant exp))))
-)
+ (list 'float mant exp)))))
(defun math-div10-bignum (a) ; [l l]
(if (cdr a)
(cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100))
(math-div10-bignum (cdr a)))
- (list (/ (car a) 10)))
-)
+ (list (/ (car a) 10))))
;;; Coerce A to be a float. [F N; V V] [Public]
(defun math-float (a)
((eq (car a) 'float) a)
((memq (car a) '(cplx polar vec hms date sdev mod))
(cons (car a) (mapcar 'math-float (cdr a))))
- (t (math-float-fancy a)))
-)
+ (t (math-float-fancy a))))
(defun math-neg (a)
(list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a)))
((memq (car a) '(cplx vec hms date calcFunc-idn))
(cons (car a) (mapcar 'math-neg (cdr a))))
- (t (math-neg-fancy a)))
-)
+ (t (math-neg-fancy a))))
;;; Compute the number of decimal digits in integer A. [S I]
((= a 0) 0)
((> a -10) 1)
((> a -100) 2)
- (t (math-numdigs (- a)))))
-)
+ (t (math-numdigs (- a))))))
;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S]
(defun math-scale-int (a n)
(cond ((= n 0) a)
((> n 0) (math-scale-left a n))
- (t (math-normalize (math-scale-right a (- n)))))
-)
+ (t (math-normalize (math-scale-right a (- n))))))
(defun math-scale-left (a n) ; [I I S]
(if (= n 0)
(* a 100))
(if (or (>= a 100000) (<= a -100000))
(math-scale-left (math-bignum a) 1)
- (* a 10))))))
-)
+ (* a 10)))))))
(defun math-scale-left-bignum (a n)
(if (>= n 3)
n (- n 3)) 3)))
(if (> n 0)
(math-mul-bignum-digit a (if (= n 2) 100 10) 0)
- a)
-)
+ a))
(defun math-scale-right (a n) ; [i i S]
(if (= n 0)
(/ a 100)
(if (= n 1)
(/ a 10)
- a)))))
-)
+ a))))))
(defun math-scale-right-bignum (a n) ; [L L S; l l S]
(if (>= n 3)
n (% n 3)))
(if (> n 0)
(cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0))
- a)
-)
+ a))
;;; Multiply (with rounding) the integer A by 10^N. [I i S]
(defun math-scale-rounding (a n)
(- (math-scale-rounding (- a) n))
(if (= n -1)
(/ (+ a 5) 10)
- (/ (+ (math-scale-right a (- -1 n)) 5) 10)))))
-)
+ (/ (+ (math-scale-right a (- -1 n)) 5) 10))))))
;;; Compute the sum of A and B. [O O O] [Public]
(and (calc-extensions)
(math-add-objects-fancy a b))))
(and (calc-extensions)
- (math-add-symb-fancy a b)))
-)
+ (math-add-symb-fancy a b))))
(defun math-add-bignum (a b) ; [L L L; l l l]
(if a
(nconc a b)
a)))
a)
- b)
-)
+ b))
(defun math-sub-bignum (a b) ; [l l l]
(if b
(setq b (cdr b)))
(and b
'neg))
- a)
-)
+ a))
(defun math-add-float (a b) ; [F F F]
(let ((ediff (- (nth 2 a) (nth 2 b))))
b
(math-make-float (math-add (nth 1 a)
(math-scale-left (nth 1 b) ediff))
- (nth 2 a)))))
-)
+ (nth 2 a))))))
;;; Compute the difference of A and B. [O O O] [Public]
(defun math-sub (a b)
(setq a (- a b))
(if (or (<= a -1000000) (>= a 1000000))
(math-bignum a)
- a))
-)
+ a)))
(defun math-sub-float (a b) ; [F F F]
(let ((ediff (- (nth 2 a) (nth 2 b))))
(math-make-float (math-add (nth 1 a)
(Math-integer-neg
(math-scale-left (nth 1 b) ediff)))
- (nth 2 a)))))
-)
+ (nth 2 a))))))
;;; Compute the product of A and B. [O O O] [Public]
(and (calc-extensions)
(math-mul-objects-fancy a b))))
(and (calc-extensions)
- (math-mul-symb-fancy a b)))
-)
+ (math-mul-symb-fancy a b))))
(defun math-infinitep (a &optional undir)
(while (and (consp a) (memq (car a) '(* / neg)))
(memq (nth 2 a) '(var-inf var-uinf var-nan))
(if (and undir (eq (nth 2 a) 'var-inf))
'(var uinf var-uinf)
- a))
-)
+ a)))
;;; Multiply digit lists A and B. [L L L; l l l]
(defun math-mul-bignum (a b)
(if (cdr ss)
(setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss))))
(setcdr ss (list (/ prod 1000))))))
- sum))
-)
+ sum)))
;;; Multiply digit list A by digit D. [L L D D; l l D D]
(defun math-mul-bignum-digit (a d c)
(setcdr aa (list (/ prod 1000))))
a))
(and (> c 0)
- (list c)))
-)
+ (list c))))
;;; Compute the integer (quotient . remainder) of A and B, which may be
(math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
(car res)))
(math-normalize (cons (car a) (cdr res))))))
- (cons (/ a b) (% a b)))
-)
+ (cons (/ a b) (% a b))))
(defun math-quotient (a b) ; [I I I] [Public]
(if (and (not (consp a)) (not (consp b)))
(math-mul-bignum-digit (cdr b) d 0)
alen blen)))
(math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg)
- (car res))))))
-)
+ (car res)))))))
;;; Divide a bignum digit list by another. [l.l l L]
(cons (car res)
(car (math-div-bignum-digit (cdr res) d)))))
(let ((res (math-div-bignum-digit a (car b))))
- (cons (car res) (list (cdr res)))))
-)
+ (cons (car res) (list (cdr res))))))
;;; Divide a bignum digit list by a digit. [l.D l D]
(defun math-div-bignum-digit (a b)
(cons
(cons (/ num b) (car res))
(% num b)))
- '(nil . 0))
-)
+ '(nil . 0)))
(defun math-div-bignum-big (a b alen blen) ; [l.l l L]
(if (< alen blen)
(res2 (math-div-bignum-part num b blen)))
(cons
(cons (car res2) (car res))
- (cdr res2))))
-)
+ (cdr res2)))))
(defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L]
(let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0)))
(den (nth (1- blen) b))
(guess (min (/ num den) 999)))
- (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess))
-)
+ (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess)))
(defun math-div-bignum-try (a b c guess) ; [D.l l l D]
(let ((rem (math-sub-bignum a c)))
(if (eq rem 'neg)
(math-div-bignum-try a b (math-sub-bignum c b) (1- guess))
- (cons guess rem)))
-)
+ (cons guess rem))))
;;; Compute the quotient of A and B. [O O N] [Public]
(and (calc-extensions)
(math-div-objects-fancy a b))))
(and (calc-extensions)
- (math-div-symb-fancy a b)))
-)
+ (math-div-symb-fancy a b))))
(defun math-div-float (a b) ; [F F F]
(let ((ldiff (max (- (1+ calc-internal-prec)
(- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b))))
0)))
(math-make-float (math-quotient (math-scale-int (nth 1 a) ldiff) (nth 1 b))
- (- (- (nth 2 a) (nth 2 b)) ldiff)))
-)
+ (- (- (nth 2 a) (nth 2 b)) ldiff))))
(aset s 0 ?1)
(aset s 1 ?:))))
(setcar (cdr entry) (calc-count-lines s))
- s)
-)
+ s))
(defun math-stack-value-offset (c)
(let* ((num (if calc-line-numbering 4 0))
(if (integerp calc-line-breaking)
(setq wid calc-line-breaking)))
(cons (max (- off (length calc-left-label)) 0)
- (+ wid num)))
-)
+ (+ wid num))))
(defun calc-count-lines (s)
(let ((pos 0)
(while (setq newpos (string-match "\n" s pos))
(setq pos (1+ newpos)
num (1+ num)))
- num)
-)
+ num))
(defun math-format-value (a &optional w)
(if (and (Math-scalarp a)
(math-format-number a)
(calc-extensions)
(let ((calc-line-breaking nil))
- (math-composition-to-string (math-compose-expr a 0) w)))
-)
+ (math-composition-to-string (math-compose-expr a 0) w))))
(defun calc-window-width ()
(if calc-embedded-info
(let ((win (get-buffer-window (aref calc-embedded-info 0))))
(1- (if win (window-width win) (frame-width))))
(- (window-width (get-buffer-window (current-buffer)))
- (if calc-line-numbering 5 1)))
-)
+ (if calc-line-numbering 5 1))))
(defun math-comp-concat (c1 c2)
(if (and (stringp c1) (stringp c2))
(concat c1 c2)
- (list 'horiz c1 c2))
-)
+ (list 'horiz c1 c2)))
(math-format-number a)))
(t
(calc-extensions)
- (math-format-flat-expr-fancy a prec)))
-)
+ (math-format-flat-expr-fancy a prec))))
str)))
(t
(calc-extensions)
- (math-format-number-fancy a prec)))
-)
+ (math-format-number-fancy a prec))))
(defun math-format-bignum (a) ; [X L]
(if (and (= calc-number-radix 10)
(not calc-group-digits))
(math-format-bignum-decimal a)
(calc-extensions)
- (math-format-bignum-fancy a))
-)
+ (math-format-bignum-fancy a)))
(defun math-format-bignum-decimal (a) ; [X L]
(if a
(setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s)
a (cdr (cdr a))))
(concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s))
- "0")
-)
+ "0"))
(list 'float (nth 1 mant) (+ (nth 2 mant) exp)))))))
;; Syntax error!
- (t nil)))
-)
+ (t nil))))
(defun math-match-substring (s n)
(if (match-beginning n)
(substring s (match-beginning n) (match-end n))
- "")
-)
+ ""))
(defun math-read-bignum (s) ; [l X]
(if (> (length s) 3)
(cons (string-to-int (substring s -3))
(math-read-bignum (substring s 0 -3)))
- (list (string-to-int s)))
-)
+ (list (string-to-int s))))
(defconst math-tex-ignore-words
"Parse the region as a vector of numbers and push it on the Calculator stack."
(interactive "r\nP")
(calc-extensions)
- (calc-do-grab-region top bot arg)
-)
+ (calc-do-grab-region top bot arg))
;;;###autoload
(defun calc-grab-rectangle (top bot arg)
"Parse a rectangle as a matrix of numbers and push it on the Calculator stack."
(interactive "r\nP")
(calc-extensions)
- (calc-do-grab-rectangle top bot arg)
-)
+ (calc-do-grab-rectangle top bot arg))
(defun calc-grab-sum-down (top bot arg)
"Parse a rectangle as a matrix of numbers and sum its columns."
(interactive "r\nP")
(calc-extensions)
- (calc-do-grab-rectangle top bot arg 'calcFunc-reduced)
-)
+ (calc-do-grab-rectangle top bot arg 'calcFunc-reduced))
(defun calc-grab-sum-across (top bot arg)
"Parse a rectangle as a matrix of numbers and sum its rows."
(interactive "r\nP")
(calc-extensions)
- (calc-do-grab-rectangle top bot arg 'calcFunc-reducea)
-)
+ (calc-do-grab-rectangle top bot arg 'calcFunc-reducea))
;;;###autoload
"Start Calc Embedded mode on the formula surrounding point."
(interactive "P")
(calc-extensions)
- (calc-do-embedded arg end obeg oend)
-)
+ (calc-do-embedded arg end obeg oend))
;;;###autoload
(defun calc-embedded-activate (&optional arg cbuf)
"Scan the current editing buffer for all embedded := and => formulas.
Also looks for the equivalent TeX words, \\gets and \\evalto."
(interactive "P")
- (calc-do-embedded-activate arg cbuf)
-)
+ (calc-do-embedded-activate arg cbuf))
(defun calc-user-invocation ()
(interactive)
(or (stringp calc-invocation-macro)
(error "Use `Z I' inside Calc to define a `M-# Z' keyboard macro"))
- (execute-kbd-macro calc-invocation-macro nil)
-)
+ (execute-kbd-macro calc-invocation-macro nil))
;;;###autoload
(defmacro defmath (func args &rest body) ; [Public]
(calc-extensions)
- (math-do-defmath func args body)
-)
+ (math-do-defmath func args body))
;;; Functions needed for Lucid Emacs support.
(cons key key)))
(t
(let ((key (read-char)))
- (cons key key))))
-)
+ (cons key key)))))
(defun calc-unread-command (&optional input)
(if (featurep 'xemacs)
(if calc-always-load-extensions
(progn
(calc-extensions)
- (calc-load-everything))
-)
+ (calc-load-everything)))
(run-hooks 'calc-load-hook)
-
+;;; calc.el ends here
;; 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.
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: ")
(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
(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: ")
(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: ")
(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: ")
(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.
(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)
(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)
(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))))))
(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))))
(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
;;(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;
" is "
(math-format-value val 1000)
"\n")
- val)
-)
+ val))
(defvar math-integral-cache nil)
(defvar math-integral-cache-state nil)
(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)
(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)
;; 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)
(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)
(math-integ-try-parts expr)
;; Give up.
- nil))
-)
+ nil)))
(defun math-integ-parts-easy (expr)
(cond ((Math-primp expr) t)
(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:
(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
(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)
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)
(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)
(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)
(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)
(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)
((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)
"\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)
(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
(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
(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)
(math-div (math-mul 2 (math-to-radians-2
(list 'calcFunc-arctan
(math-div part rq))))
- rq))))
-)
+ rq)))))
(math-defintegral calcFunc-erf
(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)
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)
(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)
(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))
(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)
(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)
(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)
(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)
(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)
(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)
(or val
(let* ((math-tabulate-initial 1)
(math-tabulate-function 'calcFunc-prod))
- (calcFunc-table expr var low high))))
-)
+ (calcFunc-table expr var low high)))))
(math-try-solve-for t1 rhs sign))
(t
(calc-record-why "*No inverse known" lhs)
- nil)))
-)
+ nil))))
(setq math-solve-ranges nil)
(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)
(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"
(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"
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
(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
(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))
(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
(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))
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))
(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
(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)
(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)
(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)
(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)
(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.
dxold))))
(or (and (math-floatp x)
(math-poly-integer-root x))
- x))
-)
+ x)))
(defun math-solve-above-dummy (x)
(and (not (Math-primp x))
(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)
(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)
(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)
(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.
(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)
(car res2)))
x (cdr x)
res2 (cdr res2)))
- accum)
-)
+ accum))
(defun math-get-from-counter (name)
(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))
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
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
(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)
(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
(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
nfac))))
(and fprime
(math-normalize accum))))
- (list 'calcFunc-taylor expr var num)))
-)
-
-
-
+ (list 'calcFunc-taylor expr var num))))
+;;; calcalg2.el ends here
;; 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.
(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: ")
(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)
(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)
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)
(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))
(if coefnames
(setq model (math-multi-subst model (cdr coefnames) (cdr coefs))))
(setq varnames vars
- coefnames coefs))
-)
+ coefnames coefs)))
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
(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)
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)
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)
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)])
(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))
(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).
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))
(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)
(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)
(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))
'(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)
(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)])
(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)
(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))
(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))
(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)))))
(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)
(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)
(setq ns (1- ns)
dy (nth ns d)))
(setq y (math-add y dy)))
- (list y dy)))
-)
+ (list y dy))))
(math-ninteg-romberg
'math-ninteg-midpoint expr
(math-float lo) (math-float hi) nil))))
- sum))
-)
+ sum)))
;;; Open Romberg method; "qromo" in section 4.4.
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)
(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"
expr
(math-mul (math-add lo hi) '(float 5 -1))
mode)))))
- (nth 1 integ-temp)
-)
+ (nth 1 integ-temp))
(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)
(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)
(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)
(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)
(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
;; 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.
(if (eq calc-language 'eqn)
" , " ", ")
0)
- right))))))))
-)
+ right)))))))))
(defconst math-eqn-special-funcs
'( calcFunc-log
(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
(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)
(concat comma-spc " ")))))
a)))
res)))
- (nreverse res))
-)
+ (nreverse res)))
(defun math-compose-rows (a count first)
(if (cdr a)
(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
(cons
" } "
(math-compose-eqn-matrix (cdr a)))))))
- nil)
-)
+ nil))
(defun math-vector-is-string (a)
(while (and (setq a (cdr a))
(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)))
p (+ p 2))))))
(if quoted
(concat "\"" a "\"")
- a)
-)
+ a))
(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
( ?\\ . "\\\\" )
( ?\a . "\\a" )
(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)
(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)
(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)
(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)
(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)
(make-list (1- h) " |")
'("\\|")))
" "
- c))))
-)
+ c)))))
(put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
(defun math-compose-choose (a prec)
(list 'vcent
(math-comp-height a1)
a1 " " a2)
- ")"))
-)
+ ")")))
(put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
(defun math-compose-integ (a prec)
(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)
(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)
(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 ()
(or (< off 0)
(and calc-display-origin
(> calc-line-breaking calc-display-origin)))
- (setq wid calc-line-breaking)))
-)
+ (setq wid calc-line-breaking))))
(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)
(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
(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))
(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))
(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))
(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
(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)
(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)
(<= 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)
(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.
(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)
(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)
(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))
(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))
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)
(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)
(+ (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))
(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))
(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.
(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).
(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
(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
;; 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.
(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")
(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)
(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)
(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)
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
projects / emacs.git / commitdiff