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

Text File | 1991-10-31 | 55.2 KB | 1,971 lines

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

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 76
Archive-name: gnucalc/part28
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-undo.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 28; 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-undo.el'
else
echo 'x - continuing file calc-undo.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-undo.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-undo () nil)
X
X
;;; Undo.
X
(defun calc-undo (n)
X  (interactive "p")
X  (and calc-executing-macro
X       (error "Use C-x e, not X, to run a keyboard macro that uses Undo."))
X  (if (<= n 0)
X      (if (< n 0)
X      (calc-redo (- n))
X    (calc-last-args 1))
X    (calc-wrapper
X     (if (null (nthcdr (1- n) calc-undo-list))
X     (error "No further undo information available"))
X     (setq calc-undo-list
X       (prog1
X           (nthcdr n calc-undo-list)
X         (let ((saved-stack-top calc-stack-top))
X           (let ((calc-stack-top 0))
X         (calc-handle-undos calc-undo-list n))
X           (setq calc-stack-top saved-stack-top))))
X     (message "Undo!")))
)
X
(defun calc-handle-undos (cl n)
X  (if (> n 0)
X      (progn
X    (let ((old-redo calc-redo-list))
X      (setq calc-undo-list nil)
X      (calc-handle-undo (car cl))
X      (setq calc-redo-list (append calc-undo-list old-redo)))
X    (calc-handle-undos (cdr cl) (1- n))))
)
X
(defun calc-handle-undo (list)
X  (and list
X       (let ((action (car list)))
X     (cond
X      ((eq (car action) 'push)
X       (calc-pop-stack 1 (nth 1 action) t))
X      ((eq (car action) 'pop)
X       (calc-push-list (nth 2 action) (nth 1 action)))
X      ((eq (car action) 'set)
X       (calc-record-undo (list 'set (nth 1 action)
X                   (symbol-value (nth 1 action))))
X       (set (nth 1 action) (nth 2 action)))
X      ((eq (car action) 'store)
X       (let ((v (intern (nth 1 action))))
X         (calc-record-undo (list 'store (nth 1 action)
X                     (and (boundp v) (symbol-value v))))
X         (if (y-or-n-p (format "Un-store variable %s? " (nth 1 action)))
X         (progn
X           (if (nth 2 action)
X               (set v (nth 2 action))
X             (makunbound v))
X           (calc-refresh-evaltos v)))))
X      ((eq (car action) 'eval)
X       (calc-record-undo (append (list 'eval (nth 2 action) (nth 1 action))
X                     (cdr (cdr (cdr action)))))
X       (apply (nth 1 action) (cdr (cdr (cdr action))))))
X     (calc-handle-undo (cdr list))))
)
X
(defun calc-redo (n)
X  (interactive "p")
X  (and calc-executing-macro
X       (error "Use C-x e, not X, to run a keyboard macro that uses Redo."))
X  (if (<= n 0)
X      (calc-undo (- n))
X    (calc-wrapper
X     (if (null (nthcdr (1- n) calc-redo-list))
X     (error "Unable to redo"))
X     (setq calc-redo-list
X       (prog1
X           (nthcdr n calc-redo-list)
X         (let ((saved-stack-top calc-stack-top))
X           (let ((calc-stack-top 0))
X         (calc-handle-redos calc-redo-list n))
X           (setq calc-stack-top saved-stack-top))))
X     (message "Redo!")))
)
X
(defun calc-handle-redos (cl n)
X  (if (> n 0)
X      (progn
X    (let ((old-undo calc-undo-list))
X      (setq calc-undo-list nil)
X      (calc-handle-undo (car cl))
X      (setq calc-undo-list (append calc-undo-list old-undo)))
X    (calc-handle-redos (cdr cl) (1- n))))
)
X
(defun calc-last-args (n)
X  (interactive "p")
X  (and calc-executing-macro
X       (error "Use C-x e, not X, to run a keyboard macro that uses last-args."))
X  (calc-wrapper
X   (let ((urec (calc-find-last-x calc-undo-list n)))
X     (if urec
X     (calc-handle-last-x urec)
X       (error "Not enough undo information available"))))
)
X
(defun calc-handle-last-x (list)
X  (and list
X       (let ((action (car list)))
X     (if (eq (car action) 'pop)
X         (calc-pop-push-record-list 0 "larg"
X                    (delq 'top-of-stack (nth 2 action))))
X     (calc-handle-last-x (cdr list))))
)
X
(defun calc-find-last-x (ul n)
X  (and ul
X       (if (calc-undo-does-pushes (car ul))
X       (if (<= n 1)
X           (car ul)
X         (calc-find-last-x (cdr ul) (1- n)))
X     (calc-find-last-x (cdr ul) n)))
)
X
(defun calc-undo-does-pushes (list)
X  (and list
X       (or (eq (car (car list)) 'pop)
X       (calc-undo-does-pushes (cdr list))))
)
X
X
X
SHAR_EOF
echo 'File calc-undo.el is complete' &&
chmod 0644 calc-undo.el ||
echo 'restore of calc-undo.el failed'
Wc_c="`wc -c < 'calc-undo.el'`"
test 4666 -eq "$Wc_c" ||
    echo 'calc-undo.el: original size 4666, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-vec.el ==============
if test -f 'calc-vec.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-vec.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-vec.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-vec.el' &&
;; Calculator for GNU Emacs, part II [calc-vec.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-vec () nil)
X
X
(defun calc-display-strings (n)
X  (interactive "P")
X  (calc-wrapper
X   (message (if (calc-change-mode 'calc-display-strings n t t)
X        "Displaying vectors of integers as quoted strings."
X          "Displaying vectors of integers normally.")))
)
X
X
(defun calc-pack (n)
X  (interactive "P")
X  (calc-wrapper
X   (let* ((nn (if n 1 2))
X      (mode (if n (prefix-numeric-value n) (calc-top-n 1)))
X      (mode (if (and (Math-vectorp mode) (cdr mode)) (cdr mode)
X          (if (integerp mode) mode
X            (error "Packing mode must be an integer or vector of integers"))))
X      (num (calc-pack-size mode))
X      (items (calc-top-list num nn)))
X     (calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items))))
)
X
(defun calc-pack-size (mode)
X  (cond ((consp mode)
X     (let ((size 1))
X       (while mode
X         (or (integerp (car mode)) (error "Vector of integers expected"))
X         (setq size (* size (calc-pack-size (car mode)))
X           mode (cdr mode)))
X       (if (= size 0)
X           (error "Zero dimensions not allowed")
X         size)))
X    ((>= mode 0) mode)
X    (t (or (cdr (assq mode '((-3 . 3) (-13 . 1) (-14 . 3) (-15 . 6))))
X           2)))
)
X
(defun calc-pack-items (mode items)
X  (cond ((consp mode)
X     (if (cdr mode)
X         (let* ((size (calc-pack-size (cdr mode)))
X            (len (length items))
X            (new nil)
X            p row)
X           (while (> len 0)
X         (setq p (nthcdr (1- size) items)
X               row items
X               items (cdr p)
X               len (- len size))
X         (setcdr p nil)
X         (setq new (cons (calc-pack-items (cdr mode) row) new)))
X           (calc-pack-items (car mode) (nreverse new)))
X       (calc-pack-items (car mode) items)))
X    ((>= mode 0)
X     (cons 'vec items))
X    ((= mode -3)
X     (if (and (math-objvecp (car items))
X          (math-objvecp (nth 1 items))
X          (math-objvecp (nth 2 items)))
X         (if (and (math-num-integerp (car items))
X              (math-num-integerp (nth 1 items)))
X         (if (math-realp (nth 2 items))
X             (cons 'hms items)
X           (error "Seconds must be real"))
X           (error "Hours and minutes must be integers"))
X       (math-normalize (list '+
X                 (list '+
X                       (if (eq calc-angle-mode 'rad)
X                       (list '* (car items)
X                         '(hms 1 0 0))
X                     (car items))
X                       (list '* (nth 1 items) '(hms 0 1 0)))
X                 (list '* (nth 2 items) '(hms 0 0 1))))))
X    ((= mode -13)
X     (if (math-realp (car items))
X         (cons 'date items)
X       (if (eq (car-safe (car items)) 'date)
X           (car items)
X         (if (math-objvecp (car items))
X         (error "Date value must be real")
X           (cons 'calcFunc-date items)))))
X    ((memq mode '(-14 -15))
X     (let ((p items))
X       (while (and p (math-objvecp (car p)))
X         (or (math-integerp (car p))
X         (error "Components must be integers"))
X         (setq p (cdr p)))
X       (if p
X           (cons 'calcFunc-date items)
X         (list 'date (math-dt-to-date items)))))
X    ((or (eq (car-safe (car items)) 'vec)
X         (eq (car-safe (nth 1 items)) 'vec))
X     (let* ((x (car items))
X        (vx (eq (car-safe x) 'vec))
X        (y (nth 1 items))
X        (vy (eq (car-safe y) 'vec))
X        (z nil)
X        (n (1- (length (if vx x y)))))
X       (and vx vy
X        (/= n (1- (length y)))
X        (error "Vectors must be the same length"))
X       (while (>= (setq n (1- n)) 0)
X         (setq z (cons (calc-pack-items
X                mode
X                (list (if vx (car (setq x (cdr x))) x)
X                  (if vy (car (setq y (cdr y))) y)))
X               z)))
X       (cons 'vec (nreverse z))))
X    ((= mode -1)
X     (if (and (math-realp (car items)) (math-realp (nth 1 items)))
X         (cons 'cplx items)
X       (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
X           (error "Components must be real"))
X       (math-normalize (list '+ (car items)
X                 (list '* (nth 1 items) '(cplx 0 1))))))
X    ((= mode -2)
X     (if (and (math-realp (car items)) (math-anglep (nth 1 items)))
X         (cons 'polar items)
X       (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
X           (error "Components must be real"))
X       (math-normalize (list '* (car items)
X                 (if (math-anglep (nth 1 items))
X                     (list 'polar 1 (nth 1 items))
X                   (list 'calcFunc-exp
X                     (list '*
X                           (math-to-radians-2
X                        (nth 1 items))
X                           (list 'polar
X                             1
X                             (math-quarter-circle
X                              nil)))))))))
X    ((= mode -4)
X     (let ((x (car items))
X           (sigma (nth 1 items)))
X       (if (or (math-scalarp x) (not (math-objvecp x)))
X           (if (or (math-anglep sigma) (not (math-objvecp sigma)))
X           (math-make-sdev x sigma)
X         (error "Error component must be real"))
X         (error "Mean component must be real or complex"))))
X    ((= mode -5)
X     (let ((a (car items))
X           (m (nth 1 items)))
X       (if (and (math-anglep a) (math-anglep m))
X           (if (math-posp m)
X           (math-make-mod a m)
X         (error "Modulus must be positive"))
X         (if (and (math-objectp a) (math-objectp m))
X         (error "Components must be real"))
X         (list 'calcFunc-makemod a m))))
X    ((memq mode '(-6 -7 -8 -9))
X     (let ((lo (car items))
X           (hi (nth 1 items)))
X       (if (and (or (math-anglep lo) (eq (car lo) 'date)
X            (not (math-objvecp lo)))
X            (or (math-anglep hi) (eq (car hi) 'date)
X            (not (math-objvecp hi))))
X           (math-make-intv (+ mode 9) lo hi)
X         (error "Components must be real"))))
X    ((eq mode -10)
X     (if (math-zerop (nth 1 items))
X         (error "Denominator must not be zero")
X       (if (and (math-integerp (car items)) (math-integerp (nth 1 items)))
X           (math-normalize (cons 'frac items))
X         (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
X         (error "Components must be integers"))
X         (cons 'calcFunc-fdiv items))))
X    ((memq mode '(-11 -12))
X     (if (and (math-realp (car items)) (math-integerp (nth 1 items)))
X         (calcFunc-scf (math-float (car items)) (nth 1 items))
X       (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
X           (error "Components must be integers"))
X       (math-normalize
X        (list 'calcFunc-scf
X          (list 'calcFunc-float (car items))
X          (nth 1 items)))))
X    (t
X     (error "Invalid packing mode: %d" mode)))
)
X
(defun calc-unpack (mode)
X  (interactive "P")
X  (calc-wrapper
X   (let ((calc-unpack-with-type t))
X     (calc-pop-push-record-list 1 "unpk" (calc-unpack-item
X                      (and mode
X                           (prefix-numeric-value mode))
X                      (calc-top)))))
)
X
(defun calc-unpack-type (item)
X  (cond ((eq (car-safe item) 'vec)
X     (1- (length item)))
X    ((eq (car-safe item) 'intv)
X     (- (nth 1 item) 9))
X    (t
X     (or (cdr (assq (car-safe item) '( (cplx . -1) (polar . -2)
X                       (hms . -3) (sdev . -4) (mod . -5)
X                       (frac . -10) (float . -11)
X                       (date . -13) )))
X         (error "Argument must be a composite object"))))
)
X
(defun calc-unpack-item (mode item)
X  (cond ((not mode)
X     (if (or (and (not (memq (car-safe item) '(frac float cplx polar vec
X                            hms date sdev mod
X                            intv)))
X              (math-objvecp item))
X         (eq (car-safe item) 'var))
X         (error "Argument must be a composite object or function call"))
X     (if (eq (car item) 'intv)
X         (cdr (cdr item))
X       (cdr item)))
X    ((> mode 0)
X     (let ((dims nil)
X           type new row)
X       (setq item (list item))
X       (while (> mode 0)
X         (setq type (calc-unpack-type (car item))
X           dims (cons type dims)
X           new (calc-unpack-item nil (car item)))
X         (while (setq item (cdr item))
X           (or (= (calc-unpack-type (car item)) type)
X           (error "Inconsistent types or dimensions in vector elements"))
X           (setq new (append new (calc-unpack-item nil (car item)))))
X         (setq item new
X           mode (1- mode)))
X       (if (cdr dims) (setq dims (list (cons 'vec (nreverse dims)))))
X       (cond ((eq calc-unpack-with-type 'pair)
X          (list (car dims) (cons 'vec item)))
X         (calc-unpack-with-type
X          (append item dims))
X         (t item))))
X    ((eq calc-unpack-with-type 'pair)
X     (let ((calc-unpack-with-type nil))
X       (list mode (cons 'vec (calc-unpack-item mode item)))))
X    ((= mode -3)
X     (if (eq (car-safe item) 'hms)
X         (cdr item)
X       (error "Argument must be an HMS form")))
X    ((= mode -13)
X     (if (eq (car-safe item) 'date)
X         (cdr item)
X       (error "Argument must be a date form")))
X    ((= mode -14)
X     (if (eq (car-safe item) 'date)
X         (math-date-to-dt (math-floor (nth 1 item)))
X       (error "Argument must be a date form")))
X    ((= mode -15)
X     (if (eq (car-safe item) 'date)
X         (append (math-date-to-dt (nth 1 item))
X             (and (not (math-integerp (nth 1 item)))
X              (list 0 0 0)))
X       (error "Argument must be a date form")))
X    ((eq (car-safe item) 'vec)
X     (let ((x nil)
X           (y nil)
X           res)
X       (while (setq item (cdr item))
X         (setq res (calc-unpack-item mode (car item))
X           x (cons (car res) x)
X           y (cons (nth 1 res) y)))
X       (list (cons 'vec (nreverse x))
X         (cons 'vec (nreverse y)))))
X    ((= mode -1)
X     (if (eq (car-safe item) 'cplx)
X         (cdr item)
X       (if (eq (car-safe item) 'polar)
X           (cdr (math-complex item))
X         (if (Math-realp item)
X         (list item 0)
X           (error "Argument must be a complex number")))))
X    ((= mode -2)
X     (if (or (memq (car-safe item) '(cplx polar))
X         (Math-realp item))
X         (cdr (math-polar item))
X       (error "Argument must be a complex number")))
X    ((= mode -4)
X     (if (eq (car-safe item) 'sdev)
X         (cdr item)
X       (list item 0)))
X    ((= mode -5)
X     (if (eq (car-safe item) 'mod)
X         (cdr item)
X       (error "Argument must be a modulo form")))
X    ((memq mode '(-6 -7 -8 -9))
X     (if (eq (car-safe item) 'intv)
X         (cdr (cdr item))
X       (list item item)))
X    ((= mode -10)
X     (if (eq (car-safe item) 'frac)
X         (cdr item)
X       (if (Math-integerp item)
X           (list item 1)
X         (error "Argument must be a rational number"))))
X    ((= mode -11)
X     (if (eq (car-safe item) 'float)
X         (list (nth 1 item) (math-normalize (nth 2 item)))
X       (error "Expected a floating-point number")))
X    ((= mode -12)
X     (if (eq (car-safe item) 'float)
X         (list (calcFunc-mant item) (calcFunc-xpon item))
X       (error "Expected a floating-point number")))
X    (t
X     (error "Invalid unpacking mode: %d" mode)))
)
(setq calc-unpack-with-type nil)
X
(defun calc-diag (n)
X  (interactive "P")
X  (calc-wrapper
X   (calc-enter-result 1 "diag" (if n
X                   (list 'calcFunc-diag (calc-top-n 1)
X                     (prefix-numeric-value n))
X                 (list 'calcFunc-diag (calc-top-n 1)))))
)
X
(defun calc-ident (n)
X  (interactive "NDimension of identity matrix = ")
X  (calc-wrapper
X   (calc-enter-result 0 "idn" (if (eq n 0)
X                  '(calcFunc-idn 1)
X                (list 'calcFunc-idn 1
X                      (prefix-numeric-value n)))))
)
X
(defun calc-index (n &optional stack)
X  (interactive "NSize of vector = \nP")
X  (calc-wrapper
X   (if (consp stack)
X       (calc-enter-result 3 "indx" (cons 'calcFunc-index (calc-top-list-n 3)))
X     (calc-enter-result 0 "indx" (list 'calcFunc-index
X                       (prefix-numeric-value n)))))
)
X
(defun calc-build-vector (n)
X  (interactive "NSize of vector = ")
X  (calc-wrapper
X   (calc-enter-result 1 "bldv" (list 'calcFunc-cvec
X                     (calc-top-n 1)
X                     (prefix-numeric-value n))))
)
X
(defun calc-cons (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-binary-op "rcns" 'calcFunc-rcons arg)
X     (calc-binary-op "cons" 'calcFunc-cons arg)))
)
X
X
(defun calc-head (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (calc-is-inverse)
X       (if (calc-is-hyperbolic)
X       (calc-unary-op "rtai" 'calcFunc-rtail arg)
X     (calc-unary-op "tail" 'calcFunc-tail arg))
X     (if (calc-is-hyperbolic)
X     (calc-unary-op "rhed" 'calcFunc-rhead arg)
X       (calc-unary-op "head" 'calcFunc-head arg))))
)
X
(defun calc-tail (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-head arg)
)
X
(defun calc-vlength (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-unary-op "dims" 'calcFunc-mdims arg)
X     (calc-unary-op "len" 'calcFunc-vlen arg)))
)
X
(defun calc-arrange-vector (n)
X  (interactive "NNumber of columns = ")
X  (calc-wrapper
X   (calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1)
X                     (prefix-numeric-value n))))
)
X
(defun calc-vector-find (arg)
X  (interactive "P")
X  (calc-wrapper
X   (let ((func (cons 'calcFunc-find (calc-top-list-n 2))))
X     (calc-enter-result
X      2 "find"
X      (if arg (append func (list (prefix-numeric-value arg))) func))))
)
X
(defun calc-subvector ()
X  (interactive)
X  (calc-wrapper
X   (if (calc-is-inverse)
X       (calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec
X                     (calc-top-list-n 3)))
X     (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3)))))
)
X
(defun calc-reverse-vector (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "rev" 'calcFunc-rev arg))
)
X
(defun calc-mask-vector (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "vmsk" 'calcFunc-vmask arg))
)
X
(defun calc-expand-vector (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3)))
X     (calc-binary-op "vexp" 'calcFunc-vexp arg)))
)
X
(defun calc-sort ()
X  (interactive)
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1)))
X     (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1)))))
)
X
(defun calc-grade ()
X  (interactive)
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1)))
X     (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1)))))
)
X
(defun calc-histogram (n)
X  (interactive "NNumber of bins: ")
X  (calc-slow-wrapper
X   (if calc-hyperbolic-flag
X       (calc-enter-result 2 "hist" (list 'calcFunc-histogram
X                     (calc-top-n 2)
X                     (calc-top-n 1)
X                     (prefix-numeric-value n)))
X     (calc-enter-result 1 "hist" (list 'calcFunc-histogram
X                       (calc-top-n 1)
X                       (prefix-numeric-value n)))))
)
X
(defun calc-transpose (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "trn" 'calcFunc-trn arg))
)
X
(defun calc-conj-transpose (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "ctrn" 'calcFunc-ctrn arg))
)
X
(defun calc-cross (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "cros" 'calcFunc-cross arg))
)
X
(defun calc-remove-duplicates (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "rdup" 'calcFunc-rdup arg))
)
X
(defun calc-set-union (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup))
)
X
(defun calc-set-intersect (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup))
)
X
(defun calc-set-difference (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup))
)
X
(defun calc-set-xor (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup))
)
X
(defun calc-set-complement (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "cmpl" 'calcFunc-vcompl arg))
)
X
(defun calc-set-floor (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "vflr" 'calcFunc-vfloor arg))
)
X
(defun calc-set-enumerate (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "enum" 'calcFunc-venum arg))
)
X
(defun calc-set-span (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "span" 'calcFunc-vspan arg))
)
X
(defun calc-set-cardinality (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "card" 'calcFunc-vcard arg))
)
X
(defun calc-unpack-bits (arg)
X  (interactive "P")
X  (calc-wrapper
X   (if (calc-is-inverse)
X       (calc-unary-op "bpck" 'calcFunc-vpack arg)
X     (calc-unary-op "bupk" 'calcFunc-vunpack arg)))
)
X
(defun calc-pack-bits (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-unpack-bits arg)
)
X
X
(defun calc-rnorm (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "rnrm" 'calcFunc-rnorm arg))
)
X
(defun calc-cnorm (arg)
X  (interactive "P")
X  (calc-wrapper
X   (calc-unary-op "cnrm" 'calcFunc-cnorm arg))
)
X
(defun calc-mrow (n &optional nn)
X  (interactive "NRow number: \nP")
X  (calc-wrapper
X   (if (consp nn)
X       (calc-enter-result 2 "mrow" (cons 'calcFunc-mrow (calc-top-list-n 2)))
X     (setq n (prefix-numeric-value n))
X     (if (= n 0)
X     (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
X       (if (< n 0)
X       (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow
X                         (calc-top-n 1) (- n)))
X     (calc-enter-result 1 "mrow" (list 'calcFunc-mrow
X                       (calc-top-n 1) n))))))
)
X
(defun calc-mcol (n &optional nn)
X  (interactive "NColumn number: \nP")
X  (calc-wrapper
X   (if (consp nn)
X       (calc-enter-result 2 "mcol" (cons 'calcFunc-mcol (calc-top-list-n 2)))
X     (setq n (prefix-numeric-value n))
X     (if (= n 0)
X     (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
X       (if (< n 0)
X       (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol
X                         (calc-top-n 1) (- n)))
X     (calc-enter-result 1 "mcol" (list 'calcFunc-mcol
X                       (calc-top-n 1) n))))))
)
X
X
;;;; Vectors.
X
(defun calcFunc-mdims (m)
X  (or (math-vectorp m)
X      (math-reject-arg m 'vectorp))
X  (cons 'vec (math-mat-dimens m))
)
X
X
;;; Apply a function elementwise to vector A.  [V X V; N X N] [Public]
(defun math-map-vec (f a)
X  (if (math-vectorp a)
X      (cons 'vec (mapcar f (cdr a)))
X    (funcall f a))
)
X
(defun math-dimension-error ()
X  (calc-record-why "*Dimension error")
X  (signal 'wrong-type-argument nil)
)
X
X
;;; Build a vector out of a list of objects.  [Public]
(defun calcFunc-vec (&rest objs)
X  (cons 'vec objs)
)
X
X
;;; Build a constant vector or matrix.  [Public]
(defun calcFunc-cvec (obj &rest dims)
X  (math-make-vec-dimen obj dims)
)
X
(defun math-make-vec-dimen (obj dims)
X  (if dims
X      (if (natnump (car dims))
X      (if (or (cdr dims)
X          (not (math-numberp obj)))
X          (cons 'vec (copy-sequence
X              (make-list (car dims)
X                     (math-make-vec-dimen obj (cdr dims)))))
X        (cons 'vec (make-list (car dims) obj)))
X    (math-reject-arg (car dims) 'fixnatnump))
X    obj)
)
X
(defun calcFunc-head (vec)
X  (if (and (Math-vectorp vec)
X       (cdr vec))
X      (nth 1 vec)
X    (calc-record-why 'vectorp vec)
X    (list 'calcFunc-head vec))
)
X
(defun calcFunc-tail (vec)
X  (if (and (Math-vectorp vec)
X       (cdr vec))
X      (cons 'vec (cdr (cdr vec)))
X    (calc-record-why 'vectorp vec)
X    (list 'calcFunc-tail vec))
)
X
(defun calcFunc-cons (head tail)
X  (if (Math-vectorp tail)
X      (cons 'vec (cons head (cdr tail)))
X    (calc-record-why 'vectorp tail)
X    (list 'calcFunc-cons head tail))
)
X
(defun calcFunc-rhead (vec)
X  (if (and (Math-vectorp vec)
X       (cdr vec))
X      (let ((vec (copy-sequence vec)))
X    (setcdr (nthcdr (- (length vec) 2) vec) nil)
X    vec)
X    (calc-record-why 'vectorp vec)
X    (list 'calcFunc-rhead vec))
)
X
(defun calcFunc-rtail (vec)
X  (if (and (Math-vectorp vec)
X       (cdr vec))
X      (nth (1- (length vec)) vec)
X    (calc-record-why 'vectorp vec)
X    (list 'calcFunc-rtail vec))
)
X
(defun calcFunc-rcons (head tail)
X  (if (Math-vectorp head)
X      (append head (list tail))
X    (calc-record-why 'vectorp head)
X    (list 'calcFunc-rcons head tail))
)
X
X
X
;;; Apply a function elementwise to vectors A and B.  [O X O O] [Public]
(defun math-map-vec-2 (f a b)
X  (if (math-vectorp a)
X      (if (math-vectorp b)
X      (let ((v nil))
X        (while (setq a (cdr a))
X          (or (setq b (cdr b))
X          (math-dimension-error))
X          (setq v (cons (funcall f (car a) (car b)) v)))
X        (if a (math-dimension-error))
X        (cons 'vec (nreverse v)))
X    (let ((v nil))
X      (while (setq a (cdr a))
X        (setq v (cons (funcall f (car a) b) v)))
X      (cons 'vec (nreverse v))))
X    (if (math-vectorp b)
X    (let ((v nil))
X      (while (setq b (cdr b))
X        (setq v (cons (funcall f a (car b)) v)))
X      (cons 'vec (nreverse v)))
X      (funcall f a b)))
)
X
X
X
;;; "Reduce" a function over a vector (left-associatively).  [O X V] [Public]
(defun math-reduce-vec (f a)
X  (if (math-vectorp a)
X      (if (cdr a)
X      (let ((accum (car (setq a (cdr a)))))
X        (while (setq a (cdr a))
X          (setq accum (funcall f accum (car a))))
X        accum)
X    0)
X    a)
)
X
;;; Reduce a function over the columns of matrix A.  [V X V] [Public]
(defun math-reduce-cols (f a)
X  (if (math-matrixp a)
X      (cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a))))
X    a)
)
X
(defun math-reduce-cols-col-step (f a col cols)
X  (and (< col cols)
X       (cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a))
X         (math-reduce-cols-col-step f a (1+ col) cols)))
)
X
(defun math-reduce-cols-row-step (f tot col a)
X  (if a
X      (math-reduce-cols-row-step f
X                 (funcall f tot (nth col (car a)))
X                 col
X                 (cdr a))
X    tot)
)
X
X
X
(defun math-dot-product (a b)
X  (if (setq a (cdr a) b (cdr b))
X      (let ((accum (math-mul (car a) (car b))))
X    (while (setq a (cdr a) b (cdr b))
X      (setq accum (math-add accum (math-mul (car a) (car b)))))
X    accum)
X    0)
)
X
X
;;; Return the number of elements in vector V.  [Public]
(defun calcFunc-vlen (v)
X  (if (math-vectorp v)
X      (1- (length v))
X    (if (math-objectp v)
X    0
X      (list 'calcFunc-vlen v)))
)
X
;;; Get the Nth row of a matrix.
(defun calcFunc-mrow (mat n)   ; [Public]
X  (if (Math-vectorp n)
X      (math-map-vec (function (lambda (x) (calcFunc-mrow mat x))) n)
X    (if (and (eq (car-safe n) 'intv) (math-constp n))
X    (calcFunc-subvec mat
X             (math-add (nth 2 n) (if (memq (nth 1 n) '(2 3)) 0 1))
X             (math-add (nth 3 n) (if (memq (nth 1 n) '(1 3)) 1 0)))
X      (or (and (integerp (setq n (math-check-integer n)))
X           (> n 0))
X      (math-reject-arg n 'fixposintp))
X      (or (Math-vectorp mat)
X      (math-reject-arg mat 'vectorp))
X      (or (nth n mat)
X      (math-reject-arg n "*Index out of range"))))
)
X
(defun calcFunc-subscr (mat n &optional m)
X  (setq mat (calcFunc-mrow mat n))
X  (if m
X      (if (math-num-integerp n)
X      (calcFunc-mrow mat m)
X    (calcFunc-mcol mat m))
X    mat)
)
X
;;; Get the Nth column of a matrix.
(defun math-mat-col (mat n)
X  (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat)))
)
X
(defun calcFunc-mcol (mat n)   ; [Public]
X  (if (Math-vectorp n)
X      (calcFunc-trn
X       (math-map-vec (function (lambda (x) (calcFunc-mcol mat x))) n))
X    (if (and (eq (car-safe n) 'intv) (math-constp n))
X    (if (math-matrixp mat)
X        (math-map-vec (function (lambda (x) (calcFunc-mrow x n))) mat)
X      (calcFunc-mrow mat n))
X      (or (and (integerp (setq n (math-check-integer n)))
X           (> n 0))
X      (math-reject-arg n 'fixposintp))
X      (or (Math-vectorp mat)
X      (math-reject-arg mat 'vectorp))
X      (or (if (math-matrixp mat)
X          (and (< n (length (nth 1 mat)))
X           (math-mat-col mat n))
X        (nth n mat))
X      (math-reject-arg n "*Index out of range"))))
)
X
;;; Remove the Nth row from a matrix.
(defun math-mat-less-row (mat n)
X  (if (<= n 0)
X      (cdr mat)
X    (cons (car mat)
X      (math-mat-less-row (cdr mat) (1- n))))
)
X
(defun calcFunc-mrrow (mat n)   ; [Public]
X  (and (integerp (setq n (math-check-integer n)))
X       (> n 0)
X       (< n (length mat))
X       (math-mat-less-row mat n))
)
X
;;; Remove the Nth column from a matrix.
(defun math-mat-less-col (mat n)
X  (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n)))
X             (cdr mat)))
)
X
(defun calcFunc-mrcol (mat n)   ; [Public]
X  (and (integerp (setq n (math-check-integer n)))
X       (> n 0)
X       (if (math-matrixp mat)
X       (and (< n (length (nth 1 mat)))
X        (math-mat-less-col mat n))
X     (math-mat-less-row mat n)))
)
X
(defun calcFunc-getdiag (mat)   ; [Public]
X  (if (math-square-matrixp mat)
X      (cons 'vec (math-get-diag-step (cdr mat) 1))
X    (calc-record-why 'square-matrixp mat)
X    (list 'calcFunc-getdiag mat))
)
X
(defun math-get-diag-step (row n)
X  (and row
X       (cons (nth n (car row))
X         (math-get-diag-step (cdr row) (1+ n))))
)
X
(defun math-transpose (mat)   ; [Public]
X  (let ((m nil)
X    (col (length (nth 1 mat))))
X    (while (> (setq col (1- col)) 0)
X      (setq m (cons (math-mat-col mat col) m)))
X    (cons 'vec m))
)
X
(defun calcFunc-trn (mat)
X  (if (math-vectorp mat)
X      (if (math-matrixp mat)
X      (math-transpose mat)
X    (math-col-matrix mat))
X    (if (math-numberp mat)
X    mat
X      (math-reject-arg mat 'matrixp)))
)
X
(defun calcFunc-ctrn (mat)
X  (calcFunc-conj (calcFunc-trn mat))
)
X
(defun calcFunc-pack (mode els)
X  (or (Math-vectorp els) (math-reject-arg els 'vectorp))
X  (if (and (Math-vectorp mode) (cdr mode))
X      (setq mode (cdr mode))
X    (or (integerp mode) (math-reject-arg mode 'fixnump)))
X  (condition-case err
X      (if (= (calc-pack-size mode) (1- (length els)))
X      (calc-pack-items mode (cdr els))
X    (math-reject-arg els "*Wrong number of elements"))
X    (error (math-reject-arg els (nth 1 err))))
)
X
(defun calcFunc-unpack (mode thing)
X  (or (integerp mode) (math-reject-arg mode 'fixnump))
X  (condition-case err
X      (cons 'vec (calc-unpack-item mode thing))
X    (error (math-reject-arg thing (nth 1 err))))
)
X
(defun calcFunc-unpackt (mode thing)
X  (let ((calc-unpack-with-type 'pair))
X    (calcFunc-unpack mode thing))
)
X
(defun calcFunc-arrange (vec cols)   ; [Public]
X  (setq cols (math-check-fixnum cols t))
X  (if (math-vectorp vec)
X      (let* ((flat (math-flatten-vector vec))
X         (mat (list 'vec))
X         next)
X    (if (<= cnls 0)
X        (nconc mat flat)
X      (while (>= (length flat) cols)
X        (setq next (nthcdr cols flat))
X        (setcdr (nthcdr (1- cols) flat) nil)
X        (setq mat (nconc mat (list (cons 'vec flat)))
X          flat next))
X      (if flat
X          (setq mat (nconc mat (list (cons 'vec flat)))))
X      mat)))
)
X
(defun math-flatten-vector (vec)   ; [L V]
X  (if (math-vectorp vec)
X      (apply 'append (mapcar 'math-flatten-vector (cdr vec)))
X    (list vec))
)
X
(defun calcFunc-vconcat (a b)
X  (math-normalize (list '| a b))
)
X
(defun calcFunc-vconcatrev (a b)
X  (math-normalize (list '| b a))
)
X
(defun calcFunc-append (v1 v2)
X  (if (and (math-vectorp v1) (math-vectorp v2))
X      (append v1 (cdr v2))
X    (list 'calcFunc-append v1 v2))
)
X
(defun calcFunc-appendrev (v1 v2)
X  (calcFunc-append v2 v1)
)
X
X
;;; Copy a matrix.  [Public]
(defun math-copy-matrix (m)
X  (if (math-vectorp (nth 1 m))
X      (cons 'vec (mapcar 'copy-sequence (cdr m)))
X    (copy-sequence m))
)
X
;;; Convert a scalar or vector into an NxN diagonal matrix.  [Public]
(defun calcFunc-diag (a &optional n)
X  (and n (not (integerp n))
X       (setq n (math-check-fixnum n)))
X  (if (math-vectorp a)
X      (if (and n (/= (length a) (1+ n)))
X      (list 'calcFunc-diag a n)
X    (if (math-matrixp a)
X        (if (and n (/= (length (elt a 1)) (1+ n)))
X        (list 'calcFunc-diag a n)
X          a)
X      (cons 'vec (math-diag-step (cdr a) 0 (1- (length a))))))
X    (if n
X    (cons 'vec (math-diag-step (make-list n a) 0 n))
X      (list 'calcFunc-diag a)))
)
X
(defun calcFunc-idn (a &optional n)
X  (if n
X      (if (math-vectorp a)
X      (math-reject-arg a 'numberp)
X    (calcFunc-diag a n))
X    (if (integerp calc-matrix-mode)
X    (calcFunc-idn a calc-matrix-mode)
X      (list 'calcFunc-idn a)))
)
X
(defun math-mimic-ident (a m)
X  (if (math-square-matrixp m)
X      (calcFunc-idn a (1- (length m)))
X    (if (math-vectorp m)
X    (if (math-zerop a)
X        (cons 'vec (mapcar (function (lambda (x)
X                       (if (math-vectorp x)
X                           (math-mimic-ident a x)
X                         a)))
X                   (cdr m)))
X      (math-dimension-error))
X      (calcFunc-idn a)))
)
X
(defun math-diag-step (a n m)
X  (if (< n m)
X      (cons (cons 'vec
X          (nconc (make-list n 0)
X             (cons (car a)
X                   (make-list (1- (- m n)) 0))))
X        (math-diag-step (cdr a) (1+ n) m))
X    nil)
)
X
;;; Create a vector of consecutive integers. [Public]
(defun calcFunc-index (n &optional start incr)
X  (if (math-messy-integerp n)
X      (math-float (calcFunc-index (math-trunc n) start incr))
X    (and (not (integerp n))
X     (setq n (math-check-fixnum n)))
X    (let ((vec nil))
X      (if start
X      (progn
X        (if (>= n 0)
X        (while (>= (setq n (1- n)) 0)
X          (setq vec (cons start vec)
X            start (math-add start (or incr 1))))
X          (while (<= (setq n (1+ n)) 0)
X        (setq vec (cons start vec)
X              start (math-mul start (or incr 2)))))
X        (setq vec (nreverse vec)))
X    (if (>= n 0)
X        (while (> n 0)
X          (setq vec (cons n vec)
X            n (1- n)))
X      (let ((i -1))
X        (while (>= i n)
X          (setq vec (cons i vec)
X            i (1- i))))))
X      (cons 'vec vec)))
)
X
;;; Find an element in a vector.
(defun calcFunc-find (vec x &optional start)
X  (setq start (if start (math-check-fixnum start t) 1))
X  (if (< start 1) (math-reject-arg start 'posp))
X  (setq vec (nthcdr start vec))
X  (let ((n start))
X    (while (and vec (not (Math-equal x (car vec))))
X      (setq n (1+ n)
X        vec (cdr vec)))
X    (if vec n 0))
)
X
;;; Return a subvector of a vector.
(defun calcFunc-subvec (vec start &optional end)
X  (setq start (math-check-fixnum start t)
X    end (math-check-fixnum (or end 0) t))
X  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X  (let ((len (1- (length vec))))
X    (if (<= start 0)
X    (setq start (+ len start 1)))
X    (if (<= end 0)
X    (setq end (+ len end 1)))
X    (if (or (> start len)
X        (<= end start))
X    '(vec)
X      (setq vec (nthcdr start vec))
X      (if (<= end len)
X      (let ((chop (nthcdr (- end start 1) (setq vec (copy-sequence vec)))))
X        (setcdr chop nil)))
X      (cons 'vec vec)))
)
X
;;; Remove a subvector from a vector.
(defun calcFunc-rsubvec (vec start &optional end)
X  (setq start (math-check-fixnum start t)
X    end (math-check-fixnum (or end 0) t))
X  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X  (let ((len (1- (length vec))))
X    (if (<= start 0)
X    (setq start (+ len start 1)))
X    (if (<= end 0)
X    (setq end (+ len end 1)))
X    (if (or (> start len)
X        (<= end start))
X    vec
X      (let ((tail (nthcdr end vec))
X        (chop (nthcdr (1- start) (setq vec (copy-sequence vec)))))
X    (setcdr chop nil)
X    (append vec tail))))
)
X
;;; Reverse the order of the elements of a vector.
(defun calcFunc-rev (vec)
X  (if (math-vectorp vec)
X      (cons 'vec (reverse (cdr vec)))
X    (math-reject-arg vec 'vectorp))
)
X
;;; Compress a vector according to a mask vector.
(defun calcFunc-vmask (mask vec)
X  (if (math-numberp mask)
X      (if (math-zerop mask)
X      '(vec)
X    vec)
X    (or (math-vectorp mask) (math-reject-arg mask 'vectorp))
X    (or (math-constp mask) (math-reject-arg mask 'constp))
X    (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X    (or (= (length mask) (length vec)) (math-dimension-error))
X    (let ((new nil))
X      (while (setq mask (cdr mask) vec (cdr vec))
X    (or (math-zerop (car mask))
X        (setq new (cons (car vec) new))))
X      (cons 'vec (nreverse new))))
)
X
;;; Expand a vector according to a mask vector.
(defun calcFunc-vexp (mask vec &optional filler)
X  (or (math-vectorp mask) (math-reject-arg mask 'vectorp))
X  (or (math-constp mask) (math-reject-arg mask 'constp))
X  (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
X  (let ((new nil)
X    (fvec (and filler (math-vectorp filler))))
X    (while (setq mask (cdr mask))
X      (if (math-zerop (car mask))
X      (setq new (cons (or (if fvec
X                  (car (setq filler (cdr filler)))
X                filler)
X                  (car mask)) new))
X    (setq vec (cdr vec)
X          new (cons (or (car vec) (car mask)) new))))
X    (cons 'vec (nreverse new)))
)
X
X
;;; Compute the row and column norms of a vector or matrix.  [Public]
(defun calcFunc-rnorm (a)
X  (if (and (Math-vectorp a)
X       (math-constp a))
X      (if (math-matrixp a)
X      (math-reduce-vec 'math-max (math-map-vec 'calcFunc-cnorm a))
X    (math-reduce-vec 'math-max (math-map-vec 'math-abs a)))
X    (calc-record-why 'vectorp a)
X    (list 'calcFunc-rnorm a))
)
X
(defun calcFunc-cnorm (a)
X  (if (and (Math-vectorp a)
X       (math-constp a))
X      (if (math-matrixp a)
X      (math-reduce-vec 'math-max
X               (math-reduce-cols 'math-add-abs a))
X    (math-reduce-vec 'math-add-abs a))
X    (calc-record-why 'vectorp a)
X    (list 'calcFunc-cnorm a))
)
X
(defun math-add-abs (a b)
X  (math-add (math-abs a) (math-abs b))
)
X
X
;;; Sort the elements of a vector into increasing order.
(defun calcFunc-sort (vec)   ; [Public]
X  (if (math-vectorp vec)
X      (cons 'vec (sort (copy-sequence (cdr vec)) 'math-beforep))
X    (math-reject-arg vec 'vectorp))
)
X
(defun calcFunc-rsort (vec)   ; [Public]
X  (if (math-vectorp vec)
X      (cons 'vec (nreverse (sort (copy-sequence (cdr vec)) 'math-beforep)))
X    (math-reject-arg vec 'vectorp))
)
X
(defun calcFunc-grade (grade-vec)
X  (if (math-vectorp grade-vec)
X      (let* ((len (1- (length grade-vec))))
X    (cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep)))
X    (math-reject-arg grade-vec 'vectorp))
)
X
(defun calcFunc-rgrade (grade-vec)
X  (if (math-vectorp grade-vec)
X      (let* ((len (1- (length grade-vec))))
X    (cons 'vec (nreverse (sort (cdr (calcFunc-index len))
X                   'math-grade-beforep))))
X    (math-reject-arg grade-vec 'vectorp))
)
X
(defun math-grade-beforep (i j)
X  (math-beforep (nth i grade-vec) (nth j grade-vec))
)
X
X
;;; Compile a histogram of data from a vector.
(defun calcFunc-histogram (vec wts &optional n)
X  (or n (setq n wts wts 1))
X  (or (Math-vectorp vec)
X      (math-reject-arg vec 'vectorp))
X  (if (Math-vectorp wts)
X      (or (= (length vec) (length wts))
X      (math-dimension-error)))
X  (or (natnump n)
X      (math-reject-arg n 'fixnatnump))
X  (let ((res (make-vector n 0))
X    (vp vec)
X    (wvec (Math-vectorp wts))
X    (wp wts)
X    bin)
X    (while (setq vp (cdr vp))
X      (setq bin (car vp))
X      (or (natnump bin)
X      (setq bin (math-floor bin)))
X      (and (natnump bin)
X       (< bin n)
X       (aset res bin (math-add (aref res bin)
X                   (if wvec (car (setq wp (cdr wp))) wts)))))
X    (cons 'vec (append res nil)))
)
X
X
;;; Set operations.
X
(defun calcFunc-vunion (a b)
X  (if (Math-objectp a)
X      (setq a (list 'vec a))
X    (or (math-vectorp a) (math-reject-arg a 'vectorp)))
X  (if (Math-objectp b)
X      (setq b (list b))
X    (or (math-vectorp b) (math-reject-arg b 'vectorp))
X    (setq b (cdr b)))
X  (calcFunc-rdup (append a b))
)
X
(defun calcFunc-vint (a b)
X  (if (and (math-simple-set a) (math-simple-set b))
X      (progn
X    (setq a (cdr (calcFunc-rdup a)))
X    (setq b (cdr (calcFunc-rdup b)))
X    (let ((vec (list 'vec)))
X      (while (and a b)
X        (if (math-beforep (car a) (car b))
X        (setq a (cdr a))
X          (if (Math-equal (car a) (car b))
X          (setq vec (cons (car a) vec)
X            a (cdr a)))
X          (setq b (cdr b))))
X      (nreverse vec)))
X    (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a)
X                      (calcFunc-vcompl b))))
)
X
(defun calcFunc-vdiff (a b)
X  (if (and (math-simple-set a) (math-simple-set b))
X      (progn
X    (setq a (cdr (calcFunc-rdup a)))
X    (setq b (cdr (calcFunc-rdup b)))
X    (let ((vec (list 'vec)))
X      (while a
X        (while (and b (math-beforep (car b) (car a)))
X          (setq b (cdr b)))
X        (if (and b (Math-equal (car a) (car b)))
X        (setq a (cdr a)
X              b (cdr b))
X          (setq vec (cons (car a) vec)
X            a (cdr a))))
X      (nreverse vec)))
X    (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b)))
)
X
(defun calcFunc-vxor (a b)
X  (if (and (math-simple-set a) (math-simple-set b))
X      (progn
X    (setq a (cdr (calcFunc-rdup a)))
X    (setq b (cdr (calcFunc-rdup b)))
X    (let ((vec (list 'vec)))
X      (while (or a b)
X        (if (and a
X             (or (not b)
X             (math-beforep (car a) (car b))))
X        (setq vec (cons (car a) vec)
X              a (cdr a))
X          (if (and a (Math-equal (car a) (car b)))
X          (setq a (cdr a))
X        (setq vec (cons (car b) vec)))
X          (setq b (cdr b))))
X      (nreverse vec)))
X    (let ((ca (calcFunc-vcompl a))
X      (cb (calcFunc-vcompl b)))
X      (calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b))
X               (calcFunc-vcompl (calcFunc-vunion a cb)))))
)
X
(defun calcFunc-vcompl (a)
X  (setq a (math-prepare-set a))
X  (let ((vec (list 'vec))
X    (prev '(neg (var inf var-inf)))
X    (closed 2))
X    (while (setq a (cdr a))
X      (or (and (equal (nth 2 (car a)) '(neg (var inf var-inf)))
X           (memq (nth 1 (car a)) '(2 3)))
X      (setq vec (cons (list 'intv
X                (+ closed
X                   (if (memq (nth 1 (car a)) '(0 1)) 1 0))
X                prev
X                (nth 2 (car a)))
X              vec)))
X      (setq prev (nth 3 (car a))
X        closed (if (memq (nth 1 (car a)) '(0 2)) 2 0)))
X    (or (and (equal prev '(var inf var-inf))
X         (= closed 0))
X    (setq vec (cons (list 'intv (+ closed 1)
X                  prev '(var inf var-inf))
X            vec)))
X    (math-clean-set (nreverse vec)))
)
X
(defun calcFunc-vspan (a)
X  (setq a (math-prepare-set a))
X  (if (cdr a)
X      (let ((last (nth (1- (length a)) a)))
X    (math-make-intv (+ (logand (nth 1 (nth 1 a)) 2)
X               (logand (nth 1 last) 1))
X            (nth 2 (nth 1 a))
X            (nth 3 last)))
X    '(intv 2 0 0))
)
X
(defun calcFunc-vfloor (a &optional always-vec)
X  (setq a (math-prepare-set a))
X  (let ((vec (list 'vec)) (p a) (prev nil) b mask)
X    (while (setq p (cdr p))
X      (setq mask (nth 1 (car p))
X        a (nth 2 (car p))
X        b (nth 3 (car p)))
X      (and (memq mask '(0 1))
X       (not (math-infinitep a))
X       (setq mask (logior mask 2))
X       (math-num-integerp a)
X       (setq a (math-add a 1)))
X      (setq a (math-ceiling a))
X      (and (memq mask '(0 2))
X       (not (math-infinitep b))
X       (setq mask (logior mask 1))
X       (math-num-integerp b)
X       (setq b (math-sub b 1)))
X      (setq b (math-floor b))
X      (if (and prev (Math-equal (math-sub a 1) (nth 3 prev)))
X      (setcar (nthcdr 3 prev) b)
X    (or (Math-lessp b a)
X        (setq vec (cons (setq prev (list 'intv mask a b)) vec)))))
X    (setq vec (nreverse vec))
X    (math-clean-set vec always-vec))
)
X
(defun calcFunc-vcard (a)
X  (setq a (calcFunc-vfloor a t))
X  (or (math-constp a) (math-reject-arg a "*Set must be finite"))
X  (let ((count 0))
X    (while (setq a (cdr a))
X      (if (eq (car-safe (car a)) 'intv)
X      (setq count (math-add count (math-sub (nth 3 (car a))
X                        (nth 2 (car a))))))
X      (setq count (math-add count 1)))
X    count)
)
X
(defun calcFunc-venum (a)
X  (setq a (calcFunc-vfloor a t))
X  (or (math-constp a) (math-reject-arg a "*Set must be finite"))
X  (let ((p a) next)
X    (while (cdr p)
X      (setq next (cdr p))
X      (if (eq (car-safe (nth 1 p)) 'intv)
X      (setcdr p (nconc (cdr (calcFunc-index (math-add
X                         (math-sub (nth 3 (nth 1 p))
X                               (nth 2 (nth 1 p)))
X                         1)
X                        (nth 2 (nth 1 p))))
X               (cdr (cdr p)))))
X      (setq p next))
X    a)
)
X
(defun calcFunc-vpack (a)
X  (setq a (calcFunc-vfloor a t))
X  (if (and (cdr a)
X       (math-negp (if (eq (car-safe (nth 1 a)) 'intv)
X              (nth 2 (nth 1 a))
X            (nth 1 a))))
X      (math-reject-arg (nth 1 a) 'posp))
X  (let ((accum 0))
X    (while (setq a (cdr a))
X      (if (eq (car-safe (car a)) 'intv)
X      (if (equal (nth 3 (car a)) '(var inf var-inf))
X          (setq accum (math-sub accum
X                    (math-power-of-2 (nth 2 (car a)))))
X        (setq accum (math-add accum
X                  (math-sub
X                   (math-power-of-2 (1+ (nth 3 (car a))))
X                   (math-power-of-2 (nth 2 (car a)))))))
X    (setq accum (math-add accum (math-power-of-2 (car a))))))
X    accum)
)
X
(defun calcFunc-vunpack (a &optional w)
X  (or (math-num-integerp a) (math-reject-arg a 'integerp))
X  (if w (setq a (math-clip a w)))
X  (if (math-messy-integerp a) (setq a (math-trunc a)))
X  (let* ((calc-number-radix 2)
X     (neg (math-negp a))
X     (aa (if neg (math-sub -1 a) a))
X     (str (if (eq aa 0)
X          ""
X        (if (consp aa)
X            (math-format-bignum-binary (cdr aa))
X          (math-format-binary aa))))
X     (zero (if neg ?1 ?0))
X     (one (if neg ?0 ?1))
X     (len (length str))
X     (vec (list 'vec))
X     (pos (1- len)) pos2)
X    (while (>= pos 0)
X      (if (eq (aref str pos) zero)
X      (setq pos (1- pos))
X    (setq pos2 pos)
X    (while (and (>= pos 0) (eq (aref str pos) one))
X      (setq pos (1- pos)))
X    (setq vec (cons (if (= pos (1- pos2))
X                (- len pos2 1)
X              (list 'intv 3 (- len pos2 1) (- len pos 2)))
X            vec))))
X    (if neg
X    (setq vec (cons (list 'intv 2 len '(var inf var-inf)) vec)))
X    (math-clean-set (nreverse vec)))
)
X
(defun calcFunc-rdup (a)
X  (if (math-simple-set a)
X      (progn
X    (and (Math-objectp a) (setq a (list 'vec a)))
X    (or (math-vectorp a) (math-reject-arg a 'vectorp))
X    (setq a (sort (copy-sequence (cdr a)) 'math-beforep))
X    (let ((p a))
X      (while (cdr p)
X        (if (Math-equal (car p) (nth 1 p))
X        (setcdr p (cdr (cdr p)))
X          (setq p (cdr p)))))
X    (cons 'vec a))
X    (math-clean-set (math-prepare-set a)))
)
X
(defun math-prepare-set (a)
X  (if (Math-objectp a)
X      (setq a (list 'vec a))
X    (or (math-vectorp a) (math-reject-arg a 'vectorp))
X    (setq a (cons 'vec (sort (copy-sequence (cdr a)) 'math-beforep))))
X  (let ((p a) res)
X
X    ;; Convert all elements to non-empty intervals.
X    (while (cdr p)
X      (if (eq (car-safe (nth 1 p)) 'intv)
X      (if (math-intv-constp (nth 1 p))
X          (if (and (memq (nth 1 (nth 1 p)) '(0 1 2))
X               (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p))))
X          (setcdr p (cdr (cdr p)))
X        (setq p (cdr p)))
X        (math-reject-arg (nth 1 p) 'constp))
X    (or (Math-anglep (nth 1 p))
X        (eq (car (nth 1 p)) 'date)
X        (equal (nth 1 p) '(var inf var-inf))
X        (equal (nth 1 p) '(neg (var inf var-inf)))
X        (math-reject-arg (nth 1 p) 'realp))
X    (setcar (cdr p) (list 'intv 3 (nth 1 p) (nth 1 p)))
X    (setq p (cdr p))))
X
X    ;; Combine redundant intervals.
X    (setq p a)
X    (while (cdr (cdr p))
X      (if (or (memq (setq res (math-compare (nth 3 (nth 1 p))
X                        (nth 2 (nth 2 p))))
X            '(-1 2))
X          (and (eq res 0)
X           (memq (nth 1 (nth 1 p)) '(0 2))
X           (memq (nth 1 (nth 2 p)) '(0 1))))
X      (setq p (cdr p))
X    (setq res (math-compare (nth 3 (nth 1 p)) (nth 3 (nth 2 p))))
X    (setcdr p (cons (list 'intv
X                  (+ (logand (logior (nth 1 (nth 1 p))
X                         (if (Math-equal
X                              (nth 2 (nth 1 p))
X                              (nth 2 (nth 2 p)))
X                             (nth 1 (nth 2 p))
X                           0))
X                     2)
X                 (logand (logior (if (memq res '(1 0 2))
X                             (nth 1 (nth 1 p)) 0)
X                         (if (memq res '(-1 0 2))
X                             (nth 1 (nth 2 p)) 0))
X                     1))
X                  (nth 2 (nth 1 p))
X                  (if (eq res 1)
X                  (nth 3 (nth 1 p))
X                (nth 3 (nth 2 p))))
X            (cdr (cdr (cdr p))))))))
X  a
)
X
(defun math-clean-set (a &optional always-vec)
X  (let ((p a) res)
X    (while (cdr p)
X      (if (and (eq (car-safe (nth 1 p)) 'intv)
X           (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p))))
X      (setcar (cdr p) (nth 2 (nth 1 p))))
X      (setq p (cdr p)))
X    (if (and (not (cdr (cdr a)))
X         (eq (car-safe (nth 1 a)) 'intv)
X         (not always-vec))
X    (nth 1 a)
X      a))
)
X
(defun math-simple-set (a)
X  (or (and (Math-objectp a)
X       (not (eq (car-safe a) 'intv)))
X      (and (Math-vectorp a)
X       (progn
X         (while (and (setq a (cdr a))
X             (not (eq (car-safe (car a)) 'intv))))
X         (null a))))
)
X
X
X
X
;;; Compute a right-handed vector cross product.  [O O O] [Public]
(defun calcFunc-cross (a b)
X  (if (and (eq (car-safe a) 'vec)
X       (= (length a) 4))
X      (if (and (eq (car-safe b) 'vec)
X           (= (length b) 4))
X      (list 'vec
X        (math-sub (math-mul (nth 2 a) (nth 3 b))
X              (math-mul (nth 3 a) (nth 2 b)))
X        (math-sub (math-mul (nth 3 a) (nth 1 b))
X              (math-mul (nth 1 a) (nth 3 b)))
X        (math-sub (math-mul (nth 1 a) (nth 2 b))
X              (math-mul (nth 2 a) (nth 1 b))))
X    (math-reject-arg b "*Three-vector expected"))
X    (math-reject-arg a "*Three-vector expected"))
)
X
X
X
X
X
(defun math-read-brackets (space-sep close)
X  (and space-sep (setq space-sep (not (math-check-for-commas))))
X  (math-read-token)
X  (while (eq exp-token 'space)
X    (math-read-token))
X  (if (or (equal exp-data close)
X      (eq exp-token 'end))
X      (progn
X    (math-read-token)
X    '(vec))
X    (let ((vals (let ((exp-keep-spaces space-sep))
X          (if (or (equal exp-data "\\dots")
X              (equal exp-data "\\ldots"))
X              '(vec (neg (var inf var-inf)))
X            (math-read-vector)))))
X      (if (or (equal exp-data "\\dots")
X          (equal exp-data "\\ldots"))
X      (progn
X        (math-read-token)
X        (setq vals (if (> (length vals) 2)
X               (cons 'calcFunc-mul (cdr vals)) (nth 1 vals)))
X        (let ((exp2 (if (or (equal exp-data close)
X                (equal exp-data ")")
X                (eq exp-token 'end))
X                '(var inf var-inf)
X              (math-read-expr-level 0))))
X          (setq vals
X            (list 'intv
X              (if (equal exp-data ")") 2 3)
X              vals
X              exp2)))
X        (if (not (or (equal exp-data close)
X             (equal exp-data ")")
X             (eq exp-token 'end)))
X        (throw 'syntax "Expected `]'")))
X    (if (equal exp-data ";")
X        (let ((exp-keep-spaces space-sep))
X          (setq vals (cons 'vec (math-read-matrix (list vals))))))
X    (if (not (or (equal exp-data close)
X             (eq exp-token 'end)))
X        (throw 'syntax "Expected `]'")))
X      (or (eq exp-token 'end)
X      (math-read-token))
X      vals))
)
X
(defun math-check-for-commas (&optional balancing)
X  (let ((count 0)
X    (pos (1- exp-pos)))
X    (while (and (>= count 0)
X        (setq pos (string-match
X               (if balancing "[],[{}()<>]" "[],[{}()]")
X               exp-str (1+ pos)))
X        (or (/= (aref exp-str pos) ?,) (> count 0) balancing))
X      (cond ((memq (aref exp-str pos) '(?\[ ?\{ ?\( ?\<))
X         (setq count (1+ count)))
X        ((memq (aref exp-str pos) '(?\] ?\} ?\) ?\>))
X         (setq count (1- count)))))
X    (if balancing
X    pos
X      (and pos (= (aref exp-str pos) ?,))))
)
X
(defun math-read-vector ()
X  (let* ((val (list (math-read-expr-level 0)))
X     (last val))
X    (while (progn
X         (while (eq exp-token 'space)
X           (math-read-token))
X         (and (not (eq exp-token 'end))
X          (not (equal exp-data ";"))
X          (not (equal exp-data close))
X          (not (equal exp-data "\\dots"))
X          (not (equal exp-data "\\ldots"))))
X      (if (equal exp-data ",")
X      (math-read-token))
X      (while (eq exp-token 'space)
X    (math-read-token))
X      (let ((rest (list (math-read-expr-level 0))))
X    (setcdr last rest)
X    (setq last rest)))
X    (cons 'vec val))
)
X
(defun math-read-matrix (mat)
X  (while (equal exp-data ";")
X    (math-read-token)
X    (while (eq exp-token 'space)
X      (math-read-token))
X    (setq mat (nconc mat (list (math-read-vector)))))
X  mat
)
X
SHAR_EOF
chmod 0644 calc-vec.el ||
echo 'restore of calc-vec.el failed'
Wc_c="`wc -c < 'calc-vec.el'`"
test 46113 -eq "$Wc_c" ||
    echo 'calc-vec.el: original size 46113, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-units.el ==============
if test -f 'calc-units.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-units.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-units.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-units.el' &&
;; Calculator for GNU Emacs, part II [calc-units.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-units () nil)
X
X
;;; Units commands.
X
(defun calc-base-units ()
X  (interactive)
X  (calc-slow-wrapper
X   (let ((calc-autorange-units nil))
X     (calc-enter-result 1 "bsun" (math-simplify-units
X                  (math-to-standard-units (calc-top-n 1)
X                              nil)))))
)
X
(defun calc-convert-units (&optional old-units new-units)
X  (interactive)
X  (calc-slow-wrapper
X   (let ((expr (calc-top-n 1))
X     (uoldname nil)
X     unew)
X     (or (math-units-in-expr-p expr t)
X     (let ((uold (or old-units
X             (progn
X               (setq uoldname (read-string "Old units: "))
X               (if (equal uoldname "")
X                   (progn
X                 (setq uoldname "1")
X                 1)
X                 (if (string-match "\\` */" uoldname)
SHAR_EOF
true || echo 'restore of calc-units.el failed'
fi
echo 'End of  part 28'
echo 'File calc-units.el is continued in part 29'
echo 29 > _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].