Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume24/gnucalc/part27

Text File | 1991-10-31 | 55.4 KB | 1,907 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i075:  gnucalc - GNU Emacs Calculator, v2.00, Part27/56
Message-ID: <[e-mail]>
X-Md4-Signature: 9dd6a9f30938340a6dcdffcc4e7274d1
Date: Thu, 31 Oct 1991 07:28:38 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 75
Archive-name: gnucalc/part27
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-sel.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 27; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-sel.el'
else
echo 'x - continuing file calc-sel.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-sel.el' &&
X                       num
X                       (list (and reselect alg)))))
X     (calc-handle-whys)))
)
X
(defun calc-sel-sub-both-sides (no-simp)
X  (interactive "P")
X  (calc-sel-add-both-sides no-simp t)
)
X
SHAR_EOF
echo 'File calc-sel.el is complete' &&
chmod 0644 calc-sel.el ||
echo 'restore of calc-sel.el failed'
Wc_c="`wc -c < 'calc-sel.el'`"
test 25519 -eq "$Wc_c" ||
    echo 'calc-sel.el: original size 25519, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-stat.el ==============
if test -f 'calc-stat.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-stat.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-stat.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-stat.el' &&
;; Calculator for GNU Emacs, part II [calc-stat.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-stat () nil)
X
X
;;; Statistical operations on vectors.
X
(defun calc-vector-count (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-vector-op "coun" 'calcFunc-vcount arg))
)
X
(defun calc-vector-sum (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-vector-op "vprd" 'calcFunc-vprod arg)
X     (calc-vector-op "vsum" 'calcFunc-vsum arg)))
)
X
(defun calc-vector-product (arg)
X  (interactive "P")
X  (calc-hyperbolic-func)
X  (calc-vector-sum arg)
)
X
(defun calc-vector-max (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (calc-vector-op "vmin" 'calcFunc-vmin arg)
X     (calc-vector-op "vmax" 'calcFunc-vmax arg)))
)
X
(defun calc-vector-min (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-vector-max arg)
)
X
(defun calc-vector-mean (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (if (calc-is-inverse)
X       (calc-vector-op "harm" 'calcFunc-vhmean arg)
X     (calc-vector-op "medn" 'calcFunc-vmedian arg))
X     (if (calc-is-inverse)
X     (calc-vector-op "meae" 'calcFunc-vmeane arg)
X       (calc-vector-op "mean" 'calcFunc-vmean arg))))
)
X
(defun calc-vector-mean-error (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-vector-mean arg)
)
X
(defun calc-vector-median (arg)
X  (interactive "P")
X  (calc-hyperbolic-func)
X  (calc-vector-mean arg)
)
X
(defun calc-vector-harmonic-mean (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-hyperbolic-func)
X  (calc-vector-mean arg)
)
X
(defun calc-vector-geometric-mean (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-binary-op "geom" 'calcFunc-agmean arg)
X     (calc-vector-op "geom" 'calcFunc-vgmean arg)))
)
X
(defun calc-vector-sdev (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (if (calc-is-inverse)
X       (calc-vector-op "pvar" 'calcFunc-vpvar arg)
X     (calc-vector-op "var" 'calcFunc-vvar arg))
X     (if (calc-is-inverse)
X     (calc-vector-op "psdv" 'calcFunc-vpsdev arg)
X       (calc-vector-op "sdev" 'calcFunc-vsdev arg))))
)
X
(defun calc-vector-pop-sdev (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-vector-sdev arg)
)
X
(defun calc-vector-variance (arg)
X  (interactive "P")
X  (calc-hyperbolic-func)
X  (calc-vector-sdev arg)
)
X
(defun calc-vector-pop-variance (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-hyperbolic-func)
X  (calc-vector-sdev arg)
)
X
(defun calc-vector-covariance (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (let ((n (if (eq arg 1) 1 2)))
X     (if (calc-is-hyperbolic)
X     (calc-enter-result n "corr" (cons 'calcFunc-vcorr
X                       (calc-top-list-n n)))
X       (if (calc-is-inverse)
X       (calc-enter-result n "pcov" (cons 'calcFunc-vpcov
X                         (calc-top-list-n n)))
X     (calc-enter-result n "cov" (cons 'calcFunc-vcov
X                      (calc-top-list-n n)))))))
)
X
(defun calc-vector-pop-covariance (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-vector-covariance arg)
)
X
(defun calc-vector-correlation (arg)
X  (interactive "P")
X  (calc-hyperbolic-func)
X  (calc-vector-covariance arg)
)
X
(defun calc-vector-op (name func arg)
X  (setq calc-aborted-prefix name
X    arg (prefix-numeric-value arg))
X  (if (< arg 0)
X      (error "Negative arguments not allowed"))
X  (calc-enter-result arg name (cons func (calc-top-list-n arg)))
)
X
X
X
X
;;; Useful statistical functions
X
;;; Sum, product, etc., of one or more values or vectors.
;;; Each argument must be either a number or a vector.  Vectors
;;; are flattened, but variables inside are assumed to represent
;;; non-vectors.
X
(defun calcFunc-vsum (&rest vecs)
X  (math-reduce-many-vecs 'calcFunc-add 'calcFunc-vsum vecs 0)
)
X
(defun calcFunc-vprod (&rest vecs)
X  (math-reduce-many-vecs 'calcFunc-mul 'calcFunc-vprod vecs 1)
)
X
(defun calcFunc-vmax (&rest vecs)
X  (if (eq (car-safe (car vecs)) 'sdev)
X      '(var inf var-inf)
X    (if (eq (car-safe (car vecs)) 'intv)
X    (nth 3 (math-fix-int-intv (car vecs)))
X      (math-reduce-many-vecs 'calcFunc-max 'calcFunc-vmax vecs
X                 '(neg (var inf var-inf)))))
)
X
(defun calcFunc-vmin (&rest vecs)
X  (if (eq (car-safe (car vecs)) 'sdev)
X      '(neg (var inf var-inf))
X    (if (eq (car-safe (car vecs)) 'intv)
X    (nth 2 (math-fix-int-intv (car vecs)))
X      (math-reduce-many-vecs 'calcFunc-min 'calcFunc-vmin vecs
X                 '(var inf var-inf))))
)
X
(defun math-reduce-many-vecs (func whole-func vecs ident)
X  (let ((const-part nil)
X    (symb-part nil)
X    val vec)
X    (let ((calc-internal-prec (+ calc-internal-prec 2)))
X      (while vecs
X    (setq val (car vecs))
X    (and (eq (car-safe val) 'var)
X         (eq (car-safe (calc-var-value (nth 2 val))) 'vec)
X         (setq val (symbol-value (nth 2 val))))
X    (cond ((Math-vectorp val)
X           (setq vec (append (and const-part (list const-part))
X                 (math-flatten-vector val)))
X           (setq const-part (if vec
X                    (calcFunc-reducer
X                     (math-calcFunc-to-var func)
X                     (cons 'vec vec))
X                  ident)))
X          ((or (Math-objectp val) (math-infinitep val))
X           (setq const-part (if const-part
X                    (funcall func const-part val)
X                  val)))
X          (t
X           (setq symb-part (nconc symb-part (list val)))))
X    (setq vecs (cdr vecs))))
X    (if const-part
X    (progn
X      (setq const-part (math-normalize const-part))
X      (if symb-part
X          (funcall func const-part (cons whole-func symb-part))
X        const-part))
X      (if symb-part (cons whole-func symb-part) ident)))
)
X
X
;;; Return the number of data elements among the arguments.
(defun calcFunc-vcount (&rest vecs)
X  (let ((count 0))
X    (while vecs
X      (setq count (if (Math-vectorp (car vecs))
X              (+ count (math-count-elements (car vecs)))
X            (if (Math-objectp (car vecs))
X            (1+ count)
X              (if (and (eq (car-safe (car vecs)) 'var)
X                   (eq (car-safe (calc-var-value
X                          (nth 2 (car vecs))))
X                   'vec))
X              (+ count (math-count-elements
X                    (symbol-value (nth 2 (car vecs)))))
X            (math-reject-arg (car vecs) 'numvecp))))
X        vecs (cdr vecs)))
X    count)
)
X
(defun math-count-elements (vec)
X  (let ((count 0))
X    (while (setq vec (cdr vec))
X      (setq count (if (Math-vectorp (car vec))
X              (+ count (math-count-elements (car vec)))
X            (1+ count))))
X    count)
)
X
X
(defun math-flatten-many-vecs (vecs)
X  (let ((p vecs)
X    (vec (list 'vec)))
X    (while p
X      (setq vec (nconc vec
X               (if (Math-vectorp (car p))
X               (math-flatten-vector (car p))
X             (if (Math-objectp (car p))
X                 (list (car p))
X               (if (and (eq (car-safe (car p)) 'var)
X                    (eq (car-safe (calc-var-value
X                           (nth 2 (car p)))) 'vec))
X                   (math-flatten-vector (symbol-value
X                             (nth 2 (car p))))
X                 (math-reject-arg (car p) 'numvecp)))))
X        p (cdr p)))
X    vec)
)
X
(defun calcFunc-vflat (&rest vecs)
X  (math-flatten-many-vecs vecs)
)
X
(defun math-split-sdev-vec (vec zero-ok)
X  (let ((means (list 'vec))
X    (wts (list 'vec))
X    (exact nil)
X    (p vec))
X    (while (and (setq p (cdr p))
X        (not (and (consp (car p))
X              (eq (car (car p)) 'sdev)))))
X    (if (null p)
X    (list vec nil)
X      (while (setq vec (cdr vec))
X    (if (and (consp (setq p (car vec)))
X         (eq (car p) 'sdev))
X        (or exact
X        (setq means (cons (nth 1 p) means)
X              wts (cons (nth 2 p) wts)))
X      (if zero-ok
X          (setq means (cons (nth 1 p) means)
X            wts (cons 0 wts))
X        (or exact
X        (setq means (list 'vec)
X              wts nil
X              exact t))
X        (setq means (cons p means)))))
X      (list (nreverse means)
X        (and wts (nreverse wts)))))
)
X
X
;;; Return the arithmetic mean of the argument numbers or vectors.
;;; (If numbers are error forms, computes the weighted mean.)
(defun calcFunc-vmean (&rest vecs)
X  (let* ((split (math-split-sdev-vec (math-flatten-many-vecs vecs) nil))
X     (means (car split))
X     (wts (nth 1 split))
X     (len (1- (length means))))
X    (if (= len 0)
X    (math-reject-arg nil "*Must be at least 1 argument")
X      (if (and (= len 1) (eq (car-safe (nth 1 means)) 'intv))
X      (let ((x (math-fix-int-intv (nth 1 means))))
X        (calcFunc-vmean (nth 2 x) (nth 3 x)))
X    (math-with-extra-prec 2
X      (if (and wts (> len 1))
X          (let* ((sqrwts (calcFunc-map '(var mul var-mul) wts wts))
X             (suminvsqrwts (calcFunc-reduce
X                    '(var add var-add)
X                    (calcFunc-map '(var div var-div)
X                          1 sqrwts))))
X        (math-div (calcFunc-reduce '(var add var-add)
X                       (calcFunc-map '(var div var-div)
X                             means sqrwts))
X              suminvsqrwts))
X        (math-div (calcFunc-reduce '(var add var-add) means) len))))))
)
X
(defun math-fix-int-intv (x)
X  (if (math-floatp x)
X      x
X    (list 'intv 3
X      (if (memq (nth 1 x) '(2 3)) (nth 2 x) (math-add (nth 2 x) 1))
X      (if (memq (nth 1 x) '(1 3)) (nth 3 x) (math-sub (nth 3 x) 1))))
)
X
;;; Compute the mean with an error estimate.
(defun calcFunc-vmeane (&rest vecs)
X  (let* ((split (math-split-sdev-vec (math-flatten-many-vecs vecs) nil))
X     (means (car split))
X     (wts (nth 1 split))
X     (len (1- (length means))))
X    (if (= len 0)
X    (math-reject-arg nil "*Must be at least 1 argument")
X      (math-with-extra-prec 2
X    (if wts
X        (let* ((sqrwts (calcFunc-map '(var mul var-mul) wts wts))
X           (suminvsqrwts (calcFunc-reduce
X                  '(var add var-add)
X                  (calcFunc-map '(var div var-div)
X                        1 sqrwts))))
X          (math-make-sdev
X           (math-div (calcFunc-reduce '(var add var-add)
X                      (calcFunc-map '(var div var-div)
X                            means sqrwts))
X             suminvsqrwts)
X           (list 'calcFunc-sqrt (math-div 1 suminvsqrwts))))
X      (let ((mean (math-div (calcFunc-reduce '(var add var-add) means)
X                len)))
X        (math-make-sdev
X         mean
X         (list 'calcFunc-sqrt
X           (math-div (calcFunc-reducer
X                  '(var add var-add)
X                  (calcFunc-map '(var pow var-pow)
X                        (calcFunc-map '(var abs var-abs)
X                              (calcFunc-map
X                               '(var add var-add)
X                               means
X                               (math-neg mean)))
X                        2))
X                 (math-mul len (1- len))))))))))
)
X
X
;;; Compute the median of a list of values.
(defun calcFunc-vmedian (&rest vecs)
X  (let* ((flat (copy-sequence (cdr (math-flatten-many-vecs vecs))))
X     (p flat)
X     (len (length flat))
X     (hlen (/ len 2)))
X    (if (= len 0)
X    (math-reject-arg nil "*Must be at least 1 argument")
X      (if (and (= len 1) (memq (car-safe (car flat)) '(sdev intv)))
X      (calcFunc-vmean (car flat))
X    (while p
X      (if (eq (car-safe (car p)) 'sdev)
X          (setcar p (nth 1 (car p))))
X      (or (Math-anglep (car p))
X          (math-reject-arg (car p) 'anglep))
X      (setq p (cdr p)))
X    (setq flat (sort flat 'math-lessp))
X    (if (= (% len 2) 0)
X        (math-div (math-add (nth (1- hlen) flat) (nth hlen flat)) 2)
X      (nth hlen flat)))))
)
X
X
(defun calcFunc-vgmean (&rest vecs)
X  (let* ((flat (math-flatten-many-vecs vecs))
X     (len (1- (length flat))))
X    (if (= len 0)
X    (math-reject-arg nil "*Must be at least 1 argument")
X      (math-with-extra-prec 2
X    (let ((x (calcFunc-reduce '(var mul math-mul) flat)))
X      (if (= len 2)
X          (math-sqrt x)
X        (math-pow x (list 'frac 1 len)))))))
)
X
X
(defun calcFunc-agmean (a b)
X  (cond ((Math-equal a b) a)
X    ((math-zerop a) a)
X    ((math-zerop b) b)
X    (calc-symbolic-mode (math-inexact-result))
X    ((not (Math-realp a)) (math-reject-arg a 'realp))
X    ((not (Math-realp b)) (math-reject-arg b 'realp))
X    (t
X     (math-with-extra-prec 2
X       (setq a (math-float (math-abs a))
X         b (math-float (math-abs b)))
X       (let (mean)
X         (while (not (math-nearly-equal-float a b))
X           (setq mean (math-mul-float (math-add-float a b) '(float 5 -1))
X             b (math-sqrt-float (math-mul-float a b))
X             a mean))
X         a))))
)
X
X
(defun calcFunc-vhmean (&rest vecs)
X  (let* ((flat (math-flatten-many-vecs vecs))
X     (len (1- (length flat))))
X    (if (= len 0)
X    (math-reject-arg nil "*Must be at least 1 argument")
X      (math-with-extra-prec 2
X    (math-div len
X          (calcFunc-reduce '(var add math-add)
X                   (calcFunc-map '(var inv var-inv) flat))))))
)
X
X
X
;;; Compute the sample variance or standard deviation of numbers or vectors.
;;; (If the numbers are error forms, only the mean part of them is used.)
(defun calcFunc-vvar (&rest vecs)
X  (if (and (= (length vecs) 1)
X       (memq (car-safe (car vecs)) '(sdev intv)))
X      (if (eq (car-safe (car vecs)) 'intv)
X      (math-intv-variance (car vecs) nil)
X    (math-sqr (nth 2 (car vecs))))
X    (math-covariance vecs nil nil 0))
)
X
(defun calcFunc-vsdev (&rest vecs)
X  (if (and (= (length vecs) 1)
X       (memq (car-safe (car vecs)) '(sdev intv)))
X      (if (eq (car-safe (car vecs)) 'intv)
X      (if (math-floatp (car vecs))
X          (math-div (math-sub (nth 3 (car vecs)) (nth 2 (car vecs)))
X            (math-sqrt-12))
X        (math-sqrt (calcFunc-vvar (car vecs))))
X    (nth 2 (car vecs)))
X    (math-sqrt (math-covariance vecs nil nil 0)))
)
X
;;; Compute the population variance or std deviation of numbers or vectors.
(defun calcFunc-vpvar (&rest vecs)
X  (if (and (= (length vecs) 1)
X       (memq (car-safe (car vecs)) '(sdev intv)))
X      (if (eq (car-safe (car vecs)) 'intv)
X      (math-intv-variance (car vecs) t)
X    (math-sqr (nth 2 (car vecs))))
X    (math-covariance vecs nil t 0))
)
X
(defun calcFunc-vpsdev (&rest vecs)
X  (if (and (= (length vecs) 1)
X       (memq (car-safe (car vecs)) '(sdev intv)))
X      (if (eq (car-safe (car vecs)) 'intv)
X      (if (math-floatp (car vecs))
X          (math-div (math-sub (nth 3 (car vecs)) (nth 2 (car vecs)))
X            (math-sqrt-12))
X        (math-sqrt (calcFunc-vpvar (car vecs))))
X    (nth 2 (car vecs)))
X    (math-sqrt (math-covariance vecs nil t 0)))
)
X
(defun math-intv-variance (x pop)
X  (or (math-constp x) (math-reject-arg x 'constp))
X  (if (math-floatp x)
X      (math-div (math-sqr (math-sub (nth 3 x) (nth 2 x))) 12)
X    (let* ((x (math-fix-int-intv x))
X       (len (math-sub (nth 3 x) (nth 2 x)))
X       (hlen (math-quotient len 2)))
X      (math-div (if (math-evenp len)
X            (calcFunc-sum '(^ (var X var-X) 2) '(var X var-X)
X                  (math-neg hlen) hlen)
X          (calcFunc-sum '(^ (- (var X var-X) (/ 1 2)) 2)
X                '(var X var-X)
X                (math-neg hlen) (math-add hlen 1)))
X        (if pop (math-add len 1) len))))
)
X
;;; Compute the covariance and linear correlation coefficient.
(defun calcFunc-vcov (vec1 &optional vec2)
X  (math-covariance (list vec1) (list vec2) nil 1)
)
X
(defun calcFunc-vpcov (vec1 &optional vec2)
X  (math-covariance (list vec1) (list vec2) t 1)
)
X
(defun calcFunc-vcorr (vec1 &optional vec2)
X  (math-covariance (list vec1) (list vec2) nil 2)
)
X
X
(defun math-covariance (vec1 vec2 pop mode)
X  (or (car vec2) (= mode 0)
X      (progn
X    (if (and (eq (car-safe (car vec1)) 'var)
X         (eq (car-safe (calc-var-value (nth 2 (car vec1)))) 'vec))
X        (setq vec1 (symbol-value (nth 2 (car vec1))))
X      (setq vec1 (car vec1)))
X    (or (math-matrixp vec1) (math-dimension-error))
X    (or (= (length (nth 1 vec1)) 3) (math-dimension-error))
X    (setq vec2 (list (math-mat-col vec1 2))
X          vec1 (list (math-mat-col vec1 1)))))
X  (math-with-extra-prec 2
X    (let* ((split1 (math-split-sdev-vec (math-flatten-many-vecs vec1) nil))
X       (means1 (car split1))
X       (wts1 (nth 1 split1))
X       split2 means2 (wts2 nil)
X       (sqrwts nil)
X       suminvsqrwts
X       (len (1- (length means1))))
X      (if (< len (if pop 1 2))
X      (math-reject-arg nil (if pop
X                   "*Must be at least 1 argument"
X                 "*Must be at least 2 arguments")))
X      (if (or wts1 wts2)
X      (setq sqrwts (math-add
X            (if wts1
X                (calcFunc-map '(var mul var-mul) wts1 wts1)
X              0)
X            (if wts2
X                (calcFunc-map '(var mul var-mul) wts2 wts2)
X              0))
X        suminvsqrwts (calcFunc-reduce
X                  '(var add var-add)
X                  (calcFunc-map '(var div var-div) 1 sqrwts))))
X      (or (= mode 0)
X      (progn
X        (setq split2 (math-split-sdev-vec (math-flatten-many-vecs vec2)
X                          nil)
X          means2 (car split2)
X          wts2 (nth 2 split1))
X        (or (= len (1- (length means2))) (math-dimension-error))))
X      (let* ((diff1 (calcFunc-map
X             '(var add var-add)
X             means1
X             (if sqrwts
X             (math-div (calcFunc-reduce
X                    '(var add var-add)
X                    (calcFunc-map '(var div var-div)
X                          means1 sqrwts))
X                   (math-neg suminvsqrwts))
X               (math-div (calcFunc-reducer '(var add var-add) means1)
X                 (- len)))))
X         (diff2 (if (= mode 0)
X            diff1
X              (calcFunc-map
X               '(var add var-add)
X               means2
X               (if sqrwts
X               (math-div (calcFunc-reduce
X                      '(var add var-add)
X                      (calcFunc-map '(var div var-div)
X                            means2 sqrwts))
X                     (math-neg suminvsqrwts))
X             (math-div (calcFunc-reducer '(var add var-add) means2)
X                   (- len))))))
X         (covar (calcFunc-map '(var mul var-mul) diff1 diff2)))
X    (if sqrwts
X        (setq covar (calcFunc-map '(var div var-div) covar sqrwts)))
X    (math-div
X     (calcFunc-reducer '(var add var-add) covar)
X     (if (= mode 2)
X         (let ((var1 (calcFunc-map '(var mul var-mul) diff1 diff1))
X           (var2 (calcFunc-map '(var mul var-mul) diff2 diff2)))
X           (if sqrwts
X           (setq var1 (calcFunc-map '(var div var-div) var1 sqrwts)
X             var2 (calcFunc-map '(var div var-div) var2 sqrwts)))
X           (math-sqrt
X        (math-mul (calcFunc-reducer '(var add var-add) var1)
X              (calcFunc-reducer '(var add var-add) var2))))
X       (if sqrwts
X           (if pop
X           suminvsqrwts
X         (math-div (math-mul suminvsqrwts (1- len)) len))
X         (if pop len (1- len))))))))
)
X
X
X
X
SHAR_EOF
chmod 0644 calc-stat.el ||
echo 'restore of calc-stat.el failed'
Wc_c="`wc -c < 'calc-stat.el'`"
test 18079 -eq "$Wc_c" ||
    echo 'calc-stat.el: original size 18079, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-store.el ==============
if test -f 'calc-store.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-store.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-store.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-store.el' &&
;; Calculator for GNU Emacs, part II [calc-store.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-store () nil)
X
X
;;; Memory commands.
X
(defun calc-store (&optional var)
X  (interactive)
X  (let ((calc-store-keep t))
X    (calc-store-into var))
)
(setq calc-store-keep nil)
X
(defun calc-store-into (&optional var)
X  (interactive)
X  (calc-wrapper
X   (let ((calc-given-value nil)
X     (calc-given-value-flag 1))
X     (or var (setq var (calc-read-var-name "Store: " t)))
X     (if var
X     (let ((found (assq var '( ( + . calc-store-plus )
X                   ( - . calc-store-minus )
X                   ( * . calc-store-times )
X                   ( / . calc-store-div )
X                   ( ^ . calc-store-power )
X                   ( | . calc-store-concat ) ))))
X       (if found
X           (funcall (cdr found))
X         (calc-store-value var (or calc-given-value (calc-top 1))
X                   "" calc-given-value-flag)
X         (message "Stored to variable \"%s\"" (calc-var-name var))))
X       (setq var (calc-is-assignments (calc-top 1)))
X       (if var
X       (while var
X         (calc-store-value (car (car var)) (cdr (car var))
X                   (if (not (cdr var)) "")
X                   (if (not (cdr var)) 1))
X         (setq var (cdr var)))))))
)
X
(defun calc-store-plus (&optional var)
X  (interactive)
X  (calc-store-binary var "+" '+)
)
X
(defun calc-store-minus (&optional var)
X  (interactive)
X  (calc-store-binary var "-" '-)
)
X
(defun calc-store-times (&optional var)
X  (interactive)
X  (calc-store-binary var "*" '*)
)
X
(defun calc-store-div (&optional var)
X  (interactive)
X  (calc-store-binary var "/" '/)
)
X
(defun calc-store-power (&optional var)
X  (interactive)
X  (calc-store-binary var "^" '^)
)
X
(defun calc-store-concat (&optional var)
X  (interactive)
X  (calc-store-binary var "|" '|)
)
X
(defun calc-store-neg (n &optional var)
X  (interactive "p")
X  (calc-store-binary var "n" '/ (- n))
)
X
(defun calc-store-inv (n &optional var)
X  (interactive "p")
X  (calc-store-binary var "&" '^ (- n))
)
X
(defun calc-store-incr (n &optional var)
X  (interactive "p")
X  (calc-store-binary var "n" '- (- n))
)
X
(defun calc-store-decr (n &optional var)
X  (interactive "p")
X  (calc-store-binary var "n" '- n)
)
X
(defun calc-store-value (var value tag &optional pop)
X  (if var
X      (let ((old (calc-var-value var)))
X    (set var value)
X    (if pop (or calc-store-keep (calc-pop-stack pop)))
X    (calc-record-undo (list 'store (symbol-name var) old))
X    (if tag
X        (calc-record value (format ">%s%s" tag (calc-var-name var))))
X    (and (memq var '(var-e var-i var-pi var-phi var-gamma))
X         (eq (car-safe old) 'special-const)
X         (message "(Note: Built-in definition of %s has been lost)" var))
X    (and (memq var '(var-inf var-uinf var-nan))
X         (null old)
X         (message "(Note: %s has built-in meanings which may interfere)"
X              var))
X    (calc-refresh-evaltos var)))
)
X
(defun calc-var-name (var)
X  (if (symbolp var) (setq var (symbol-name var)))
X  (if (string-match "\\`var-." var)
X      (substring var 4)
X    var)
)
X
(defun calc-store-binary (var tag func &optional val)
X  (calc-wrapper
X   (let ((calc-simplify-mode (if (eq calc-simplify-mode 'none)
X                 'num calc-simplify-mode))
X     (value (or val (calc-top 1))))
X     (or var (setq var (calc-read-var-name (format "Store %s: " tag))))
X     (if var
X     (let ((old (calc-var-value var)))
X       (or old
X           (error "No such variable: \"%s\"" (calc-var-name var)))
X       (if (stringp old)
X           (setq old (math-read-expr old)))
X       (if (eq (car-safe old) 'error)
X           (error "Bad format in variable contents: %s" (nth 2 old)))
X       (calc-store-value var
X                 (calc-normalize (if (calc-is-inverse)
X                         (list func value old)
X                           (list func old value)))
X                 tag (and (not val) 1))
X       (message "Stored to variable \"%s\"" (calc-var-name var))))))
)
X
(defun calc-read-var-name (prompt &optional calc-store-opers)
X  (setq calc-given-value nil
X    calc-aborted-prefix nil)
X  (let ((var (let ((minibuffer-completion-table obarray)
X           (minibuffer-completion-predicate 'boundp)
X           (minibuffer-completion-confirm t))
X           (read-from-minibuffer prompt "var-" calc-var-name-map nil))))
X    (setq calc-aborted-prefix "")
X    (and (not (equal var ""))
X     (not (equal var "var-"))
X     (if (string-match "\\`\\([-a-zA-Z0-9]+\\) *:?=" var)
X         (if (null calc-given-value-flag)
X         (error "Assignment is not allowed in this command")
X           (let ((svar (intern (substring var 0 (match-end 1)))))
X         (setq calc-given-value-flag 0
X               calc-given-value (math-read-expr
X                     (substring var (match-end 0))))
X         (if (eq (car-safe calc-given-value) 'error)
X             (error "Bad format: %s" (nth 2 calc-given-value)))
X         (setq calc-given-value (math-evaluate-expr calc-given-value))
X         svar))
X       (intern var))))
)
(setq calc-given-value-flag nil)
X
(defvar calc-var-name-map nil "Keymap for reading Calc variable names.")
(if calc-var-name-map
X    ()
X  (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map))
X  (define-key calc-var-name-map " " 'self-insert-command)
X  (mapcar (function
X       (lambda (x)
X         (define-key calc-var-name-map (char-to-string x)
X           'calcVar-digit)))
X      "0123456789")
X  (mapcar (function
X       (lambda (x)
X         (define-key calc-var-name-map (char-to-string x)
X           'calcVar-oper)))
X      "+-*/^|")
)
X
(defun calcVar-digit ()
X  (interactive)
X  (if (calc-minibuffer-contains "var-\\'")
X      (if (eq calc-store-opers 0)
X      (beep)
X    (insert "q")
X    (self-insert-and-exit))
X    (self-insert-command 1))
)
X
(defun calcVar-oper ()
X  (interactive)
X  (if (and (eq calc-store-opers t)
X       (calc-minibuffer-contains "var-\\'"))
X      (progn
X    (erase-buffer)
X    (self-insert-and-exit))
X    (self-insert-command 1))
)
X
(defun calc-store-map (&optional oper var)
X  (interactive)
X  (calc-wrapper
X   (let* ((sel-mode nil)
X      (calc-dollar-values (mapcar 'calc-get-stack-element
X                      (nthcdr calc-stack-top calc-stack)))
X      (calc-dollar-used 0)
X      (oper (or oper (calc-get-operator "Store Mapping")))
X      (nargs (car oper)))
X     (or var (setq var (calc-read-var-name (format "Store Mapping %s: "
X                           (nth 2 oper)))))
X     (if var
X     (let ((old (or (calc-var-value var)
X            (error "No such variable: \"%s\""
X                   (calc-var-name var))))
X           (calc-simplify-mode (if (eq calc-simplify-mode 'none)
X                       'num calc-simplify-mode))
X           (values (and (> nargs 1)
X                (calc-top-list (1- nargs) (1+ calc-dollar-used)))))
X       (message "Working...")
X       (calc-set-command-flag 'clear-message)
X       (if (stringp old)
X           (setq old (math-read-expr old)))
X       (if (eq (car-safe old) 'error)
X           (error "Bad format in variable contents: %s" (nth 2 old)))
X       (setq values (if (calc-is-inverse)
X                (append values (list old))
X              (append (list old) values)))
X       (calc-store-value var
X                 (calc-normalize (cons (nth 1 oper) values))
X                 (nth 2 oper)
X                 (+ calc-dollar-used (1- nargs)))))))
)
X
(defun calc-store-exchange (&optional var)
X  (interactive)
X  (calc-wrapper
X   (let ((calc-given-value nil)
X     (calc-given-value-flag 1)
X     top)
X     (or var (setq var (calc-read-var-name "Exchange with: ")))
X     (if var
X     (let ((value (calc-var-value var)))
X       (or value
X           (error "No such variable: \"%s\"" (calc-var-name var)))
X       (if (eq (car-safe value) 'special-const)
X           (error "%s is a special constant" var))
X       (setq top (or calc-given-value (calc-top 1)))
X       (calc-store-value var top nil)
X       (calc-pop-push-record calc-given-value-flag
X                 (concat "<>" (calc-var-name var)) value)))))
)
X
(defun calc-unstore (&optional var)
X  (interactive)
X  (calc-wrapper
X   (or var (setq var (calc-read-var-name "Unstore: ")))
X   (if var
X       (progn
X     (and (memq var '(var-e var-i var-pi var-phi var-gamma))
X          (eq (car-safe (calc-var-value var)) 'special-const)
X          (message "(Note: Built-in definition of %s has been lost)" var))
X     (if (and (boundp var) (symbol-value var))
X         (message "Unstored variable \"%s\"" (calc-var-name var))
X       (message "Variable \"%s\" remains unstored" (calc-var-name var)))
X     (makunbound var)
X     (calc-refresh-evaltos var))))
)
X
(defun calc-let (&optional var)
X  (interactive)
X  (calc-wrapper
X   (let* ((calc-given-value nil)
X      (calc-given-value-flag 1)
X      thing value)
X     (or var (setq var (calc-read-var-name "Let variable: ")))
X     (if calc-given-value
X     (setq value calc-given-value
X           thing (calc-top 1))
X       (setq value (calc-top 1)
X         thing (calc-top 2)))
X     (setq var (if var
X           (list (cons var value))
X         (calc-is-assignments value)))
X     (if var
X     (calc-pop-push-record
X      (1+ calc-given-value-flag)
X      (concat "=" (calc-var-name (car (car var))))
X      (let ((saved-val (mapcar (function
X                    (lambda (v)
X                      (and (boundp (car v))
X                       (symbol-value (car v)))))
X                   var)))
X        (unwind-protect
X        (let ((vv var))
X          (while vv
X            (set (car (car vv)) (calc-normalize (cdr (car vv))))
X            (calc-refresh-evaltos (car (car vv)))
X            (setq vv (cdr vv)))
X          (math-evaluate-expr thing))
X          (while saved-val
X        (if (car saved-val)
X            (set (car (car var)) (car saved-val))
X          (makunbound (car (car var))))
X        (setq saved-val (cdr saved-val)
X              var (cdr var)))
X          (calc-handle-whys)))))))
)
X
(defun calc-is-assignments (value)
X  (if (memq (car-safe value) '(calcFunc-eq calcFunc-assign))
X      (and (eq (car-safe (nth 1 value)) 'var)
X       (list (cons (nth 2 (nth 1 value)) (nth 2 value))))
X    (if (eq (car-safe value) 'vec)
X    (let ((vv nil))
X      (while (and (setq value (cdr value))
X              (memq (car-safe (car value))
X                '(calcFunc-eq calcFunc-assign))
X              (eq (car-safe (nth 1 (car value))) 'var))
X        (setq vv (cons (cons (nth 2 (nth 1 (car value)))
X                 (nth 2 (car value)))
X               vv)))
X      (and (not value)
X           vv))))
)
X
(defun calc-recall (&optional var)
X  (interactive)
X  (calc-wrapper
X   (or var (setq var (calc-read-var-name "Recall: ")))
X   (if var
X       (let ((value (calc-var-value var)))
X     (or value
X         (error "No such variable: \"%s\"" (calc-var-name var)))
X     (if (stringp value)
X         (setq value (math-read-expr value)))
X     (if (eq (car-safe value) 'error)
X         (error "Bad format in variable contents: %s" (nth 2 value)))
X     (setq value (calc-normalize value))
X     (calc-record value (concat "<" (calc-var-name var)))
X     (calc-push value))))
)
X
(defun calc-store-quick ()
X  (interactive)
X  (calc-store (intern (format "var-q%c" last-command-char)))
)
X
(defun calc-store-into-quick ()
X  (interactive)
X  (calc-store-into (intern (format "var-q%c" last-command-char)))
)
X
(defun calc-recall-quick ()
X  (interactive)
X  (calc-recall (intern (format "var-q%c" last-command-char)))
)
X
(defun calc-copy-variable (&optional var1 var2)
X  (interactive)
X  (calc-wrapper
X   (or var1 (setq var1 (calc-read-var-name "Copy variable: ")))
X   (if var1
X       (let ((value (calc-var-value var1)))
X     (or value
X         (error "No such variable: \"%s\"" (calc-var-name var)))
X     (or var2 (setq var2 (calc-read-var-name
X                  (format "Copy variable: %s, to: " var1))))
X     (if var2
X         (calc-store-value var2 value "")))))
)
X
(defun calc-edit-variable (&optional var)
X  (interactive)
X  (calc-wrapper
X   (or var (setq var (calc-read-var-name
X              (if calc-last-edited-variable
X              (format "Edit: (default %s) "
X                  (calc-var-name calc-last-edited-variable))
X            "Edit: "))))
X   (or var (setq var calc-last-edited-variable))
X   (if var
X       (let* ((value (calc-var-value var)))
X     (if (eq (car-safe value) 'special-const)
X         (error "%s is a special constant" var))
X     (setq calc-last-edited-variable var)
X     (calc-edit-mode (list 'calc-finish-stack-edit (list 'quote var))
X             t
X             (concat "Editing " (calc-var-name var)))
X     (and value
X          (insert (math-format-nice-expr value (screen-width)) "\n")))))
X  (calc-show-edit-buffer)
)
(setq calc-last-edited-variable nil)
X
(defun calc-edit-Decls ()
X  (interactive)
X  (calc-edit-variable 'var-Decls)
)
X
(defun calc-edit-EvalRules ()
X  (interactive)
X  (calc-edit-variable 'var-EvalRules)
)
X
(defun calc-edit-FitRules ()
X  (interactive)
X  (calc-edit-variable 'var-FitRules)
)
X
(defun calc-edit-GenCount ()
X  (interactive)
X  (calc-edit-variable 'var-GenCount)
)
X
(defun calc-edit-LineStyles ()
X  (interactive)
X  (calc-edit-variable 'var-LineStyles)
)
X
(defun calc-edit-PointStyles ()
X  (interactive)
X  (calc-edit-variable 'var-PointStyles)
)
X
(defun calc-edit-PlotRejects ()
X  (interactive)
X  (calc-edit-variable 'var-PlotRejects)
)
X
(defun calc-edit-AlgSimpRules ()
X  (interactive)
X  (calc-edit-variable 'var-AlgSimpRules)
)
X
(defun calc-edit-TimeZone ()
X  (interactive)
X  (calc-edit-variable 'var-TimeZone)
)
X
(defun calc-edit-UnitSimpRules ()
X  (interactive)
X  (calc-edit-variable 'var-UnitSimpRules)
)
X
(defun calc-edit-ExtSimpRules ()
X  (interactive)
X  (calc-edit-variable 'var-ExtSimpRules)
)
X
(defun calc-declare-variable (&optional var)
X  (interactive)
X  (calc-wrapper
X   (or var (setq var (calc-read-var-name "Declare: " 0)))
X   (or var (setq var 'var-All))
X   (let* (dp decl def row rp)
X     (or (and (calc-var-value 'var-Decls)
X          (eq (car-safe var-Decls) 'vec))
X     (setq var-Decls (list 'vec)))
X     (setq dp var-Decls)
X     (while (and (setq dp (cdr dp))
X         (or (not (eq (car-safe (car dp)) 'vec))
X             (/= (length (car dp)) 3)
X             (progn
X               (setq row (nth 1 (car dp))
X                 rp row)
X               (if (eq (car-safe row) 'vec)
X               (progn
X                 (while
X                 (and (setq rp (cdr rp))
X                      (or (not (eq (car-safe (car rp)) 'var))
X                      (not (eq (nth 2 (car rp)) var)))))
X                 (setq rp (car rp)))
X             (if (or (not (eq (car-safe row) 'var))
X                 (not (eq (nth 2 row) var)))
X                 (setq rp nil)))
X               (not rp)))))
X     (setq unread-command-char ?\C-a
X       decl (read-string (format "Declare: %s  to be: " var)
X                 (and rp
X                  (math-format-flat-expr (nth 2 (car dp)) 0))))
X     (setq decl (and (string-match "[^ \t]" decl)
X             (math-read-exprs decl)))
X     (if (eq (car-safe decl) 'error)
X     (error "Bad format in declaration: %s" (nth 2 decl)))
X     (if (cdr decl)
X     (setq decl (cons 'vec decl))
X       (setq decl (car decl)))
X     (and (eq (car-safe decl) 'vec)
X      (= (length decl) 2)
X      (setq decl (nth 1 decl)))
X     (calc-record (append '(vec) (list (math-build-var-name var))
X              (and decl (list decl)))
X          "decl")
X     (setq var-Decls (copy-sequence var-Decls))
X     (if (eq (car-safe row) 'vec)
X     (progn
X       (setcdr row (delq rp (cdr row)))
X       (or (cdr row)
X           (setq var-Decls (delq (car dp) var-Decls))))
X       (setq var-Decls (delq (car dp) var-Decls)))
X     (if decl
X     (progn
X       (setq dp (and (not (eq var 'var-All)) var-Decls))
X       (while (and (setq dp (cdr dp))
X               (or (not (eq (car-safe (car dp)) 'vec))
X               (/= (length (car dp)) 3)
X               (not (equal (nth 2 (car dp)) decl)))))
X       (if dp
X           (setcar (cdr (car dp))
X               (append (if (eq (car-safe (nth 1 (car dp))) 'vec)
X                   (nth 1 (car dp))
X                 (list 'vec (nth 1 (car dp))))
X                   (list (math-build-var-name var))))
X         (setq var-Decls (append var-Decls
X                     (list (list 'vec
X                         (math-build-var-name var)
X                         decl)))))))
X     (calc-refresh-evaltos 'var-Decls)))
)
X
(defun calc-permanent-variable (&optional var)
X  (interactive)
X  (calc-wrapper
X   (or var (setq var (calc-read-var-name "Save variable (default=all): ")))
X   (let (pos)
X     (and var (or (and (boundp var) (symbol-value var))
X          (error "No such variable")))
X     (set-buffer (find-file-noselect (substitute-in-file-name
X                      calc-settings-file)))
X     (if var
X     (calc-insert-permanent-variable var)
X       (mapatoms (function
X          (lambda (x)
X            (and (string-match "\\`var-" (symbol-name x))
X             (not (memq x calc-dont-insert-variables))
X             (calc-var-value x)
X             (not (eq (car-safe (symbol-value x)) 'special-const))
X             (calc-insert-permanent-variable x))))))
X     (save-buffer)))
)
(defvar calc-dont-insert-variables '(var-FitRules var-FactorRules
X                     var-CommuteRules var-JumpRules
X                     var-DistribRules var-MergeRules
X                     var-NegateRules var-InvertRules
X                     var-IntegAfterRules
X                     var-TimeZone var-PlotRejects
X                     var-PlotData1 var-PlotData2
X                     var-PlotData3 var-PlotData4
X                     var-PlotData5 var-PlotData6
X                     var-DUMMY
))
X
(defun calc-insert-permanent-variable (var)
X  (goto-char (point-min))
X  (if (search-forward (concat "(setq " (symbol-name var) " '") nil t)
X      (progn
X    (setq pos (point-marker))
X    (forward-line -1)
X    (if (looking-at ";;; Variable .* stored by Calc on ")
X        (progn
X          (delete-region (match-end 0) (progn (end-of-line) (point)))
X          (insert (current-time-string))))
X    (goto-char (- pos 8 (length (symbol-name var))))
X    (forward-sexp 1)
X    (backward-char 1)
X    (delete-region pos (point)))
X    (goto-char (point-max))
X    (insert "\n;;; Variable \""
X        (symbol-name var)
X        "\" stored by Calc on "
X        (current-time-string)
X        "\n(setq "
X        (symbol-name var)
X        " ')\n")
X    (backward-char 2))
X  (insert (prin1-to-string (calc-var-value var)))
X  (forward-line 1)
)
X
(defun calc-insert-variables (buf)
X  (interactive "bBuffer in which to save variable values: ")
X  (save-excursion
X    (set-buffer buf)
X    (mapatoms (function
X           (lambda (x)
X         (and (string-match "\\`var-" (symbol-name x))
X              (not (memq x calc-dont-insert-variables))
X              (calc-var-value x)
X              (not (eq (car-safe (symbol-value x)) 'special-const))
X              (or (not (eq x 'var-Decls))
X              (not (equal var-Decls '(vec))))
X              (insert "(setq "
X                  (symbol-name x)
X                  " "
X                  (prin1-to-string
X                   (let ((calc-language
X                      (if (memq calc-language '(nil big))
X                      'flat
X                    calc-language)))
X                 (math-format-value (symbol-value x) 100000)))
X                  ")\n"))))))
)
X
(defun calc-assign (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op ":=" 'calcFunc-assign arg))
)
X
(defun calc-evalto (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "=>" 'calcFunc-evalto arg))
)
X
(defun calc-subscript (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "sub" 'calcFunc-subscr arg))
)
X
SHAR_EOF
chmod 0644 calc-store.el ||
echo 'restore of calc-store.el failed'
Wc_c="`wc -c < 'calc-store.el'`"
test 18912 -eq "$Wc_c" ||
    echo 'calc-store.el: original size 18912, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-stuff.el ==============
if test -f 'calc-stuff.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-stuff.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-stuff.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-stuff.el' &&
;; Calculator for GNU Emacs, part II [calc-stuff.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-stuff () nil)
X
X
(defun calc-num-prefix (n)
X  "Use the number at the top of stack as the numeric prefix for the next command.
With a prefix, push that prefix as a number onto the stack."
X  (interactive "P")
X  (calc-wrapper
X   (if n
X       (calc-enter-result 0 "" (prefix-numeric-value n))
X     (let ((num (calc-top 1)))
X       (if (math-messy-integerp num)
X       (setq num (math-trunc num)))
X       (or (integerp num)
X       (error "Argument must be a small integer"))
X       (calc-pop-stack 1)
X       (setq prefix-arg num)
X       (message "%d-" num))))    ; a (lame) simulation of the real thing...
)
X
X
(defun calc-more-recursion-depth (n)
X  (interactive "P")
X  (calc-wrapper
X   (if (calc-is-inverse)
X       (calc-less-recursion-depth n)
X     (let ((n (if n (prefix-numeric-value n) 2)))
X       (if (> n 1)
X       (setq max-specpdl-size (* max-specpdl-size n)
X         max-lisp-eval-depth (* max-lisp-eval-depth n))))
X     (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)))
)
X
(defun calc-less-recursion-depth (n)
X  (interactive "P")
X  (let ((n (if n (prefix-numeric-value n) 2)))
X    (if (> n 1)
X    (setq max-specpdl-size
X          (max (/ max-specpdl-size n) 600)
X          max-lisp-eval-depth
X          (max (/ max-lisp-eval-depth n) 200))))
X  (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)
)
X
X
(defun calc-explain-why (why &optional more)
X  (if (eq (car why) '*)
X      (setq why (cdr why)))
X  (let* ((pred (car why))
X     (arg (nth 1 why))
X     (msg (cond ((not pred) "Wrong type of argument")
X            ((stringp pred) pred)
X            ((eq pred 'integerp) "Integer expected")
X            ((eq pred 'natnump)
X             (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
X             "Integer expected"
X               "Nonnegative integer expected"))
X            ((eq pred 'posintp)
X             (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
X             "Integer expected"
X               "Positive integer expected"))
X            ((eq pred 'fixnump)
X             (if (and arg (Math-integerp arg))
X             "Small integer expected"
X               "Integer expected"))
X            ((eq pred 'fixnatnump)
X             (if (and arg (Math-natnump arg))
X             "Small integer expected"
X               (if (and arg (Math-objvecp arg)
X                (not (Math-integerp arg)))
X               "Integer expected"
X             "Nonnegative integer expected")))
X            ((eq pred 'fixposintp)
X             (if (and arg (Math-integerp arg) (Math-posp arg))
X             "Small integer expected"
X               (if (and arg (Math-objvecp arg)
X                (not (Math-integerp arg)))
X               "Integer expected"
X             "Positive integer expected")))
X            ((eq pred 'posp) "Positive number expected")
X            ((eq pred 'negp) "Negative number expected")
X            ((eq pred 'nonzerop) "Nonzero number expected")
X            ((eq pred 'realp) "Real number expected")
X            ((eq pred 'anglep) "Real number expected")
X            ((eq pred 'hmsp) "HMS form expected")
X            ((eq pred 'datep)
X             (if (and arg (Math-objectp arg))
X             "Real number or date form expected"
X               "Date form expected"))
X            ((eq pred 'numberp) "Number expected")
X            ((eq pred 'scalarp) "Number expected")
X            ((eq pred 'vectorp) "Vector or matrix expected")
X            ((eq pred 'numvecp) "Number or vector expected")
X            ((eq pred 'matrixp) "Matrix expected")
X            ((eq pred 'square-matrixp)
X             (if (and arg (math-matrixp arg))
X             "Square matrix expected"
X               "Matrix expected"))
X            ((eq pred 'objectp) "Number expected")
X            ((eq pred 'constp) "Constant expected")
X            ((eq pred 'range) "Argument out of range")
X            (t (format "%s expected" pred))))
X     (punc ": ")
X     (calc-can-abbrev-vectors t))
X    (while (setq why (cdr why))
X      (and (car why)
X       (setq msg (concat msg punc (if (stringp (car why))
X                      (car why)
X                    (math-format-flat-expr (car why) 0)))
X         punc ", ")))
X    (message "%s%s" msg (if more "  [w=more]" "")))
)
X
(defun calc-why ()
X  (interactive)
X  (if (not (eq this-command last-command))
X      (if (eq last-command calc-last-why-command)
X      (setq calc-which-why (cdr calc-why))
X    (setq calc-which-why calc-why)))
X  (if calc-which-why
X      (progn
X    (calc-explain-why (car calc-which-why) (cdr calc-which-why))
X    (setq calc-which-why (cdr calc-which-why)))
X    (if calc-why
X    (progn
X      (message "(No further explanations available)")
X      (setq calc-which-why calc-why))
X      (message "No explanations available")))
)
(setq calc-which-why nil)
(setq calc-last-why-command nil)
X
X
(defun calc-version ()
X  (interactive)
X  (message "Calc %s, installed %s" calc-version calc-installed-date))
X
X
(defun calc-flush-caches ()
X  (interactive)
X  (calc-wrapper
X   (setq math-lud-cache nil
X     math-log2-cache nil
X     math-radix-digits-cache nil
X     math-radix-float-cache-tag nil
X     math-random-cache nil
X     math-max-digits-cache nil
X     math-checked-rewrites nil
X     math-integral-cache nil
X     math-units-table nil
X     math-decls-cache-tag nil
X     math-eval-rules-cache-tag t
X     math-graph-var-cache nil
X     math-graph-data-cache nil
X     math-format-date-cache nil)
X   (mapcar (function (lambda (x) (set x -100))) math-cache-list)
X   (message "All internal calculator caches have been reset."))
)
X
X
;;; Conversions.
X
(defun calc-clean (n)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-with-default-simplification
X    (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean)))
X      (calc-enter-result 1 "cln"
X             (if n
X                 (let ((n (prefix-numeric-value n)))
X                   (list func
X                     (calc-top-n 1)
X                     (if (<= n 0)
X                     (+ n calc-internal-prec)
X                       n)))
X               (list func (calc-top-n 1)))))))
)
X
(defun calc-clean-num (num)
X  (interactive "P")
X  (calc-clean (- (if num
X             (prefix-numeric-value num)
X           (if (and (>= last-command-char ?0)
X                (<= last-command-char ?9))
X               (- last-command-char ?0)
X             (error "Number required")))))
)
X
X
(defun calcFunc-clean (a &optional prec)   ; [X X S] [Public]
X  (if prec
X      (cond ((Math-messy-integerp prec)
X         (calcFunc-clean a (math-trunc prec)))
X        ((or (not (integerp prec))
X         (< prec 3))
X         (calc-record-why "*Precision must be an integer 3 or above")
X         (list 'calcFunc-clean a prec))
X        ((not (Math-objvecp a))
X         (list 'calcFunc-clean a prec))
X        (t (let ((calc-internal-prec prec)
X             (math-chopping-small t))
X         (calcFunc-clean (math-normalize a)))))
X    (cond ((eq (car-safe a) 'polar)
X       (let ((theta (math-mod (nth 2 a)
X                  (if (eq calc-angle-mode 'rad)
X                      (math-two-pi)
X                    360))))
X         (math-neg
X          (math-neg
X           (math-normalize
X        (list 'polar
X              (calcFunc-clean (nth 1 a))
X              (calcFunc-clean theta)))))))
X      ((memq (car-safe a) '(vec date hms))
X       (cons (car a) (mapcar 'calcFunc-clean (cdr a))))
X      ((memq (car-safe a) '(cplx mod sdev intv))
X       (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a)))))
X      ((eq (car-safe a) 'float)
X       (if math-chopping-small
X           (if (or (> (nth 2 a) (- calc-internal-prec))
X               (Math-lessp (- calc-internal-prec) (calcFunc-xpon a)))
X           (if (and (math-num-integerp a)
X                (math-lessp (calcFunc-xpon a) calc-internal-prec))
X               (math-trunc a)
X             a)
X         0)
X         a))
X      ((Math-objectp a) a)
X      ((math-infinitep a) a)
X      (t (list 'calcFunc-clean a))))
)
(setq math-chopping-small nil)
X
(defun calcFunc-pclean (a &optional prec)
X  (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
X               a)
)
X
(defun calcFunc-pfloat (a)
X  (math-map-over-constants 'math-float a)
)
X
(defun calcFunc-pfrac (a &optional tol)
X  (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
X               a)
)
X
(defun math-map-over-constants (func expr)
X  (math-map-over-constants-rec expr)
)
X
(defun math-map-over-constants-rec (expr)
X  (cond ((or (Math-primp expr)
X         (memq (car expr) '(intv sdev)))
X     (or (and (Math-objectp expr)
X          (funcall func expr))
X         expr))
X    ((and (memq (car expr) '(^ calcFunc-subscr))
X          (eq func 'math-float)
X          (= (length expr) 3)
X          (Math-integerp (nth 2 expr)))
X     (list (car expr)
X           (math-map-over-constants-rec (nth 1 expr))
X           (nth 2 expr)))
X    (t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr)))))
)
X
X
X
X
SHAR_EOF
chmod 0644 calc-stuff.el ||
echo 'restore of calc-stuff.el failed'
Wc_c="`wc -c < 'calc-stuff.el'`"
test 9150 -eq "$Wc_c" ||
    echo 'calc-stuff.el: original size 9150, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-trail.el ==============
if test -f 'calc-trail.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-trail.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-trail.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-trail.el' &&
;; Calculator for GNU Emacs, part II [calc-trail.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-trail () nil)
X
X
;;; Trail commands.
X
(defun calc-trail-in ()
X  (interactive)
X  (let ((win (get-buffer-window (calc-trail-display t))))
X    (and win (select-window win)))
)
X
(defun calc-trail-out ()
X  (interactive)
X  (calc-select-buffer)
X  (let ((win (get-buffer-window (current-buffer))))
X    (if win
X    (progn
X      (select-window win)
X      (calc-align-stack-window))
X      (calc)))
)
X
(defun calc-trail-next (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (forward-line n)
X   (calc-trail-here))
)
X
(defun calc-trail-previous (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (forward-line (- n))
X   (calc-trail-here))
)
X
(defun calc-trail-first (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (goto-char (point-min))
X   (forward-line n)
X   (calc-trail-here))
)
X
(defun calc-trail-last (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (goto-char (point-max))
X   (forward-line (- n))
X   (calc-trail-here))
)
X
(defun calc-trail-scroll-left (n)
X  (interactive "P")
X  (let ((curwin (selected-window)))
X    (calc-with-trail-buffer
X     (unwind-protect
X     (progn
X       (select-window (get-buffer-window (current-buffer)))
X       (calc-scroll-left n))
X       (select-window curwin))))
)
X
(defun calc-trail-scroll-right (n)
X  (interactive "P")
X  (let ((curwin (selected-window)))
X    (calc-with-trail-buffer
X     (unwind-protect
X     (progn
X       (select-window (get-buffer-window (current-buffer)))
X       (calc-scroll-right n))
X       (select-window curwin))))
)
X
(defun calc-trail-forward (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (forward-line (* n (1- (window-height))))
X   (calc-trail-here))
)
X
(defun calc-trail-backward (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (forward-line (- (* n (1- (window-height)))))
X   (calc-trail-here))
)
X
(defun calc-trail-isearch-forward ()
X  (interactive)
X  (calc-with-trail-buffer
X   (save-window-excursion
X     (select-window (get-buffer-window (current-buffer)))
X     (let ((search-exit-char ?\r))
X       (isearch t nil)))
X   (calc-trail-here))
)
X
(defun calc-trail-isearch-backward ()
X  (interactive)
X  (calc-with-trail-buffer
X   (save-window-excursion
X     (select-window (get-buffer-window (current-buffer)))
X     (let ((search-exit-char ?\r))
X       (isearch nil nil)))
X   (calc-trail-here))
)
X
(defun calc-trail-yank (arg)
X  (interactive "P")
X  (calc-wrapper
X   (or arg (calc-set-command-flag 'hold-trail))
X   (calc-enter-result 0 "yank"
X              (calc-with-trail-buffer
X               (if arg
X               (forward-line (- (prefix-numeric-value arg))))
X               (if (or (looking-at "Emacs Calc")
X                   (looking-at "----")
X                   (looking-at " ? ? ?[^ \n]* *$")
X                   (looking-at "..?.?$"))
X               (error "Can't yank that line"))
X               (if (looking-at ".*, \\.\\.\\., ")
X               (error "Can't yank (vector was abbreviated)"))
X               (forward-char 4)
X               (search-forward " ")
X               (let* ((next (save-excursion (forward-line 1) (point)))
X                  (str (buffer-substring (point) (1- next)))
X                  (val (save-excursion
X                     (set-buffer save-buf)
X                     (math-read-plain-expr str))))
X             (if (eq (car-safe val) 'error)
X                 (error "Can't yank that line: %s" (nth 2 val))
X               val)))))
)
X
(defun calc-trail-marker (str)
X  (interactive "sText to insert in trail: ")
X  (calc-with-trail-buffer
X   (forward-line 1)
X   (let ((buffer-read-only nil))
X     (insert "---- " str "\n"))
X   (forward-line -1)
X   (calc-trail-here))
)
X
(defun calc-trail-kill (n)
X  (interactive "p")
X  (calc-with-trail-buffer
X   (let ((buffer-read-only nil))
X     (save-restriction
X       (narrow-to-region   ; don't delete "Emacs Trail" header
X    (save-excursion
X      (goto-char (point-min))
X      (forward-line 1)
X      (point))
X    (point-max))
X       (kill-line n)))
X   (calc-trail-here))
)
X
X
X
SHAR_EOF
chmod 0644 calc-trail.el ||
echo 'restore of calc-trail.el failed'
Wc_c="`wc -c < 'calc-trail.el'`"
test 4845 -eq "$Wc_c" ||
    echo 'calc-trail.el: original size 4845, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-undo.el ==============
if test -f 'calc-undo.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-undo.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-undo.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-undo.el' &&
;; Calculator for GNU Emacs, part II [calc-undo.el]
SHAR_EOF
true || echo 'restore of calc-undo.el failed'
fi
echo 'End of  part 27'
echo 'File calc-undo.el is continued in part 28'
echo 28 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].