1 ;;; calc-vec.el --- vector functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
34 (defun calc-display-strings (n)
37 (message (if (calc-change-mode 'calc-display-strings n t t)
38 "Displaying vectors of integers as quoted strings"
39 "Displaying vectors of integers normally"))))
45 (let* ((nn (if n 1 2))
46 (mode (if n (prefix-numeric-value n) (calc-top-n 1)))
47 (mode (if (and (Math-vectorp mode) (cdr mode)) (cdr mode)
48 (if (integerp mode) mode
49 (error "Packing mode must be an integer or vector of integers"))))
50 (num (calc-pack-size mode))
51 (items (calc-top-list num nn)))
52 (calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items)))))
54 (defun calc-pack-size (mode)
58 (or (integerp (car mode)) (error "Vector of integers expected"))
59 (setq size (* size (calc-pack-size (car mode)))
62 (error "Zero dimensions not allowed")
65 (t (or (cdr (assq mode '((-3 . 3) (-13 . 1) (-14 . 3) (-15 . 6))))
68 (defun calc-pack-items (mode items)
71 (let* ((size (calc-pack-size (cdr mode)))
76 (setq p (nthcdr (1- size) items)
81 (setq new (cons (calc-pack-items (cdr mode) row) new)))
82 (calc-pack-items (car mode) (nreverse new)))
83 (calc-pack-items (car mode) items)))
87 (if (and (math-objvecp (car items))
88 (math-objvecp (nth 1 items))
89 (math-objvecp (nth 2 items)))
90 (if (and (math-num-integerp (car items))
91 (math-num-integerp (nth 1 items)))
92 (if (math-realp (nth 2 items))
94 (error "Seconds must be real"))
95 (error "Hours and minutes must be integers"))
96 (math-normalize (list '+
98 (if (eq calc-angle-mode 'rad)
102 (list '* (nth 1 items) '(hms 0 1 0)))
103 (list '* (nth 2 items) '(hms 0 0 1))))))
105 (if (math-realp (car items))
107 (if (eq (car-safe (car items)) 'date)
109 (if (math-objvecp (car items))
110 (error "Date value must be real")
111 (cons 'calcFunc-date items)))))
112 ((memq mode '(-14 -15))
114 (while (and p (math-objvecp (car p)))
115 (or (math-integerp (car p))
116 (error "Components must be integers"))
119 (cons 'calcFunc-date items)
120 (list 'date (math-dt-to-date items)))))
121 ((or (eq (car-safe (car items)) 'vec)
122 (eq (car-safe (nth 1 items)) 'vec))
123 (let* ((x (car items))
124 (vx (eq (car-safe x) 'vec))
126 (vy (eq (car-safe y) 'vec))
128 (n (1- (length (if vx x y)))))
130 (/= n (1- (length y)))
131 (error "Vectors must be the same length"))
132 (while (>= (setq n (1- n)) 0)
133 (setq z (cons (calc-pack-items
135 (list (if vx (car (setq x (cdr x))) x)
136 (if vy (car (setq y (cdr y))) y)))
138 (cons 'vec (nreverse z))))
140 (if (and (math-realp (car items)) (math-realp (nth 1 items)))
142 (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
143 (error "Components must be real"))
144 (math-normalize (list '+ (car items)
145 (list '* (nth 1 items) '(cplx 0 1))))))
147 (if (and (math-realp (car items)) (math-anglep (nth 1 items)))
149 (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
150 (error "Components must be real"))
151 (math-normalize (list '* (car items)
152 (if (math-anglep (nth 1 items))
153 (list 'polar 1 (nth 1 items))
163 (let ((x (car items))
164 (sigma (nth 1 items)))
165 (if (or (math-scalarp x) (not (math-objvecp x)))
166 (if (or (math-anglep sigma) (not (math-objvecp sigma)))
167 (math-make-sdev x sigma)
168 (error "Error component must be real"))
169 (error "Mean component must be real or complex"))))
171 (let ((a (car items))
173 (if (and (math-anglep a) (math-anglep m))
176 (error "Modulus must be positive"))
177 (if (and (math-objectp a) (math-objectp m))
178 (error "Components must be real"))
179 (list 'calcFunc-makemod a m))))
180 ((memq mode '(-6 -7 -8 -9))
181 (let ((lo (car items))
183 (if (and (or (math-anglep lo) (eq (car lo) 'date)
184 (not (math-objvecp lo)))
185 (or (math-anglep hi) (eq (car hi) 'date)
186 (not (math-objvecp hi))))
187 (math-make-intv (+ mode 9) lo hi)
188 (error "Components must be real"))))
190 (if (math-zerop (nth 1 items))
191 (error "Denominator must not be zero")
192 (if (and (math-integerp (car items)) (math-integerp (nth 1 items)))
193 (math-normalize (cons 'frac items))
194 (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
195 (error "Components must be integers"))
196 (cons 'calcFunc-fdiv items))))
197 ((memq mode '(-11 -12))
198 (if (and (math-realp (car items)) (math-integerp (nth 1 items)))
199 (calcFunc-scf (math-float (car items)) (nth 1 items))
200 (if (and (math-objectp (car items)) (math-objectp (nth 1 items)))
201 (error "Components must be integers"))
204 (list 'calcFunc-float (car items))
207 (error "Invalid packing mode: %d" mode))))
209 (defvar calc-unpack-with-type nil)
210 (defun calc-unpack (mode)
213 (let ((calc-unpack-with-type t))
214 (calc-pop-push-record-list 1 "unpk" (calc-unpack-item
216 (prefix-numeric-value mode))
219 (defun calc-unpack-type (item)
220 (cond ((eq (car-safe item) 'vec)
222 ((eq (car-safe item) 'intv)
225 (or (cdr (assq (car-safe item) '( (cplx . -1) (polar . -2)
226 (hms . -3) (sdev . -4) (mod . -5)
227 (frac . -10) (float . -11)
229 (error "Argument must be a composite object")))))
231 (defun calc-unpack-item (mode item)
233 (if (or (and (not (memq (car-safe item) '(frac float cplx polar vec
237 (eq (car-safe item) 'var))
238 (error "Argument must be a composite object or function call"))
239 (if (eq (car item) 'intv)
245 (setq item (list item))
247 (setq type (calc-unpack-type (car item))
248 dims (cons type dims)
249 new (calc-unpack-item nil (car item)))
250 (while (setq item (cdr item))
251 (or (= (calc-unpack-type (car item)) type)
252 (error "Inconsistent types or dimensions in vector elements"))
253 (setq new (append new (calc-unpack-item nil (car item)))))
256 (if (cdr dims) (setq dims (list (cons 'vec (nreverse dims)))))
257 (cond ((eq calc-unpack-with-type 'pair)
258 (list (car dims) (cons 'vec item)))
259 (calc-unpack-with-type
262 ((eq calc-unpack-with-type 'pair)
263 (let ((calc-unpack-with-type nil))
264 (list mode (cons 'vec (calc-unpack-item mode item)))))
266 (if (eq (car-safe item) 'hms)
268 (error "Argument must be an HMS form")))
270 (if (eq (car-safe item) 'date)
272 (error "Argument must be a date form")))
274 (if (eq (car-safe item) 'date)
275 (math-date-to-dt (math-floor (nth 1 item)))
276 (error "Argument must be a date form")))
278 (if (eq (car-safe item) 'date)
279 (append (math-date-to-dt (nth 1 item))
280 (and (not (math-integerp (nth 1 item)))
282 (error "Argument must be a date form")))
283 ((eq (car-safe item) 'vec)
287 (while (setq item (cdr item))
288 (setq res (calc-unpack-item mode (car item))
290 y (cons (nth 1 res) y)))
291 (list (cons 'vec (nreverse x))
292 (cons 'vec (nreverse y)))))
294 (if (eq (car-safe item) 'cplx)
296 (if (eq (car-safe item) 'polar)
297 (cdr (math-complex item))
298 (if (Math-realp item)
300 (error "Argument must be a complex number")))))
302 (if (or (memq (car-safe item) '(cplx polar))
304 (cdr (math-polar item))
305 (error "Argument must be a complex number")))
307 (if (eq (car-safe item) 'sdev)
311 (if (eq (car-safe item) 'mod)
313 (error "Argument must be a modulo form")))
314 ((memq mode '(-6 -7 -8 -9))
315 (if (eq (car-safe item) 'intv)
319 (if (eq (car-safe item) 'frac)
321 (if (Math-integerp item)
323 (error "Argument must be a rational number"))))
325 (if (eq (car-safe item) 'float)
326 (list (nth 1 item) (math-normalize (nth 2 item)))
327 (error "Expected a floating-point number")))
329 (if (eq (car-safe item) 'float)
330 (list (calcFunc-mant item) (calcFunc-xpon item))
331 (error "Expected a floating-point number")))
333 (error "Invalid unpacking mode: %d" mode))))
338 (calc-enter-result 1 "diag" (if n
339 (list 'calcFunc-diag (calc-top-n 1)
340 (prefix-numeric-value n))
341 (list 'calcFunc-diag (calc-top-n 1))))))
343 (defun calc-ident (n)
344 (interactive "NDimension of identity matrix = ")
346 (calc-enter-result 0 "idn" (if (eq n 0)
348 (list 'calcFunc-idn 1
349 (prefix-numeric-value n))))))
351 (defun calc-index (n &optional stack)
352 (interactive "NSize of vector = \nP")
355 (calc-enter-result 3 "indx" (cons 'calcFunc-index (calc-top-list-n 3)))
356 (calc-enter-result 0 "indx" (list 'calcFunc-index
357 (prefix-numeric-value n))))))
359 (defun calc-build-vector (n)
360 (interactive "NSize of vector = ")
362 (calc-enter-result 1 "bldv" (list 'calcFunc-cvec
364 (prefix-numeric-value n)))))
366 (defun calc-cons (arg)
369 (if (calc-is-hyperbolic)
370 (calc-binary-op "rcns" 'calcFunc-rcons arg)
371 (calc-binary-op "cons" 'calcFunc-cons arg))))
374 (defun calc-head (arg)
377 (if (calc-is-inverse)
378 (if (calc-is-hyperbolic)
379 (calc-unary-op "rtai" 'calcFunc-rtail arg)
380 (calc-unary-op "tail" 'calcFunc-tail arg))
381 (if (calc-is-hyperbolic)
382 (calc-unary-op "rhed" 'calcFunc-rhead arg)
383 (calc-unary-op "head" 'calcFunc-head arg)))))
385 (defun calc-tail (arg)
390 (defun calc-vlength (arg)
393 (if (calc-is-hyperbolic)
394 (calc-unary-op "dims" 'calcFunc-mdims arg)
395 (calc-unary-op "len" 'calcFunc-vlen arg))))
397 (defun calc-arrange-vector (n)
398 (interactive "NNumber of columns = ")
400 (calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1)
401 (prefix-numeric-value n)))))
403 (defun calc-vector-find (arg)
406 (let ((func (cons 'calcFunc-find (calc-top-list-n 2))))
409 (if arg (append func (list (prefix-numeric-value arg))) func)))))
411 (defun calc-subvector ()
414 (if (calc-is-inverse)
415 (calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec
416 (calc-top-list-n 3)))
417 (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3))))))
419 (defun calc-reverse-vector (arg)
422 (calc-unary-op "rev" 'calcFunc-rev arg)))
424 (defun calc-mask-vector (arg)
427 (calc-binary-op "vmsk" 'calcFunc-vmask arg)))
429 (defun calc-expand-vector (arg)
432 (if (calc-is-hyperbolic)
433 (calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3)))
434 (calc-binary-op "vexp" 'calcFunc-vexp arg))))
439 (if (calc-is-inverse)
440 (calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1)))
441 (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1))))))
446 (if (calc-is-inverse)
447 (calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1)))
448 (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))))
450 (defun calc-histogram (n)
451 (interactive "NNumber of bins: ")
453 (if calc-hyperbolic-flag
454 (calc-enter-result 2 "hist" (list 'calcFunc-histogram
457 (prefix-numeric-value n)))
458 (calc-enter-result 1 "hist" (list 'calcFunc-histogram
460 (prefix-numeric-value n))))))
462 (defun calc-transpose (arg)
465 (calc-unary-op "trn" 'calcFunc-trn arg)))
467 (defun calc-conj-transpose (arg)
470 (calc-unary-op "ctrn" 'calcFunc-ctrn arg)))
472 (defun calc-cross (arg)
475 (calc-binary-op "cros" 'calcFunc-cross arg)))
477 (defun calc-remove-duplicates (arg)
480 (calc-unary-op "rdup" 'calcFunc-rdup arg)))
482 (defun calc-set-union (arg)
485 (calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup)))
487 (defun calc-set-intersect (arg)
490 (calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup)))
492 (defun calc-set-difference (arg)
495 (calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup)))
497 (defun calc-set-xor (arg)
500 (calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup)))
502 (defun calc-set-complement (arg)
505 (calc-unary-op "cmpl" 'calcFunc-vcompl arg)))
507 (defun calc-set-floor (arg)
510 (calc-unary-op "vflr" 'calcFunc-vfloor arg)))
512 (defun calc-set-enumerate (arg)
515 (calc-unary-op "enum" 'calcFunc-venum arg)))
517 (defun calc-set-span (arg)
520 (calc-unary-op "span" 'calcFunc-vspan arg)))
522 (defun calc-set-cardinality (arg)
525 (calc-unary-op "card" 'calcFunc-vcard arg)))
527 (defun calc-unpack-bits (arg)
530 (if (calc-is-inverse)
531 (calc-unary-op "bpck" 'calcFunc-vpack arg)
532 (calc-unary-op "bupk" 'calcFunc-vunpack arg))))
534 (defun calc-pack-bits (arg)
537 (calc-unpack-bits arg))
540 (defun calc-rnorm (arg)
543 (calc-unary-op "rnrm" 'calcFunc-rnorm arg)))
545 (defun calc-cnorm (arg)
548 (calc-unary-op "cnrm" 'calcFunc-cnorm arg)))
550 (defun calc-mrow (n &optional nn)
551 (interactive "NRow number: \nP")
554 (calc-enter-result 2 "mrow" (cons 'calcFunc-mrow (calc-top-list-n 2)))
555 (setq n (prefix-numeric-value n))
557 (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
559 (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow
560 (calc-top-n 1) (- n)))
561 (calc-enter-result 1 "mrow" (list 'calcFunc-mrow
562 (calc-top-n 1) n)))))))
564 (defun calc-mcol (n &optional nn)
565 (interactive "NColumn number: \nP")
568 (calc-enter-result 2 "mcol" (cons 'calcFunc-mcol (calc-top-list-n 2)))
569 (setq n (prefix-numeric-value n))
571 (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1)))
573 (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol
574 (calc-top-n 1) (- n)))
575 (calc-enter-result 1 "mcol" (list 'calcFunc-mcol
576 (calc-top-n 1) n)))))))
581 (defun calcFunc-mdims (m)
583 (math-reject-arg m 'vectorp))
584 (cons 'vec (math-mat-dimens m)))
587 ;;; Apply a function elementwise to vector A. [V X V; N X N] [Public]
588 (defun math-map-vec (f a)
590 (cons 'vec (mapcar f (cdr a)))
593 (defun math-dimension-error ()
594 (calc-record-why "*Dimension error")
595 (signal 'wrong-type-argument nil))
598 ;;; Build a vector out of a list of objects. [Public]
599 (defun calcFunc-vec (&rest objs)
603 ;;; Build a constant vector or matrix. [Public]
604 (defun calcFunc-cvec (obj &rest dims)
605 (math-make-vec-dimen obj dims))
607 (defun math-make-vec-dimen (obj dims)
609 (if (natnump (car dims))
611 (not (math-numberp obj)))
612 (cons 'vec (copy-sequence
613 (make-list (car dims)
614 (math-make-vec-dimen obj (cdr dims)))))
615 (cons 'vec (make-list (car dims) obj)))
616 (math-reject-arg (car dims) 'fixnatnump))
619 (defun calcFunc-head (vec)
620 (if (and (Math-vectorp vec)
623 (calc-record-why 'vectorp vec)
624 (list 'calcFunc-head vec)))
626 (defun calcFunc-tail (vec)
627 (if (and (Math-vectorp vec)
629 (cons 'vec (cdr (cdr vec)))
630 (calc-record-why 'vectorp vec)
631 (list 'calcFunc-tail vec)))
633 (defun calcFunc-cons (head tail)
634 (if (Math-vectorp tail)
635 (cons 'vec (cons head (cdr tail)))
636 (calc-record-why 'vectorp tail)
637 (list 'calcFunc-cons head tail)))
639 (defun calcFunc-rhead (vec)
640 (if (and (Math-vectorp vec)
642 (let ((vec (copy-sequence vec)))
643 (setcdr (nthcdr (- (length vec) 2) vec) nil)
645 (calc-record-why 'vectorp vec)
646 (list 'calcFunc-rhead vec)))
648 (defun calcFunc-rtail (vec)
649 (if (and (Math-vectorp vec)
651 (nth (1- (length vec)) vec)
652 (calc-record-why 'vectorp vec)
653 (list 'calcFunc-rtail vec)))
655 (defun calcFunc-rcons (head tail)
656 (if (Math-vectorp head)
657 (append head (list tail))
658 (calc-record-why 'vectorp head)
659 (list 'calcFunc-rcons head tail)))
663 ;;; Apply a function elementwise to vectors A and B. [O X O O] [Public]
664 (defun math-map-vec-2 (f a b)
668 (while (setq a (cdr a))
670 (math-dimension-error))
671 (setq v (cons (funcall f (car a) (car b)) v)))
672 (if a (math-dimension-error))
673 (cons 'vec (nreverse v)))
675 (while (setq a (cdr a))
676 (setq v (cons (funcall f (car a) b) v)))
677 (cons 'vec (nreverse v))))
680 (while (setq b (cdr b))
681 (setq v (cons (funcall f a (car b)) v)))
682 (cons 'vec (nreverse v)))
687 ;;; "Reduce" a function over a vector (left-associatively). [O X V] [Public]
688 (defun math-reduce-vec (f a)
691 (let ((accum (car (setq a (cdr a)))))
692 (while (setq a (cdr a))
693 (setq accum (funcall f accum (car a))))
698 ;;; Reduce a function over the columns of matrix A. [V X V] [Public]
699 (defun math-reduce-cols (f a)
701 (cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a))))
704 (defun math-reduce-cols-col-step (f a col cols)
706 (cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a))
707 (math-reduce-cols-col-step f a (1+ col) cols))))
709 (defun math-reduce-cols-row-step (f tot col a)
711 (math-reduce-cols-row-step f
712 (funcall f tot (nth col (car a)))
719 (defun math-dot-product (a b)
720 (if (setq a (cdr a) b (cdr b))
721 (let ((accum (math-mul (car a) (car b))))
722 (while (setq a (cdr a) b (cdr b))
723 (setq accum (math-add accum (math-mul (car a) (car b)))))
728 ;;; Return the number of elements in vector V. [Public]
729 (defun calcFunc-vlen (v)
734 (list 'calcFunc-vlen v))))
736 ;;; Get the Nth row of a matrix.
737 (defun calcFunc-mrow (mat n) ; [Public]
739 (math-map-vec (function (lambda (x) (calcFunc-mrow mat x))) n)
740 (if (and (eq (car-safe n) 'intv) (math-constp n))
742 (math-add (nth 2 n) (if (memq (nth 1 n) '(2 3)) 0 1))
743 (math-add (nth 3 n) (if (memq (nth 1 n) '(1 3)) 1 0)))
744 (or (and (integerp (setq n (math-check-integer n)))
746 (math-reject-arg n 'fixposintp))
747 (or (Math-vectorp mat)
748 (math-reject-arg mat 'vectorp))
750 (math-reject-arg n "*Index out of range")))))
752 (defun calcFunc-subscr (mat n &optional m)
753 (setq mat (calcFunc-mrow mat n))
755 (if (math-num-integerp n)
756 (calcFunc-mrow mat m)
757 (calcFunc-mcol mat m))
760 ;;; Get the Nth column of a matrix.
761 (defun math-mat-col (mat n)
762 (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat))))
764 (defun calcFunc-mcol (mat n) ; [Public]
767 (math-map-vec (function (lambda (x) (calcFunc-mcol mat x))) n))
768 (if (and (eq (car-safe n) 'intv) (math-constp n))
769 (if (math-matrixp mat)
770 (math-map-vec (function (lambda (x) (calcFunc-mrow x n))) mat)
771 (calcFunc-mrow mat n))
772 (or (and (integerp (setq n (math-check-integer n)))
774 (math-reject-arg n 'fixposintp))
775 (or (Math-vectorp mat)
776 (math-reject-arg mat 'vectorp))
777 (or (if (math-matrixp mat)
778 (and (< n (length (nth 1 mat)))
779 (math-mat-col mat n))
781 (math-reject-arg n "*Index out of range")))))
783 ;;; Remove the Nth row from a matrix.
784 (defun math-mat-less-row (mat n)
788 (math-mat-less-row (cdr mat) (1- n)))))
790 (defun calcFunc-mrrow (mat n) ; [Public]
791 (and (integerp (setq n (math-check-integer n)))
794 (math-mat-less-row mat n)))
796 ;;; Remove the Nth column from a matrix.
797 (defun math-mat-less-col (mat n)
798 (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n)))
801 (defun calcFunc-mrcol (mat n) ; [Public]
802 (and (integerp (setq n (math-check-integer n)))
804 (if (math-matrixp mat)
805 (and (< n (length (nth 1 mat)))
806 (math-mat-less-col mat n))
807 (math-mat-less-row mat n))))
809 (defun calcFunc-getdiag (mat) ; [Public]
810 (if (math-square-matrixp mat)
811 (cons 'vec (math-get-diag-step (cdr mat) 1))
812 (calc-record-why 'square-matrixp mat)
813 (list 'calcFunc-getdiag mat)))
815 (defun math-get-diag-step (row n)
817 (cons (nth n (car row))
818 (math-get-diag-step (cdr row) (1+ n)))))
820 (defun math-transpose (mat) ; [Public]
822 (col (length (nth 1 mat))))
823 (while (> (setq col (1- col)) 0)
824 (setq m (cons (math-mat-col mat col) m)))
827 (defun calcFunc-trn (mat)
828 (if (math-vectorp mat)
829 (if (math-matrixp mat)
831 (math-col-matrix mat))
832 (if (math-numberp mat)
834 (math-reject-arg mat 'matrixp))))
836 (defun calcFunc-ctrn (mat)
837 (calcFunc-conj (calcFunc-trn mat)))
839 (defun calcFunc-pack (mode els)
840 (or (Math-vectorp els) (math-reject-arg els 'vectorp))
841 (if (and (Math-vectorp mode) (cdr mode))
842 (setq mode (cdr mode))
843 (or (integerp mode) (math-reject-arg mode 'fixnump)))
845 (if (= (calc-pack-size mode) (1- (length els)))
846 (calc-pack-items mode (cdr els))
847 (math-reject-arg els "*Wrong number of elements"))
848 (error (math-reject-arg els (nth 1 err)))))
850 (defun calcFunc-unpack (mode thing)
851 (or (integerp mode) (math-reject-arg mode 'fixnump))
853 (cons 'vec (calc-unpack-item mode thing))
854 (error (math-reject-arg thing (nth 1 err)))))
856 (defun calcFunc-unpackt (mode thing)
857 (let ((calc-unpack-with-type 'pair))
858 (calcFunc-unpack mode thing)))
860 (defun calcFunc-arrange (vec cols) ; [Public]
861 (setq cols (math-check-fixnum cols t))
862 (if (math-vectorp vec)
863 (let* ((flat (math-flatten-vector vec))
868 (while (>= (length flat) cols)
869 (setq next (nthcdr cols flat))
870 (setcdr (nthcdr (1- cols) flat) nil)
871 (setq mat (nconc mat (list (cons 'vec flat)))
874 (setq mat (nconc mat (list (cons 'vec flat)))))
877 (defun math-flatten-vector (vec) ; [L V]
878 (if (math-vectorp vec)
879 (apply 'append (mapcar 'math-flatten-vector (cdr vec)))
882 (defun calcFunc-vconcat (a b)
883 (math-normalize (list '| a b)))
885 (defun calcFunc-vconcatrev (a b)
886 (math-normalize (list '| b a)))
888 (defun calcFunc-append (v1 v2)
889 (if (and (math-vectorp v1) (math-vectorp v2))
891 (list 'calcFunc-append v1 v2)))
893 (defun calcFunc-appendrev (v1 v2)
894 (calcFunc-append v2 v1))
897 ;;; Copy a matrix. [Public]
898 (defun math-copy-matrix (m)
899 (if (math-vectorp (nth 1 m))
900 (cons 'vec (mapcar 'copy-sequence (cdr m)))
903 ;;; Convert a scalar or vector into an NxN diagonal matrix. [Public]
904 (defun calcFunc-diag (a &optional n)
905 (and n (not (integerp n))
906 (setq n (math-check-fixnum n)))
908 (if (and n (/= (length a) (1+ n)))
909 (list 'calcFunc-diag a n)
911 (if (and n (/= (length (elt a 1)) (1+ n)))
912 (list 'calcFunc-diag a n)
914 (cons 'vec (math-diag-step (cdr a) 0 (1- (length a))))))
916 (cons 'vec (math-diag-step (make-list n a) 0 n))
917 (list 'calcFunc-diag a))))
919 (defun calcFunc-idn (a &optional n)
922 (math-reject-arg a 'numberp)
924 (if (integerp calc-matrix-mode)
925 (calcFunc-idn a calc-matrix-mode)
926 (list 'calcFunc-idn a))))
928 (defun math-mimic-ident (a m)
929 (if (math-square-matrixp m)
930 (calcFunc-idn a (1- (length m)))
933 (cons 'vec (mapcar (function (lambda (x)
935 (math-mimic-ident a x)
938 (math-dimension-error))
941 (defun math-diag-step (a n m)
944 (nconc (make-list n 0)
946 (make-list (1- (- m n)) 0))))
947 (math-diag-step (cdr a) (1+ n) m))
950 ;;; Create a vector of consecutive integers. [Public]
951 (defun calcFunc-index (n &optional start incr)
952 (if (math-messy-integerp n)
953 (math-float (calcFunc-index (math-trunc n) start incr))
954 (and (not (integerp n))
955 (setq n (math-check-fixnum n)))
960 (while (>= (setq n (1- n)) 0)
961 (setq vec (cons start vec)
962 start (math-add start (or incr 1))))
963 (while (<= (setq n (1+ n)) 0)
964 (setq vec (cons start vec)
965 start (math-mul start (or incr 2)))))
966 (setq vec (nreverse vec)))
969 (setq vec (cons n vec)
973 (setq vec (cons i vec)
977 ;;; Find an element in a vector.
978 (defun calcFunc-find (vec x &optional start)
979 (setq start (if start (math-check-fixnum start t) 1))
980 (if (< start 1) (math-reject-arg start 'posp))
981 (setq vec (nthcdr start vec))
983 (while (and vec (not (Math-equal x (car vec))))
988 ;;; Return a subvector of a vector.
989 (defun calcFunc-subvec (vec start &optional end)
990 (setq start (math-check-fixnum start t)
991 end (math-check-fixnum (or end 0) t))
992 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
993 (let ((len (1- (length vec))))
995 (setq start (+ len start 1)))
997 (setq end (+ len end 1)))
998 (if (or (> start len)
1001 (setq vec (nthcdr start vec))
1003 (let ((chop (nthcdr (- end start 1) (setq vec (copy-sequence vec)))))
1007 ;;; Remove a subvector from a vector.
1008 (defun calcFunc-rsubvec (vec start &optional end)
1009 (setq start (math-check-fixnum start t)
1010 end (math-check-fixnum (or end 0) t))
1011 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
1012 (let ((len (1- (length vec))))
1014 (setq start (+ len start 1)))
1016 (setq end (+ len end 1)))
1017 (if (or (> start len)
1020 (let ((tail (nthcdr end vec))
1021 (chop (nthcdr (1- start) (setq vec (copy-sequence vec)))))
1023 (append vec tail)))))
1025 ;;; Reverse the order of the elements of a vector.
1026 (defun calcFunc-rev (vec)
1027 (if (math-vectorp vec)
1028 (cons 'vec (reverse (cdr vec)))
1029 (math-reject-arg vec 'vectorp)))
1031 ;;; Compress a vector according to a mask vector.
1032 (defun calcFunc-vmask (mask vec)
1033 (if (math-numberp mask)
1034 (if (math-zerop mask)
1037 (or (math-vectorp mask) (math-reject-arg mask 'vectorp))
1038 (or (math-constp mask) (math-reject-arg mask 'constp))
1039 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
1040 (or (= (length mask) (length vec)) (math-dimension-error))
1042 (while (setq mask (cdr mask) vec (cdr vec))
1043 (or (math-zerop (car mask))
1044 (setq new (cons (car vec) new))))
1045 (cons 'vec (nreverse new)))))
1047 ;;; Expand a vector according to a mask vector.
1048 (defun calcFunc-vexp (mask vec &optional filler)
1049 (or (math-vectorp mask) (math-reject-arg mask 'vectorp))
1050 (or (math-constp mask) (math-reject-arg mask 'constp))
1051 (or (math-vectorp vec) (math-reject-arg vec 'vectorp))
1053 (fvec (and filler (math-vectorp filler))))
1054 (while (setq mask (cdr mask))
1055 (if (math-zerop (car mask))
1056 (setq new (cons (or (if fvec
1057 (car (setq filler (cdr filler)))
1061 new (cons (or (car vec) (car mask)) new))))
1062 (cons 'vec (nreverse new))))
1065 ;;; Compute the row and column norms of a vector or matrix. [Public]
1066 (defun calcFunc-rnorm (a)
1067 (if (and (Math-vectorp a)
1069 (if (math-matrixp a)
1070 (math-reduce-vec 'math-max (math-map-vec 'calcFunc-cnorm a))
1071 (math-reduce-vec 'math-max (math-map-vec 'math-abs a)))
1072 (calc-record-why 'vectorp a)
1073 (list 'calcFunc-rnorm a)))
1075 (defun calcFunc-cnorm (a)
1076 (if (and (Math-vectorp a)
1078 (if (math-matrixp a)
1079 (math-reduce-vec 'math-max
1080 (math-reduce-cols 'math-add-abs a))
1081 (math-reduce-vec 'math-add-abs a))
1082 (calc-record-why 'vectorp a)
1083 (list 'calcFunc-cnorm a)))
1085 (defun math-add-abs (a b)
1086 (math-add (math-abs a) (math-abs b)))
1089 ;;; Sort the elements of a vector into increasing order.
1090 (defun calcFunc-sort (vec) ; [Public]
1091 (if (math-vectorp vec)
1092 (cons 'vec (sort (copy-sequence (cdr vec)) 'math-beforep))
1093 (math-reject-arg vec 'vectorp)))
1095 (defun calcFunc-rsort (vec) ; [Public]
1096 (if (math-vectorp vec)
1097 (cons 'vec (nreverse (sort (copy-sequence (cdr vec)) 'math-beforep)))
1098 (math-reject-arg vec 'vectorp)))
1100 ;; The variable math-grade-vec is local to calcFunc-grade and
1101 ;; calcFunc-rgrade, but is used by math-grade-beforep, which is called
1102 ;; by calcFunc-grade and calcFunc-rgrade.
1103 (defvar math-grade-vec)
1105 (defun calcFunc-grade (math-grade-vec)
1106 (if (math-vectorp math-grade-vec)
1107 (let* ((len (1- (length math-grade-vec))))
1108 (cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep)))
1109 (math-reject-arg math-grade-vec 'vectorp)))
1111 (defun calcFunc-rgrade (math-grade-vec)
1112 (if (math-vectorp math-grade-vec)
1113 (let* ((len (1- (length math-grade-vec))))
1114 (cons 'vec (nreverse (sort (cdr (calcFunc-index len))
1115 'math-grade-beforep))))
1116 (math-reject-arg math-grade-vec 'vectorp)))
1118 (defun math-grade-beforep (i j)
1119 (math-beforep (nth i math-grade-vec) (nth j math-grade-vec)))
1122 ;;; Compile a histogram of data from a vector.
1123 (defun calcFunc-histogram (vec wts &optional n)
1124 (or n (setq n wts wts 1))
1125 (or (Math-vectorp vec)
1126 (math-reject-arg vec 'vectorp))
1127 (if (Math-vectorp wts)
1128 (or (= (length vec) (length wts))
1129 (math-dimension-error)))
1131 (math-reject-arg n 'fixnatnump))
1132 (let ((res (make-vector n 0))
1134 (wvec (Math-vectorp wts))
1137 (while (setq vp (cdr vp))
1140 (setq bin (math-floor bin)))
1143 (aset res bin (math-add (aref res bin)
1144 (if wvec (car (setq wp (cdr wp))) wts)))))
1145 (cons 'vec (append res nil))))
1150 (defun calcFunc-vunion (a b)
1151 (if (Math-objectp a)
1152 (setq a (list 'vec a))
1153 (or (math-vectorp a) (math-reject-arg a 'vectorp)))
1154 (if (Math-objectp b)
1156 (or (math-vectorp b) (math-reject-arg b 'vectorp))
1158 (calcFunc-rdup (append a b)))
1160 (defun calcFunc-vint (a b)
1161 (if (and (math-simple-set a) (math-simple-set b))
1163 (setq a (cdr (calcFunc-rdup a)))
1164 (setq b (cdr (calcFunc-rdup b)))
1165 (let ((vec (list 'vec)))
1167 (if (math-beforep (car a) (car b))
1169 (if (Math-equal (car a) (car b))
1170 (setq vec (cons (car a) vec)
1174 (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a)
1175 (calcFunc-vcompl b)))))
1177 (defun calcFunc-vdiff (a b)
1178 (if (and (math-simple-set a) (math-simple-set b))
1180 (setq a (cdr (calcFunc-rdup a)))
1181 (setq b (cdr (calcFunc-rdup b)))
1182 (let ((vec (list 'vec)))
1184 (while (and b (math-beforep (car b) (car a)))
1186 (if (and b (Math-equal (car a) (car b)))
1189 (setq vec (cons (car a) vec)
1192 (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b))))
1194 (defun calcFunc-vxor (a b)
1195 (if (and (math-simple-set a) (math-simple-set b))
1197 (setq a (cdr (calcFunc-rdup a)))
1198 (setq b (cdr (calcFunc-rdup b)))
1199 (let ((vec (list 'vec)))
1203 (math-beforep (car a) (car b))))
1204 (setq vec (cons (car a) vec)
1206 (if (and a (Math-equal (car a) (car b)))
1208 (setq vec (cons (car b) vec)))
1211 (let ((ca (calcFunc-vcompl a))
1212 (cb (calcFunc-vcompl b)))
1213 (calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b))
1214 (calcFunc-vcompl (calcFunc-vunion a cb))))))
1216 (defun calcFunc-vcompl (a)
1217 (setq a (math-prepare-set a))
1218 (let ((vec (list 'vec))
1219 (prev '(neg (var inf var-inf)))
1221 (while (setq a (cdr a))
1222 (or (and (equal (nth 2 (car a)) '(neg (var inf var-inf)))
1223 (memq (nth 1 (car a)) '(2 3)))
1224 (setq vec (cons (list 'intv
1226 (if (memq (nth 1 (car a)) '(0 1)) 1 0))
1230 (setq prev (nth 3 (car a))
1231 closed (if (memq (nth 1 (car a)) '(0 2)) 2 0)))
1232 (or (and (equal prev '(var inf var-inf))
1234 (setq vec (cons (list 'intv (+ closed 1)
1235 prev '(var inf var-inf))
1237 (math-clean-set (nreverse vec))))
1239 (defun calcFunc-vspan (a)
1240 (setq a (math-prepare-set a))
1242 (let ((last (nth (1- (length a)) a)))
1243 (math-make-intv (+ (logand (nth 1 (nth 1 a)) 2)
1244 (logand (nth 1 last) 1))
1249 (defun calcFunc-vfloor (a &optional always-vec)
1250 (setq a (math-prepare-set a))
1251 (let ((vec (list 'vec)) (p a) (prev nil) b mask)
1252 (while (setq p (cdr p))
1253 (setq mask (nth 1 (car p))
1256 (and (memq mask '(0 1))
1257 (not (math-infinitep a))
1258 (setq mask (logior mask 2))
1259 (math-num-integerp a)
1260 (setq a (math-add a 1)))
1261 (setq a (math-ceiling a))
1262 (and (memq mask '(0 2))
1263 (not (math-infinitep b))
1264 (setq mask (logior mask 1))
1265 (math-num-integerp b)
1266 (setq b (math-sub b 1)))
1267 (setq b (math-floor b))
1268 (if (and prev (Math-equal (math-sub a 1) (nth 3 prev)))
1269 (setcar (nthcdr 3 prev) b)
1270 (or (Math-lessp b a)
1271 (setq vec (cons (setq prev (list 'intv mask a b)) vec)))))
1272 (setq vec (nreverse vec))
1273 (math-clean-set vec always-vec)))
1275 (defun calcFunc-vcard (a)
1276 (setq a (calcFunc-vfloor a t))
1277 (or (math-constp a) (math-reject-arg a "*Set must be finite"))
1279 (while (setq a (cdr a))
1280 (if (eq (car-safe (car a)) 'intv)
1281 (setq count (math-add count (math-sub (nth 3 (car a))
1283 (setq count (math-add count 1)))
1286 (defun calcFunc-venum (a)
1287 (setq a (calcFunc-vfloor a t))
1288 (or (math-constp a) (math-reject-arg a "*Set must be finite"))
1292 (if (eq (car-safe (nth 1 p)) 'intv)
1293 (setcdr p (nconc (cdr (calcFunc-index (math-add
1294 (math-sub (nth 3 (nth 1 p))
1302 (defun calcFunc-vpack (a)
1303 (setq a (calcFunc-vfloor a t))
1305 (math-negp (if (eq (car-safe (nth 1 a)) 'intv)
1308 (math-reject-arg (nth 1 a) 'posp))
1310 (while (setq a (cdr a))
1311 (if (eq (car-safe (car a)) 'intv)
1312 (if (equal (nth 3 (car a)) '(var inf var-inf))
1313 (setq accum (math-sub accum
1314 (math-power-of-2 (nth 2 (car a)))))
1315 (setq accum (math-add accum
1317 (math-power-of-2 (1+ (nth 3 (car a))))
1318 (math-power-of-2 (nth 2 (car a)))))))
1319 (setq accum (math-add accum (math-power-of-2 (car a))))))
1322 (defun calcFunc-vunpack (a &optional w)
1323 (or (math-num-integerp a) (math-reject-arg a 'integerp))
1324 (if w (setq a (math-clip a w)))
1325 (if (math-messy-integerp a) (setq a (math-trunc a)))
1326 (let* ((calc-number-radix 2)
1328 (aa (if neg (math-sub -1 a) a))
1332 (math-format-bignum-binary (cdr aa))
1333 (math-format-binary aa))))
1334 (zero (if neg ?1 ?0))
1335 (one (if neg ?0 ?1))
1338 (pos (1- len)) pos2)
1340 (if (eq (aref str pos) zero)
1343 (while (and (>= pos 0) (eq (aref str pos) one))
1344 (setq pos (1- pos)))
1345 (setq vec (cons (if (= pos (1- pos2))
1347 (list 'intv 3 (- len pos2 1) (- len pos 2)))
1350 (setq vec (cons (list 'intv 2 len '(var inf var-inf)) vec)))
1351 (math-clean-set (nreverse vec))))
1353 (defun calcFunc-rdup (a)
1354 (if (math-simple-set a)
1356 (and (Math-objectp a) (setq a (list 'vec a)))
1357 (or (math-vectorp a) (math-reject-arg a 'vectorp))
1358 (setq a (sort (copy-sequence (cdr a)) 'math-beforep))
1361 (if (Math-equal (car p) (nth 1 p))
1362 (setcdr p (cdr (cdr p)))
1365 (math-clean-set (math-prepare-set a))))
1367 (defun math-prepare-set (a)
1368 (if (Math-objectp a)
1369 (setq a (list 'vec a))
1370 (or (math-vectorp a) (math-reject-arg a 'vectorp))
1371 (setq a (cons 'vec (sort (copy-sequence (cdr a)) 'math-beforep))))
1374 ;; Convert all elements to non-empty intervals.
1376 (if (eq (car-safe (nth 1 p)) 'intv)
1377 (if (math-intv-constp (nth 1 p))
1378 (if (and (memq (nth 1 (nth 1 p)) '(0 1 2))
1379 (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p))))
1380 (setcdr p (cdr (cdr p)))
1382 (math-reject-arg (nth 1 p) 'constp))
1383 (or (Math-anglep (nth 1 p))
1384 (eq (car (nth 1 p)) 'date)
1385 (equal (nth 1 p) '(var inf var-inf))
1386 (equal (nth 1 p) '(neg (var inf var-inf)))
1387 (math-reject-arg (nth 1 p) 'realp))
1388 (setcar (cdr p) (list 'intv 3 (nth 1 p) (nth 1 p)))
1391 ;; Combine redundant intervals.
1393 (while (cdr (cdr p))
1394 (if (or (memq (setq res (math-compare (nth 3 (nth 1 p))
1398 (memq (nth 1 (nth 1 p)) '(0 2))
1399 (memq (nth 1 (nth 2 p)) '(0 1))))
1401 (setq res (math-compare (nth 3 (nth 1 p)) (nth 3 (nth 2 p))))
1402 (setcdr p (cons (list 'intv
1403 (+ (logand (logior (nth 1 (nth 1 p))
1410 (logand (logior (if (memq res '(1 0 2))
1411 (nth 1 (nth 1 p)) 0)
1412 (if (memq res '(-1 0 2))
1413 (nth 1 (nth 2 p)) 0))
1419 (cdr (cdr (cdr p))))))))
1422 (defun math-clean-set (a &optional always-vec)
1425 (if (and (eq (car-safe (nth 1 p)) 'intv)
1426 (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p))))
1427 (setcar (cdr p) (nth 2 (nth 1 p))))
1429 (if (and (not (cdr (cdr a)))
1430 (eq (car-safe (nth 1 a)) 'intv)
1435 (defun math-simple-set (a)
1436 (or (and (Math-objectp a)
1437 (not (eq (car-safe a) 'intv)))
1438 (and (Math-vectorp a)
1440 (while (and (setq a (cdr a))
1441 (not (eq (car-safe (car a)) 'intv))))
1447 ;;; Compute a right-handed vector cross product. [O O O] [Public]
1448 (defun calcFunc-cross (a b)
1449 (if (and (eq (car-safe a) 'vec)
1451 (if (and (eq (car-safe b) 'vec)
1454 (math-sub (math-mul (nth 2 a) (nth 3 b))
1455 (math-mul (nth 3 a) (nth 2 b)))
1456 (math-sub (math-mul (nth 3 a) (nth 1 b))
1457 (math-mul (nth 1 a) (nth 3 b)))
1458 (math-sub (math-mul (nth 1 a) (nth 2 b))
1459 (math-mul (nth 2 a) (nth 1 b))))
1460 (math-reject-arg b "*Three-vector expected"))
1461 (math-reject-arg a "*Three-vector expected")))
1465 ;; The variable math-rb-close is local to math-read-brackets, but
1466 ;; is used by math-read-vector, which is called (directly and
1467 ;; indirectly) by math-read-brackets.
1468 (defvar math-rb-close)
1470 ;; The next few variables are local to math-read-exprs in calc-aent.el
1471 ;; and math-read-expr in calc-ext.el, but are set in functions they call.
1472 (defvar math-exp-pos)
1473 (defvar math-exp-str)
1474 (defvar math-exp-old-pos)
1475 (defvar math-exp-token)
1476 (defvar math-exp-keep-spaces)
1477 (defvar math-expr-data)
1479 (defun math-read-brackets (space-sep math-rb-close)
1480 (and space-sep (setq space-sep (not (math-check-for-commas))))
1482 (while (eq math-exp-token 'space)
1484 (if (or (equal math-expr-data math-rb-close)
1485 (eq math-exp-token 'end))
1489 (let ((save-exp-pos math-exp-pos)
1490 (save-exp-old-pos math-exp-old-pos)
1491 (save-exp-token math-exp-token)
1492 (save-exp-data math-expr-data)
1493 (vals (let ((math-exp-keep-spaces space-sep))
1494 (if (or (equal math-expr-data "\\dots")
1495 (equal math-expr-data "\\ldots"))
1496 '(vec (neg (var inf var-inf)))
1497 (catch 'syntax (math-read-vector))))))
1500 (let ((error-exp-pos math-exp-pos)
1501 (error-exp-old-pos math-exp-old-pos)
1503 (setq math-exp-pos save-exp-pos
1504 math-exp-old-pos save-exp-old-pos
1505 math-exp-token save-exp-token
1506 math-expr-data save-exp-data)
1507 (let ((math-exp-keep-spaces nil))
1508 (setq vals2 (catch 'syntax (math-read-vector))))
1509 (if (and (not (stringp vals2))
1510 (or (assoc math-expr-data '(("\\ldots") ("\\dots") (";")))
1511 (equal math-expr-data math-rb-close)
1512 (eq math-exp-token 'end)))
1515 (setq math-exp-pos error-exp-pos
1516 math-exp-old-pos error-exp-old-pos)
1517 (throw 'syntax vals)))
1518 (throw 'syntax vals)))
1519 (if (or (equal math-expr-data "\\dots")
1520 (equal math-expr-data "\\ldots"))
1523 (setq vals (if (> (length vals) 2)
1524 (cons 'calcFunc-mul (cdr vals)) (nth 1 vals)))
1525 (let ((exp2 (if (or (equal math-expr-data math-rb-close)
1526 (equal math-expr-data ")")
1527 (eq math-exp-token 'end))
1529 (math-read-expr-level 0))))
1532 (if (equal math-expr-data ")") 2 3)
1535 (if (not (or (equal math-expr-data math-rb-close)
1536 (equal math-expr-data ")")
1537 (eq math-exp-token 'end)))
1538 (throw 'syntax "Expected `]'")))
1539 (if (equal math-expr-data ";")
1540 (let ((math-exp-keep-spaces space-sep))
1541 (setq vals (cons 'vec (math-read-matrix (list vals))))))
1542 (if (not (or (equal math-expr-data math-rb-close)
1543 (eq math-exp-token 'end)))
1544 (throw 'syntax "Expected `]'")))
1545 (or (eq math-exp-token 'end)
1549 (defun math-check-for-commas (&optional balancing)
1551 (pos (1- math-exp-pos)))
1552 (while (and (>= count 0)
1553 (setq pos (string-match
1554 (if balancing "[],[{}()<>]" "[],[{}()]")
1555 math-exp-str (1+ pos)))
1556 (or (/= (aref math-exp-str pos) ?,) (> count 0) balancing))
1557 (cond ((memq (aref math-exp-str pos) '(?\[ ?\{ ?\( ?\<))
1558 (setq count (1+ count)))
1559 ((memq (aref math-exp-str pos) '(?\] ?\} ?\) ?\>))
1560 (setq count (1- count)))))
1563 (and pos (= (aref math-exp-str pos) ?,)))))
1565 (defun math-read-vector ()
1566 (let* ((val (list (math-read-expr-level 0)))
1569 (while (eq math-exp-token 'space)
1571 (and (not (eq math-exp-token 'end))
1572 (not (equal math-expr-data ";"))
1573 (not (equal math-expr-data math-rb-close))
1574 (not (equal math-expr-data "\\dots"))
1575 (not (equal math-expr-data "\\ldots"))))
1576 (if (equal math-expr-data ",")
1578 (while (eq math-exp-token 'space)
1580 (let ((rest (list (math-read-expr-level 0))))
1585 (defun math-read-matrix (mat)
1586 (while (equal math-expr-data ";")
1588 (while (eq math-exp-token 'space)
1590 (setq mat (nconc mat (list (math-read-vector)))))
1595 ;;; arch-tag: 7902a7af-ec69-440a-8635-ebb4db263402
1596 ;;; calc-vec.el ends here