1 ;;; calc-vec.el --- vector functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 3, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 ;; This file is autoloaded from calc-ext.el.
35 ;; Declare functions which are defined elsewhere.
36 (declare-function math-read-expr-level
"calc-aent" (exp-prec &optional exp-term
))
39 (defun calc-display-strings (n)
42 (message (if (calc-change-mode 'calc-display-strings n t t
)
43 "Displaying vectors of integers as quoted strings"
44 "Displaying vectors of integers normally"))))
50 (let* ((nn (if n
1 2))
51 (mode (if n
(prefix-numeric-value n
) (calc-top-n 1)))
52 (mode (if (and (Math-vectorp mode
) (cdr mode
)) (cdr mode
)
53 (if (integerp mode
) mode
54 (error "Packing mode must be an integer or vector of integers"))))
55 (num (calc-pack-size mode
))
56 (items (calc-top-list num nn
)))
57 (calc-enter-result (+ nn num -
1) "pack" (calc-pack-items mode items
)))))
59 (defun calc-pack-size (mode)
63 (or (integerp (car mode
)) (error "Vector of integers expected"))
64 (setq size
(* size
(calc-pack-size (car mode
)))
67 (error "Zero dimensions not allowed")
70 (t (or (cdr (assq mode
'((-3 .
3) (-13 .
1) (-14 .
3) (-15 .
6))))
73 (defun calc-pack-items (mode items
)
76 (let* ((size (calc-pack-size (cdr mode
)))
81 (setq p
(nthcdr (1- size
) items
)
86 (setq new
(cons (calc-pack-items (cdr mode
) row
) new
)))
87 (calc-pack-items (car mode
) (nreverse new
)))
88 (calc-pack-items (car mode
) items
)))
92 (if (and (math-objvecp (car items
))
93 (math-objvecp (nth 1 items
))
94 (math-objvecp (nth 2 items
)))
95 (if (and (math-num-integerp (car items
))
96 (math-num-integerp (nth 1 items
)))
97 (if (math-realp (nth 2 items
))
99 (error "Seconds must be real"))
100 (error "Hours and minutes must be integers"))
101 (math-normalize (list '+
103 (if (eq calc-angle-mode
'rad
)
107 (list '* (nth 1 items
) '(hms 0 1 0)))
108 (list '* (nth 2 items
) '(hms 0 0 1))))))
110 (if (math-realp (car items
))
112 (if (eq (car-safe (car items
)) 'date
)
114 (if (math-objvecp (car items
))
115 (error "Date value must be real")
116 (cons 'calcFunc-date items
)))))
117 ((memq mode
'(-14 -
15))
119 (while (and p
(math-objvecp (car p
)))
120 (or (math-integerp (car p
))
121 (error "Components must be integers"))
124 (cons 'calcFunc-date items
)
125 (list 'date
(math-dt-to-date items
)))))
126 ((or (eq (car-safe (car items
)) 'vec
)
127 (eq (car-safe (nth 1 items
)) 'vec
))
128 (let* ((x (car items
))
129 (vx (eq (car-safe x
) 'vec
))
131 (vy (eq (car-safe y
) 'vec
))
133 (n (1- (length (if vx x y
)))))
135 (/= n
(1- (length y
)))
136 (error "Vectors must be the same length"))
137 (while (>= (setq n
(1- n
)) 0)
138 (setq z
(cons (calc-pack-items
140 (list (if vx
(car (setq x
(cdr x
))) x
)
141 (if vy
(car (setq y
(cdr y
))) y
)))
143 (cons 'vec
(nreverse z
))))
145 (if (and (math-realp (car items
)) (math-realp (nth 1 items
)))
147 (if (and (math-objectp (car items
)) (math-objectp (nth 1 items
)))
148 (error "Components must be real"))
149 (math-normalize (list '+ (car items
)
150 (list '* (nth 1 items
) '(cplx 0 1))))))
152 (if (and (math-realp (car items
)) (math-anglep (nth 1 items
)))
154 (if (and (math-objectp (car items
)) (math-objectp (nth 1 items
)))
155 (error "Components must be real"))
156 (math-normalize (list '* (car items
)
157 (if (math-anglep (nth 1 items
))
158 (list 'polar
1 (nth 1 items
))
168 (let ((x (car items
))
169 (sigma (nth 1 items
)))
170 (if (or (math-scalarp x
) (not (math-objvecp x
)))
171 (if (or (math-anglep sigma
) (not (math-objvecp sigma
)))
172 (math-make-sdev x sigma
)
173 (error "Error component must be real"))
174 (error "Mean component must be real or complex"))))
176 (let ((a (car items
))
178 (if (and (math-anglep a
) (math-anglep m
))
181 (error "Modulus must be positive"))
182 (if (and (math-objectp a
) (math-objectp m
))
183 (error "Components must be real"))
184 (list 'calcFunc-makemod a m
))))
185 ((memq mode
'(-6 -
7 -
8 -
9))
186 (let ((lo (car items
))
188 (if (and (or (math-anglep lo
) (eq (car lo
) 'date
)
189 (not (math-objvecp lo
)))
190 (or (math-anglep hi
) (eq (car hi
) 'date
)
191 (not (math-objvecp hi
))))
192 (math-make-intv (+ mode
9) lo hi
)
193 (error "Components must be real"))))
195 (if (math-zerop (nth 1 items
))
196 (error "Denominator must not be zero")
197 (if (and (math-integerp (car items
)) (math-integerp (nth 1 items
)))
198 (math-normalize (cons 'frac items
))
199 (if (and (math-objectp (car items
)) (math-objectp (nth 1 items
)))
200 (error "Components must be integers"))
201 (cons 'calcFunc-fdiv items
))))
202 ((memq mode
'(-11 -
12))
203 (if (and (math-realp (car items
)) (math-integerp (nth 1 items
)))
204 (calcFunc-scf (math-float (car items
)) (nth 1 items
))
205 (if (and (math-objectp (car items
)) (math-objectp (nth 1 items
)))
206 (error "Components must be integers"))
209 (list 'calcFunc-float
(car items
))
212 (error "Invalid packing mode: %d" mode
))))
214 (defvar calc-unpack-with-type nil
)
215 (defun calc-unpack (mode)
218 (let ((calc-unpack-with-type t
))
219 (calc-pop-push-record-list 1 "unpk" (calc-unpack-item
221 (prefix-numeric-value mode
))
224 (defun calc-unpack-type (item)
225 (cond ((eq (car-safe item
) 'vec
)
227 ((eq (car-safe item
) 'intv
)
230 (or (cdr (assq (car-safe item
) '( (cplx . -
1) (polar . -
2)
231 (hms . -
3) (sdev . -
4) (mod . -
5)
232 (frac . -
10) (float . -
11)
234 (error "Argument must be a composite object")))))
236 (defun calc-unpack-item (mode item
)
238 (if (or (and (not (memq (car-safe item
) '(frac float cplx polar vec
242 (eq (car-safe item
) 'var
))
243 (error "Argument must be a composite object or function call"))
244 (if (eq (car item
) 'intv
)
250 (setq item
(list item
))
252 (setq type
(calc-unpack-type (car item
))
253 dims
(cons type dims
)
254 new
(calc-unpack-item nil
(car item
)))
255 (while (setq item
(cdr item
))
256 (or (= (calc-unpack-type (car item
)) type
)
257 (error "Inconsistent types or dimensions in vector elements"))
258 (setq new
(append new
(calc-unpack-item nil
(car item
)))))
261 (if (cdr dims
) (setq dims
(list (cons 'vec
(nreverse dims
)))))
262 (cond ((eq calc-unpack-with-type
'pair
)
263 (list (car dims
) (cons 'vec item
)))
264 (calc-unpack-with-type
267 ((eq calc-unpack-with-type
'pair
)
268 (let ((calc-unpack-with-type nil
))
269 (list mode
(cons 'vec
(calc-unpack-item mode item
)))))
271 (if (eq (car-safe item
) 'hms
)
273 (error "Argument must be an HMS form")))
275 (if (eq (car-safe item
) 'date
)
277 (error "Argument must be a date form")))
279 (if (eq (car-safe item
) 'date
)
280 (math-date-to-dt (math-floor (nth 1 item
)))
281 (error "Argument must be a date form")))
283 (if (eq (car-safe item
) 'date
)
284 (append (math-date-to-dt (nth 1 item
))
285 (and (not (math-integerp (nth 1 item
)))
287 (error "Argument must be a date form")))
288 ((eq (car-safe item
) 'vec
)
292 (while (setq item
(cdr item
))
293 (setq res
(calc-unpack-item mode
(car item
))
295 y
(cons (nth 1 res
) y
)))
296 (list (cons 'vec
(nreverse x
))
297 (cons 'vec
(nreverse y
)))))
299 (if (eq (car-safe item
) 'cplx
)
301 (if (eq (car-safe item
) 'polar
)
302 (cdr (math-complex item
))
303 (if (Math-realp item
)
305 (error "Argument must be a complex number")))))
307 (if (or (memq (car-safe item
) '(cplx polar
))
309 (cdr (math-polar item
))
310 (error "Argument must be a complex number")))
312 (if (eq (car-safe item
) 'sdev
)
316 (if (eq (car-safe item
) 'mod
)
318 (error "Argument must be a modulo form")))
319 ((memq mode
'(-6 -
7 -
8 -
9))
320 (if (eq (car-safe item
) 'intv
)
324 (if (eq (car-safe item
) 'frac
)
326 (if (Math-integerp item
)
328 (error "Argument must be a rational number"))))
330 (if (eq (car-safe item
) 'float
)
331 (list (nth 1 item
) (math-normalize (nth 2 item
)))
332 (error "Expected a floating-point number")))
334 (if (eq (car-safe item
) 'float
)
335 (list (calcFunc-mant item
) (calcFunc-xpon item
))
336 (error "Expected a floating-point number")))
338 (error "Invalid unpacking mode: %d" mode
))))
343 (calc-enter-result 1 "diag" (if n
344 (list 'calcFunc-diag
(calc-top-n 1)
345 (prefix-numeric-value n
))
346 (list 'calcFunc-diag
(calc-top-n 1))))))
348 (defun calc-ident (n)
349 (interactive "NDimension of identity matrix = ")
351 (calc-enter-result 0 "idn" (if (eq n
0)
353 (list 'calcFunc-idn
1
354 (prefix-numeric-value n
))))))
356 (defun calc-index (n &optional stack
)
357 (interactive "NSize of vector = \nP")
360 (calc-enter-result 3 "indx" (cons 'calcFunc-index
(calc-top-list-n 3)))
361 (calc-enter-result 0 "indx" (list 'calcFunc-index
362 (prefix-numeric-value n
))))))
364 (defun calc-build-vector (n)
365 (interactive "NSize of vector = ")
367 (calc-enter-result 1 "bldv" (list 'calcFunc-cvec
369 (prefix-numeric-value n
)))))
371 (defun calc-cons (arg)
374 (if (calc-is-hyperbolic)
375 (calc-binary-op "rcns" 'calcFunc-rcons arg
)
376 (calc-binary-op "cons" 'calcFunc-cons arg
))))
379 (defun calc-head (arg)
382 (if (calc-is-inverse)
383 (if (calc-is-hyperbolic)
384 (calc-unary-op "rtai" 'calcFunc-rtail arg
)
385 (calc-unary-op "tail" 'calcFunc-tail arg
))
386 (if (calc-is-hyperbolic)
387 (calc-unary-op "rhed" 'calcFunc-rhead arg
)
388 (calc-unary-op "head" 'calcFunc-head arg
)))))
390 (defun calc-tail (arg)
395 (defun calc-vlength (arg)
398 (if (calc-is-hyperbolic)
399 (calc-unary-op "dims" 'calcFunc-mdims arg
)
400 (calc-unary-op "len" 'calcFunc-vlen arg
))))
402 (defun calc-arrange-vector (n)
403 (interactive "NNumber of columns = ")
405 (calc-enter-result 1 "arng" (list 'calcFunc-arrange
(calc-top-n 1)
406 (prefix-numeric-value n
)))))
408 (defun calc-vector-find (arg)
411 (let ((func (cons 'calcFunc-find
(calc-top-list-n 2))))
414 (if arg
(append func
(list (prefix-numeric-value arg
))) func
)))))
416 (defun calc-subvector ()
419 (if (calc-is-inverse)
420 (calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec
421 (calc-top-list-n 3)))
422 (calc-enter-result 3 "svec" (cons 'calcFunc-subvec
(calc-top-list-n 3))))))
424 (defun calc-reverse-vector (arg)
427 (calc-unary-op "rev" 'calcFunc-rev arg
)))
429 (defun calc-mask-vector (arg)
432 (calc-binary-op "vmsk" 'calcFunc-vmask arg
)))
434 (defun calc-expand-vector (arg)
437 (if (calc-is-hyperbolic)
438 (calc-enter-result 3 "vexp" (cons 'calcFunc-vexp
(calc-top-list-n 3)))
439 (calc-binary-op "vexp" 'calcFunc-vexp arg
))))
444 (if (calc-is-inverse)
445 (calc-enter-result 1 "rsrt" (list 'calcFunc-rsort
(calc-top-n 1)))
446 (calc-enter-result 1 "sort" (list 'calcFunc-sort
(calc-top-n 1))))))
451 (if (calc-is-inverse)
452 (calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade
(calc-top-n 1)))
453 (calc-enter-result 1 "grad" (list 'calcFunc-grade
(calc-top-n 1))))))
455 (defun calc-histogram (n)
456 (interactive "NNumber of bins: ")
458 (if calc-hyperbolic-flag
459 (calc-enter-result 2 "hist" (list 'calcFunc-histogram
462 (prefix-numeric-value n
)))
463 (calc-enter-result 1 "hist" (list 'calcFunc-histogram
465 (prefix-numeric-value n
))))))
467 (defun calc-transpose (arg)
470 (calc-unary-op "trn" 'calcFunc-trn arg
)))
472 (defun calc-conj-transpose (arg)
475 (calc-unary-op "ctrn" 'calcFunc-ctrn arg
)))
477 (defun calc-cross (arg)
480 (calc-binary-op "cros" 'calcFunc-cross arg
)))
482 (defun calc-remove-duplicates (arg)
485 (calc-unary-op "rdup" 'calcFunc-rdup arg
)))
487 (defun calc-set-union (arg)
490 (calc-binary-op "unio" 'calcFunc-vunion arg
'(vec) 'calcFunc-rdup
)))
492 (defun calc-set-intersect (arg)
495 (calc-binary-op "intr" 'calcFunc-vint arg
'(vec) 'calcFunc-rdup
)))
497 (defun calc-set-difference (arg)
500 (calc-binary-op "diff" 'calcFunc-vdiff arg
'(vec) 'calcFunc-rdup
)))
502 (defun calc-set-xor (arg)
505 (calc-binary-op "xor" 'calcFunc-vxor arg
'(vec) 'calcFunc-rdup
)))
507 (defun calc-set-complement (arg)
510 (calc-unary-op "cmpl" 'calcFunc-vcompl arg
)))
512 (defun calc-set-floor (arg)
515 (calc-unary-op "vflr" 'calcFunc-vfloor arg
)))
517 (defun calc-set-enumerate (arg)
520 (calc-unary-op "enum" 'calcFunc-venum arg
)))
522 (defun calc-set-span (arg)
525 (calc-unary-op "span" 'calcFunc-vspan arg
)))
527 (defun calc-set-cardinality (arg)
530 (calc-unary-op "card" 'calcFunc-vcard arg
)))
532 (defun calc-unpack-bits (arg)
535 (if (calc-is-inverse)
536 (calc-unary-op "bpck" 'calcFunc-vpack arg
)
537 (calc-unary-op "bupk" 'calcFunc-vunpack arg
))))
539 (defun calc-pack-bits (arg)
542 (calc-unpack-bits arg
))
545 (defun calc-rnorm (arg)
548 (calc-unary-op "rnrm" 'calcFunc-rnorm arg
)))
550 (defun calc-cnorm (arg)
553 (calc-unary-op "cnrm" 'calcFunc-cnorm arg
)))
555 (defun calc-mrow (n &optional nn
)
556 (interactive "NRow number: \nP")
559 (calc-enter-result 2 "mrow" (cons 'calcFunc-mrow
(calc-top-list-n 2)))
560 (setq n
(prefix-numeric-value n
))
562 (calc-enter-result 1 "getd" (list 'calcFunc-getdiag
(calc-top-n 1)))
564 (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow
565 (calc-top-n 1) (- n
)))
566 (calc-enter-result 1 "mrow" (list 'calcFunc-mrow
567 (calc-top-n 1) n
)))))))
569 (defun calc-mcol (n &optional nn
)
570 (interactive "NColumn number: \nP")
573 (calc-enter-result 2 "mcol" (cons 'calcFunc-mcol
(calc-top-list-n 2)))
574 (setq n
(prefix-numeric-value n
))
576 (calc-enter-result 1 "getd" (list 'calcFunc-getdiag
(calc-top-n 1)))
578 (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol
579 (calc-top-n 1) (- n
)))
580 (calc-enter-result 1 "mcol" (list 'calcFunc-mcol
581 (calc-top-n 1) n
)))))))
586 (defun calcFunc-mdims (m)
588 (math-reject-arg m
'vectorp
))
589 (cons 'vec
(math-mat-dimens m
)))
592 ;;; Apply a function elementwise to vector A. [V X V; N X N] [Public]
593 (defun math-map-vec (f a
)
595 (cons 'vec
(mapcar f
(cdr a
)))
598 (defun math-dimension-error ()
599 (calc-record-why "*Dimension error")
600 (signal 'wrong-type-argument nil
))
603 ;;; Build a vector out of a list of objects. [Public]
604 (defun calcFunc-vec (&rest objs
)
608 ;;; Build a constant vector or matrix. [Public]
609 (defun calcFunc-cvec (obj &rest dims
)
610 (math-make-vec-dimen obj dims
))
612 (defun math-make-vec-dimen (obj dims
)
614 (if (natnump (car dims
))
616 (not (math-numberp obj
)))
617 (cons 'vec
(copy-sequence
618 (make-list (car dims
)
619 (math-make-vec-dimen obj
(cdr dims
)))))
620 (cons 'vec
(make-list (car dims
) obj
)))
621 (math-reject-arg (car dims
) 'fixnatnump
))
624 (defun calcFunc-head (vec)
625 (if (and (Math-vectorp vec
)
628 (calc-record-why 'vectorp vec
)
629 (list 'calcFunc-head vec
)))
631 (defun calcFunc-tail (vec)
632 (if (and (Math-vectorp vec
)
634 (cons 'vec
(cdr (cdr vec
)))
635 (calc-record-why 'vectorp vec
)
636 (list 'calcFunc-tail vec
)))
638 (defun calcFunc-cons (head tail
)
639 (if (Math-vectorp tail
)
640 (cons 'vec
(cons head
(cdr tail
)))
641 (calc-record-why 'vectorp tail
)
642 (list 'calcFunc-cons head tail
)))
644 (defun calcFunc-rhead (vec)
645 (if (and (Math-vectorp vec
)
647 (let ((vec (copy-sequence vec
)))
648 (setcdr (nthcdr (- (length vec
) 2) vec
) nil
)
650 (calc-record-why 'vectorp vec
)
651 (list 'calcFunc-rhead vec
)))
653 (defun calcFunc-rtail (vec)
654 (if (and (Math-vectorp vec
)
656 (nth (1- (length vec
)) vec
)
657 (calc-record-why 'vectorp vec
)
658 (list 'calcFunc-rtail vec
)))
660 (defun calcFunc-rcons (head tail
)
661 (if (Math-vectorp head
)
662 (append head
(list tail
))
663 (calc-record-why 'vectorp head
)
664 (list 'calcFunc-rcons head tail
)))
668 ;;; Apply a function elementwise to vectors A and B. [O X O O] [Public]
669 (defun math-map-vec-2 (f a b
)
673 (while (setq a
(cdr a
))
675 (math-dimension-error))
676 (setq v
(cons (funcall f
(car a
) (car b
)) v
)))
677 (if a
(math-dimension-error))
678 (cons 'vec
(nreverse v
)))
680 (while (setq a
(cdr a
))
681 (setq v
(cons (funcall f
(car a
) b
) v
)))
682 (cons 'vec
(nreverse v
))))
685 (while (setq b
(cdr b
))
686 (setq v
(cons (funcall f a
(car b
)) v
)))
687 (cons 'vec
(nreverse v
)))
692 ;;; "Reduce" a function over a vector (left-associatively). [O X V] [Public]
693 (defun math-reduce-vec (f a
)
696 (let ((accum (car (setq a
(cdr a
)))))
697 (while (setq a
(cdr a
))
698 (setq accum
(funcall f accum
(car a
))))
703 ;;; Reduce a function over the columns of matrix A. [V X V] [Public]
704 (defun math-reduce-cols (f a
)
706 (cons 'vec
(math-reduce-cols-col-step f
(cdr a
) 1 (length (nth 1 a
))))
709 (defun math-reduce-cols-col-step (f a col cols
)
711 (cons (math-reduce-cols-row-step f
(nth col
(car a
)) col
(cdr a
))
712 (math-reduce-cols-col-step f a
(1+ col
) cols
))))
714 (defun math-reduce-cols-row-step (f tot col a
)
716 (math-reduce-cols-row-step f
717 (funcall f tot
(nth col
(car a
)))
724 (defun math-dot-product (a b
)
725 (if (setq a
(cdr a
) b
(cdr b
))
726 (let ((accum (math-mul (car a
) (car b
))))
727 (while (setq a
(cdr a
) b
(cdr b
))
728 (setq accum
(math-add accum
(math-mul (car a
) (car b
)))))
733 ;;; Return the number of elements in vector V. [Public]
734 (defun calcFunc-vlen (v)
739 (list 'calcFunc-vlen v
))))
741 ;;; Get the Nth row of a matrix.
742 (defun calcFunc-mrow (mat n
) ; [Public]
744 (math-map-vec (function (lambda (x) (calcFunc-mrow mat x
))) n
)
745 (if (and (eq (car-safe n
) 'intv
) (math-constp n
))
747 (math-add (nth 2 n
) (if (memq (nth 1 n
) '(2 3)) 0 1))
748 (math-add (nth 3 n
) (if (memq (nth 1 n
) '(1 3)) 1 0)))
749 (or (and (integerp (setq n
(math-check-integer n
)))
751 (math-reject-arg n
'fixposintp
))
752 (or (Math-vectorp mat
)
753 (math-reject-arg mat
'vectorp
))
755 (math-reject-arg n
"*Index out of range")))))
757 (defun calcFunc-subscr (mat n
&optional m
)
758 (setq mat
(calcFunc-mrow mat n
))
760 (if (math-num-integerp n
)
761 (calcFunc-mrow mat m
)
762 (calcFunc-mcol mat m
))
765 ;;; Get the Nth column of a matrix.
766 (defun math-mat-col (mat n
)
767 (cons 'vec
(mapcar (function (lambda (x) (elt x n
))) (cdr mat
))))
769 (defun calcFunc-mcol (mat n
) ; [Public]
772 (math-map-vec (function (lambda (x) (calcFunc-mcol mat x
))) n
))
773 (if (and (eq (car-safe n
) 'intv
) (math-constp n
))
774 (if (math-matrixp mat
)
775 (math-map-vec (function (lambda (x) (calcFunc-mrow x n
))) mat
)
776 (calcFunc-mrow mat n
))
777 (or (and (integerp (setq n
(math-check-integer n
)))
779 (math-reject-arg n
'fixposintp
))
780 (or (Math-vectorp mat
)
781 (math-reject-arg mat
'vectorp
))
782 (or (if (math-matrixp mat
)
783 (and (< n
(length (nth 1 mat
)))
784 (math-mat-col mat n
))
786 (math-reject-arg n
"*Index out of range")))))
788 ;;; Remove the Nth row from a matrix.
789 (defun math-mat-less-row (mat n
)
793 (math-mat-less-row (cdr mat
) (1- n
)))))
795 (defun calcFunc-mrrow (mat n
) ; [Public]
796 (and (integerp (setq n
(math-check-integer n
)))
799 (math-mat-less-row mat n
)))
801 ;;; Remove the Nth column from a matrix.
802 (defun math-mat-less-col (mat n
)
803 (cons 'vec
(mapcar (function (lambda (x) (math-mat-less-row x n
)))
806 (defun calcFunc-mrcol (mat n
) ; [Public]
807 (and (integerp (setq n
(math-check-integer n
)))
809 (if (math-matrixp mat
)
810 (and (< n
(length (nth 1 mat
)))
811 (math-mat-less-col mat n
))
812 (math-mat-less-row mat n
))))
814 (defun calcFunc-getdiag (mat) ; [Public]
815 (if (math-square-matrixp mat
)
816 (cons 'vec
(math-get-diag-step (cdr mat
) 1))
817 (calc-record-why 'square-matrixp mat
)
818 (list 'calcFunc-getdiag mat
)))
820 (defun math-get-diag-step (row n
)
822 (cons (nth n
(car row
))
823 (math-get-diag-step (cdr row
) (1+ n
)))))
825 (defun math-transpose (mat) ; [Public]
827 (col (length (nth 1 mat
))))
828 (while (> (setq col
(1- col
)) 0)
829 (setq m
(cons (math-mat-col mat col
) m
)))
832 (defun calcFunc-trn (mat)
833 (if (math-vectorp mat
)
834 (if (math-matrixp mat
)
836 (math-col-matrix mat
))
837 (if (math-numberp mat
)
839 (math-reject-arg mat
'matrixp
))))
841 (defun calcFunc-ctrn (mat)
842 (calcFunc-conj (calcFunc-trn mat
)))
844 (defun calcFunc-pack (mode els
)
845 (or (Math-vectorp els
) (math-reject-arg els
'vectorp
))
846 (if (and (Math-vectorp mode
) (cdr mode
))
847 (setq mode
(cdr mode
))
848 (or (integerp mode
) (math-reject-arg mode
'fixnump
)))
850 (if (= (calc-pack-size mode
) (1- (length els
)))
851 (calc-pack-items mode
(cdr els
))
852 (math-reject-arg els
"*Wrong number of elements"))
853 (error (math-reject-arg els
(nth 1 err
)))))
855 (defun calcFunc-unpack (mode thing
)
856 (or (integerp mode
) (math-reject-arg mode
'fixnump
))
858 (cons 'vec
(calc-unpack-item mode thing
))
859 (error (math-reject-arg thing
(nth 1 err
)))))
861 (defun calcFunc-unpackt (mode thing
)
862 (let ((calc-unpack-with-type 'pair
))
863 (calcFunc-unpack mode thing
)))
865 (defun calcFunc-arrange (vec cols
) ; [Public]
866 (setq cols
(math-check-fixnum cols t
))
867 (if (math-vectorp vec
)
868 (let* ((flat (math-flatten-vector vec
))
873 (while (>= (length flat
) cols
)
874 (setq next
(nthcdr cols flat
))
875 (setcdr (nthcdr (1- cols
) flat
) nil
)
876 (setq mat
(nconc mat
(list (cons 'vec flat
)))
879 (setq mat
(nconc mat
(list (cons 'vec flat
)))))
882 (defun math-flatten-vector (vec) ; [L V]
883 (if (math-vectorp vec
)
884 (apply 'append
(mapcar 'math-flatten-vector
(cdr vec
)))
887 (defun calcFunc-vconcat (a b
)
888 (math-normalize (list '| a b
)))
890 (defun calcFunc-vconcatrev (a b
)
891 (math-normalize (list '| b a
)))
893 (defun calcFunc-append (v1 v2
)
894 (if (and (math-vectorp v1
) (math-vectorp v2
))
896 (list 'calcFunc-append v1 v2
)))
898 (defun calcFunc-appendrev (v1 v2
)
899 (calcFunc-append v2 v1
))
902 ;;; Copy a matrix. [Public]
903 (defun math-copy-matrix (m)
904 (if (math-vectorp (nth 1 m
))
905 (cons 'vec
(mapcar 'copy-sequence
(cdr m
)))
908 ;;; Convert a scalar or vector into an NxN diagonal matrix. [Public]
909 (defun calcFunc-diag (a &optional n
)
910 (and n
(not (integerp n
))
911 (setq n
(math-check-fixnum n
)))
913 (if (and n
(/= (length a
) (1+ n
)))
914 (list 'calcFunc-diag a n
)
916 (if (and n
(/= (length (elt a
1)) (1+ n
)))
917 (list 'calcFunc-diag a n
)
919 (cons 'vec
(math-diag-step (cdr a
) 0 (1- (length a
))))))
921 (cons 'vec
(math-diag-step (make-list n a
) 0 n
))
922 (list 'calcFunc-diag a
))))
924 (defun calcFunc-idn (a &optional n
)
927 (math-reject-arg a
'numberp
)
929 (if (integerp calc-matrix-mode
)
930 (calcFunc-idn a calc-matrix-mode
)
931 (list 'calcFunc-idn a
))))
933 (defun math-mimic-ident (a m
)
934 (if (math-square-matrixp m
)
935 (calcFunc-idn a
(1- (length m
)))
938 (cons 'vec
(mapcar (function (lambda (x)
940 (math-mimic-ident a x
)
943 (math-dimension-error))
946 (defun math-diag-step (a n m
)
949 (nconc (make-list n
0)
951 (make-list (1- (- m n
)) 0))))
952 (math-diag-step (cdr a
) (1+ n
) m
))
955 ;;; Create a vector of consecutive integers. [Public]
956 (defun calcFunc-index (n &optional start incr
)
957 (if (math-messy-integerp n
)
958 (math-float (calcFunc-index (math-trunc n
) start incr
))
959 (and (not (integerp n
))
960 (setq n
(math-check-fixnum n
)))
965 (while (>= (setq n
(1- n
)) 0)
966 (setq vec
(cons start vec
)
967 start
(math-add start
(or incr
1))))
968 (while (<= (setq n
(1+ n
)) 0)
969 (setq vec
(cons start vec
)
970 start
(math-mul start
(or incr
2)))))
971 (setq vec
(nreverse vec
)))
974 (setq vec
(cons n vec
)
978 (setq vec
(cons i vec
)
982 ;;; Find an element in a vector.
983 (defun calcFunc-find (vec x
&optional start
)
984 (setq start
(if start
(math-check-fixnum start t
) 1))
985 (if (< start
1) (math-reject-arg start
'posp
))
986 (setq vec
(nthcdr start vec
))
988 (while (and vec
(not (Math-equal x
(car vec
))))
993 ;;; Return a subvector of a vector.
994 (defun calcFunc-subvec (vec start
&optional end
)
995 (setq start
(math-check-fixnum start t
)
996 end
(math-check-fixnum (or end
0) t
))
997 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
998 (let ((len (1- (length vec
))))
1000 (setq start
(+ len start
1)))
1002 (setq end
(+ len end
1)))
1003 (if (or (> start len
)
1006 (setq vec
(nthcdr start vec
))
1008 (let ((chop (nthcdr (- end start
1) (setq vec
(copy-sequence vec
)))))
1012 ;;; Remove a subvector from a vector.
1013 (defun calcFunc-rsubvec (vec start
&optional end
)
1014 (setq start
(math-check-fixnum start t
)
1015 end
(math-check-fixnum (or end
0) t
))
1016 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
1017 (let ((len (1- (length vec
))))
1019 (setq start
(+ len start
1)))
1021 (setq end
(+ len end
1)))
1022 (if (or (> start len
)
1025 (let ((tail (nthcdr end vec
))
1026 (chop (nthcdr (1- start
) (setq vec
(copy-sequence vec
)))))
1028 (append vec tail
)))))
1030 ;;; Reverse the order of the elements of a vector.
1031 (defun calcFunc-rev (vec)
1032 (if (math-vectorp vec
)
1033 (cons 'vec
(reverse (cdr vec
)))
1034 (math-reject-arg vec
'vectorp
)))
1036 ;;; Compress a vector according to a mask vector.
1037 (defun calcFunc-vmask (mask vec
)
1038 (if (math-numberp mask
)
1039 (if (math-zerop mask
)
1042 (or (math-vectorp mask
) (math-reject-arg mask
'vectorp
))
1043 (or (math-constp mask
) (math-reject-arg mask
'constp
))
1044 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
1045 (or (= (length mask
) (length vec
)) (math-dimension-error))
1047 (while (setq mask
(cdr mask
) vec
(cdr vec
))
1048 (or (math-zerop (car mask
))
1049 (setq new
(cons (car vec
) new
))))
1050 (cons 'vec
(nreverse new
)))))
1052 ;;; Expand a vector according to a mask vector.
1053 (defun calcFunc-vexp (mask vec
&optional filler
)
1054 (or (math-vectorp mask
) (math-reject-arg mask
'vectorp
))
1055 (or (math-constp mask
) (math-reject-arg mask
'constp
))
1056 (or (math-vectorp vec
) (math-reject-arg vec
'vectorp
))
1058 (fvec (and filler
(math-vectorp filler
))))
1059 (while (setq mask
(cdr mask
))
1060 (if (math-zerop (car mask
))
1061 (setq new
(cons (or (if fvec
1062 (car (setq filler
(cdr filler
)))
1066 new
(cons (or (car vec
) (car mask
)) new
))))
1067 (cons 'vec
(nreverse new
))))
1070 ;;; Compute the row and column norms of a vector or matrix. [Public]
1071 (defun calcFunc-rnorm (a)
1072 (if (and (Math-vectorp a
)
1074 (if (math-matrixp a
)
1075 (math-reduce-vec 'math-max
(math-map-vec 'calcFunc-cnorm a
))
1076 (math-reduce-vec 'math-max
(math-map-vec 'math-abs a
)))
1077 (calc-record-why 'vectorp a
)
1078 (list 'calcFunc-rnorm a
)))
1080 (defun calcFunc-cnorm (a)
1081 (if (and (Math-vectorp a
)
1083 (if (math-matrixp a
)
1084 (math-reduce-vec 'math-max
1085 (math-reduce-cols 'math-add-abs a
))
1086 (math-reduce-vec 'math-add-abs a
))
1087 (calc-record-why 'vectorp a
)
1088 (list 'calcFunc-cnorm a
)))
1090 (defun math-add-abs (a b
)
1091 (math-add (math-abs a
) (math-abs b
)))
1094 ;;; Sort the elements of a vector into increasing order.
1095 (defun calcFunc-sort (vec) ; [Public]
1096 (if (math-vectorp vec
)
1097 (cons 'vec
(sort (copy-sequence (cdr vec
)) 'math-beforep
))
1098 (math-reject-arg vec
'vectorp
)))
1100 (defun calcFunc-rsort (vec) ; [Public]
1101 (if (math-vectorp vec
)
1102 (cons 'vec
(nreverse (sort (copy-sequence (cdr vec
)) 'math-beforep
)))
1103 (math-reject-arg vec
'vectorp
)))
1105 ;; The variable math-grade-vec is local to calcFunc-grade and
1106 ;; calcFunc-rgrade, but is used by math-grade-beforep, which is called
1107 ;; by calcFunc-grade and calcFunc-rgrade.
1108 (defvar math-grade-vec
)
1110 (defun calcFunc-grade (math-grade-vec)
1111 (if (math-vectorp math-grade-vec
)
1112 (let* ((len (1- (length math-grade-vec
))))
1113 (cons 'vec
(sort (cdr (calcFunc-index len
)) 'math-grade-beforep
)))
1114 (math-reject-arg math-grade-vec
'vectorp
)))
1116 (defun calcFunc-rgrade (math-grade-vec)
1117 (if (math-vectorp math-grade-vec
)
1118 (let* ((len (1- (length math-grade-vec
))))
1119 (cons 'vec
(nreverse (sort (cdr (calcFunc-index len
))
1120 'math-grade-beforep
))))
1121 (math-reject-arg math-grade-vec
'vectorp
)))
1123 (defun math-grade-beforep (i j
)
1124 (math-beforep (nth i math-grade-vec
) (nth j math-grade-vec
)))
1127 ;;; Compile a histogram of data from a vector.
1128 (defun calcFunc-histogram (vec wts
&optional n
)
1129 (or n
(setq n wts wts
1))
1130 (or (Math-vectorp vec
)
1131 (math-reject-arg vec
'vectorp
))
1132 (if (Math-vectorp wts
)
1133 (or (= (length vec
) (length wts
))
1134 (math-dimension-error)))
1136 (math-reject-arg n
'fixnatnump
))
1137 (let ((res (make-vector n
0))
1139 (wvec (Math-vectorp wts
))
1142 (while (setq vp
(cdr vp
))
1145 (setq bin
(math-floor bin
)))
1148 (aset res bin
(math-add (aref res bin
)
1149 (if wvec
(car (setq wp
(cdr wp
))) wts
)))))
1150 (cons 'vec
(append res nil
))))
1155 (defun calcFunc-vunion (a b
)
1156 (if (Math-objectp a
)
1157 (setq a
(list 'vec a
))
1158 (or (math-vectorp a
) (math-reject-arg a
'vectorp
)))
1159 (if (Math-objectp b
)
1161 (or (math-vectorp b
) (math-reject-arg b
'vectorp
))
1163 (calcFunc-rdup (append a b
)))
1165 (defun calcFunc-vint (a b
)
1166 (if (and (math-simple-set a
) (math-simple-set b
))
1168 (setq a
(cdr (calcFunc-rdup a
)))
1169 (setq b
(cdr (calcFunc-rdup b
)))
1170 (let ((vec (list 'vec
)))
1172 (if (math-beforep (car a
) (car b
))
1174 (if (Math-equal (car a
) (car b
))
1175 (setq vec
(cons (car a
) vec
)
1179 (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a
)
1180 (calcFunc-vcompl b
)))))
1182 (defun calcFunc-vdiff (a b
)
1183 (if (and (math-simple-set a
) (math-simple-set b
))
1185 (setq a
(cdr (calcFunc-rdup a
)))
1186 (setq b
(cdr (calcFunc-rdup b
)))
1187 (let ((vec (list 'vec
)))
1189 (while (and b
(math-beforep (car b
) (car a
)))
1191 (if (and b
(Math-equal (car a
) (car b
)))
1194 (setq vec
(cons (car a
) vec
)
1197 (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a
) b
))))
1199 (defun calcFunc-vxor (a b
)
1200 (if (and (math-simple-set a
) (math-simple-set b
))
1202 (setq a
(cdr (calcFunc-rdup a
)))
1203 (setq b
(cdr (calcFunc-rdup b
)))
1204 (let ((vec (list 'vec
)))
1208 (math-beforep (car a
) (car b
))))
1209 (setq vec
(cons (car a
) vec
)
1211 (if (and a
(Math-equal (car a
) (car b
)))
1213 (setq vec
(cons (car b
) vec
)))
1216 (let ((ca (calcFunc-vcompl a
))
1217 (cb (calcFunc-vcompl b
)))
1218 (calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b
))
1219 (calcFunc-vcompl (calcFunc-vunion a cb
))))))
1221 (defun calcFunc-vcompl (a)
1222 (setq a
(math-prepare-set a
))
1223 (let ((vec (list 'vec
))
1224 (prev '(neg (var inf var-inf
)))
1226 (while (setq a
(cdr a
))
1227 (or (and (equal (nth 2 (car a
)) '(neg (var inf var-inf
)))
1228 (memq (nth 1 (car a
)) '(2 3)))
1229 (setq vec
(cons (list 'intv
1231 (if (memq (nth 1 (car a
)) '(0 1)) 1 0))
1235 (setq prev
(nth 3 (car a
))
1236 closed
(if (memq (nth 1 (car a
)) '(0 2)) 2 0)))
1237 (or (and (equal prev
'(var inf var-inf
))
1239 (setq vec
(cons (list 'intv
(+ closed
1)
1240 prev
'(var inf var-inf
))
1242 (math-clean-set (nreverse vec
))))
1244 (defun calcFunc-vspan (a)
1245 (setq a
(math-prepare-set a
))
1247 (let ((last (nth (1- (length a
)) a
)))
1248 (math-make-intv (+ (logand (nth 1 (nth 1 a
)) 2)
1249 (logand (nth 1 last
) 1))
1254 (defun calcFunc-vfloor (a &optional always-vec
)
1255 (setq a
(math-prepare-set a
))
1256 (let ((vec (list 'vec
)) (p a
) (prev nil
) b mask
)
1257 (while (setq p
(cdr p
))
1258 (setq mask
(nth 1 (car p
))
1261 (and (memq mask
'(0 1))
1262 (not (math-infinitep a
))
1263 (setq mask
(logior mask
2))
1264 (math-num-integerp a
)
1265 (setq a
(math-add a
1)))
1266 (setq a
(math-ceiling a
))
1267 (and (memq mask
'(0 2))
1268 (not (math-infinitep b
))
1269 (setq mask
(logior mask
1))
1270 (math-num-integerp b
)
1271 (setq b
(math-sub b
1)))
1272 (setq b
(math-floor b
))
1273 (if (and prev
(Math-equal (math-sub a
1) (nth 3 prev
)))
1274 (setcar (nthcdr 3 prev
) b
)
1275 (or (Math-lessp b a
)
1276 (setq vec
(cons (setq prev
(list 'intv mask a b
)) vec
)))))
1277 (setq vec
(nreverse vec
))
1278 (math-clean-set vec always-vec
)))
1280 (defun calcFunc-vcard (a)
1281 (setq a
(calcFunc-vfloor a t
))
1282 (or (math-constp a
) (math-reject-arg a
"*Set must be finite"))
1284 (while (setq a
(cdr a
))
1285 (if (eq (car-safe (car a
)) 'intv
)
1286 (setq count
(math-add count
(math-sub (nth 3 (car a
))
1288 (setq count
(math-add count
1)))
1291 (defun calcFunc-venum (a)
1292 (setq a
(calcFunc-vfloor a t
))
1293 (or (math-constp a
) (math-reject-arg a
"*Set must be finite"))
1297 (if (eq (car-safe (nth 1 p
)) 'intv
)
1298 (setcdr p
(nconc (cdr (calcFunc-index (math-add
1299 (math-sub (nth 3 (nth 1 p
))
1307 (defun calcFunc-vpack (a)
1308 (setq a
(calcFunc-vfloor a t
))
1310 (math-negp (if (eq (car-safe (nth 1 a
)) 'intv
)
1313 (math-reject-arg (nth 1 a
) 'posp
))
1315 (while (setq a
(cdr a
))
1316 (if (eq (car-safe (car a
)) 'intv
)
1317 (if (equal (nth 3 (car a
)) '(var inf var-inf
))
1318 (setq accum
(math-sub accum
1319 (math-power-of-2 (nth 2 (car a
)))))
1320 (setq accum
(math-add accum
1322 (math-power-of-2 (1+ (nth 3 (car a
))))
1323 (math-power-of-2 (nth 2 (car a
)))))))
1324 (setq accum
(math-add accum
(math-power-of-2 (car a
))))))
1327 (defun calcFunc-vunpack (a &optional w
)
1328 (or (math-num-integerp a
) (math-reject-arg a
'integerp
))
1329 (if w
(setq a
(math-clip a w
)))
1330 (if (math-messy-integerp a
) (setq a
(math-trunc a
)))
1331 (let* ((calc-number-radix 2)
1333 (aa (if neg
(math-sub -
1 a
) a
))
1337 (math-format-bignum-binary (cdr aa
))
1338 (math-format-binary aa
))))
1339 (zero (if neg ?
1 ?
0))
1340 (one (if neg ?
0 ?
1))
1343 (pos (1- len
)) pos2
)
1345 (if (eq (aref str pos
) zero
)
1348 (while (and (>= pos
0) (eq (aref str pos
) one
))
1349 (setq pos
(1- pos
)))
1350 (setq vec
(cons (if (= pos
(1- pos2
))
1352 (list 'intv
3 (- len pos2
1) (- len pos
2)))
1355 (setq vec
(cons (list 'intv
2 len
'(var inf var-inf
)) vec
)))
1356 (math-clean-set (nreverse vec
))))
1358 (defun calcFunc-rdup (a)
1359 (if (math-simple-set a
)
1361 (and (Math-objectp a
) (setq a
(list 'vec a
)))
1362 (or (math-vectorp a
) (math-reject-arg a
'vectorp
))
1363 (setq a
(sort (copy-sequence (cdr a
)) 'math-beforep
))
1366 (if (Math-equal (car p
) (nth 1 p
))
1367 (setcdr p
(cdr (cdr p
)))
1370 (math-clean-set (math-prepare-set a
))))
1372 (defun math-prepare-set (a)
1373 (if (Math-objectp a
)
1374 (setq a
(list 'vec a
))
1375 (or (math-vectorp a
) (math-reject-arg a
'vectorp
))
1376 (setq a
(cons 'vec
(sort (copy-sequence (cdr a
)) 'math-beforep
))))
1379 ;; Convert all elements to non-empty intervals.
1381 (if (eq (car-safe (nth 1 p
)) 'intv
)
1382 (if (math-intv-constp (nth 1 p
))
1383 (if (and (memq (nth 1 (nth 1 p
)) '(0 1 2))
1384 (Math-equal (nth 2 (nth 1 p
)) (nth 3 (nth 1 p
))))
1385 (setcdr p
(cdr (cdr p
)))
1387 (math-reject-arg (nth 1 p
) 'constp
))
1388 (or (Math-anglep (nth 1 p
))
1389 (eq (car (nth 1 p
)) 'date
)
1390 (equal (nth 1 p
) '(var inf var-inf
))
1391 (equal (nth 1 p
) '(neg (var inf var-inf
)))
1392 (math-reject-arg (nth 1 p
) 'realp
))
1393 (setcar (cdr p
) (list 'intv
3 (nth 1 p
) (nth 1 p
)))
1396 ;; Combine redundant intervals.
1398 (while (cdr (cdr p
))
1399 (if (or (memq (setq res
(math-compare (nth 3 (nth 1 p
))
1403 (memq (nth 1 (nth 1 p
)) '(0 2))
1404 (memq (nth 1 (nth 2 p
)) '(0 1))))
1406 (setq res
(math-compare (nth 3 (nth 1 p
)) (nth 3 (nth 2 p
))))
1407 (setcdr p
(cons (list 'intv
1408 (+ (logand (logior (nth 1 (nth 1 p
))
1415 (logand (logior (if (memq res
'(1 0 2))
1416 (nth 1 (nth 1 p
)) 0)
1417 (if (memq res
'(-1 0 2))
1418 (nth 1 (nth 2 p
)) 0))
1424 (cdr (cdr (cdr p
))))))))
1427 (defun math-clean-set (a &optional always-vec
)
1430 (if (and (eq (car-safe (nth 1 p
)) 'intv
)
1431 (Math-equal (nth 2 (nth 1 p
)) (nth 3 (nth 1 p
))))
1432 (setcar (cdr p
) (nth 2 (nth 1 p
))))
1434 (if (and (not (cdr (cdr a
)))
1435 (eq (car-safe (nth 1 a
)) 'intv
)
1440 (defun math-simple-set (a)
1441 (or (and (Math-objectp a
)
1442 (not (eq (car-safe a
) 'intv
)))
1443 (and (Math-vectorp a
)
1445 (while (and (setq a
(cdr a
))
1446 (not (eq (car-safe (car a
)) 'intv
))))
1452 ;;; Compute a right-handed vector cross product. [O O O] [Public]
1453 (defun calcFunc-cross (a b
)
1454 (if (and (eq (car-safe a
) 'vec
)
1456 (if (and (eq (car-safe b
) 'vec
)
1459 (math-sub (math-mul (nth 2 a
) (nth 3 b
))
1460 (math-mul (nth 3 a
) (nth 2 b
)))
1461 (math-sub (math-mul (nth 3 a
) (nth 1 b
))
1462 (math-mul (nth 1 a
) (nth 3 b
)))
1463 (math-sub (math-mul (nth 1 a
) (nth 2 b
))
1464 (math-mul (nth 2 a
) (nth 1 b
))))
1465 (math-reject-arg b
"*Three-vector expected"))
1466 (math-reject-arg a
"*Three-vector expected")))
1470 ;; The variable math-rb-close is local to math-read-brackets, but
1471 ;; is used by math-read-vector, which is called (directly and
1472 ;; indirectly) by math-read-brackets.
1473 (defvar math-rb-close
)
1475 ;; The next few variables are local to math-read-exprs in calc-aent.el
1476 ;; and math-read-expr in calc-ext.el, but are set in functions they call.
1477 (defvar math-exp-pos
)
1478 (defvar math-exp-str
)
1479 (defvar math-exp-old-pos
)
1480 (defvar math-exp-token
)
1481 (defvar math-exp-keep-spaces
)
1482 (defvar math-expr-data
)
1484 (defun math-read-brackets (space-sep math-rb-close
)
1485 (and space-sep
(setq space-sep
(not (math-check-for-commas))))
1487 (while (eq math-exp-token
'space
)
1489 (if (or (equal math-expr-data math-rb-close
)
1490 (eq math-exp-token
'end
))
1494 (let ((save-exp-pos math-exp-pos
)
1495 (save-exp-old-pos math-exp-old-pos
)
1496 (save-exp-token math-exp-token
)
1497 (save-exp-data math-expr-data
)
1498 (vals (let ((math-exp-keep-spaces space-sep
))
1499 (if (or (equal math-expr-data
"\\dots")
1500 (equal math-expr-data
"\\ldots"))
1501 '(vec (neg (var inf var-inf
)))
1502 (catch 'syntax
(math-read-vector))))))
1505 (let ((error-exp-pos math-exp-pos
)
1506 (error-exp-old-pos math-exp-old-pos
)
1508 (setq math-exp-pos save-exp-pos
1509 math-exp-old-pos save-exp-old-pos
1510 math-exp-token save-exp-token
1511 math-expr-data save-exp-data
)
1512 (let ((math-exp-keep-spaces nil
))
1513 (setq vals2
(catch 'syntax
(math-read-vector))))
1514 (if (and (not (stringp vals2
))
1515 (or (assoc math-expr-data
'(("\\ldots") ("\\dots") (";")))
1516 (equal math-expr-data math-rb-close
)
1517 (eq math-exp-token
'end
)))
1520 (setq math-exp-pos error-exp-pos
1521 math-exp-old-pos error-exp-old-pos
)
1522 (throw 'syntax vals
)))
1523 (throw 'syntax vals
)))
1524 (if (or (equal math-expr-data
"\\dots")
1525 (equal math-expr-data
"\\ldots"))
1528 (setq vals
(if (> (length vals
) 2)
1529 (cons 'calcFunc-mul
(cdr vals
)) (nth 1 vals
)))
1530 (let ((exp2 (if (or (equal math-expr-data math-rb-close
)
1531 (equal math-expr-data
")")
1532 (eq math-exp-token
'end
))
1534 (math-read-expr-level 0))))
1537 (if (equal math-expr-data
")") 2 3)
1540 (if (not (or (equal math-expr-data math-rb-close
)
1541 (equal math-expr-data
")")
1542 (eq math-exp-token
'end
)))
1543 (throw 'syntax
"Expected `]'")))
1544 (if (equal math-expr-data
";")
1545 (let ((math-exp-keep-spaces space-sep
))
1546 (setq vals
(cons 'vec
(math-read-matrix (list vals
))))))
1547 (if (not (or (equal math-expr-data math-rb-close
)
1548 (eq math-exp-token
'end
)))
1549 (throw 'syntax
"Expected `]'")))
1550 (or (eq math-exp-token
'end
)
1554 (defun math-check-for-commas (&optional balancing
)
1556 (pos (1- math-exp-pos
)))
1557 (while (and (>= count
0)
1558 (setq pos
(string-match
1559 (if balancing
"[],[{}()<>]" "[],[{}()]")
1560 math-exp-str
(1+ pos
)))
1561 (or (/= (aref math-exp-str pos
) ?
,) (> count
0) balancing
))
1562 (cond ((memq (aref math-exp-str pos
) '(?\
[ ?\
{ ?\
( ?\
<))
1563 (setq count
(1+ count
)))
1564 ((memq (aref math-exp-str pos
) '(?\
] ?\
} ?\
) ?\
>))
1565 (setq count
(1- count
)))))
1568 (and pos
(= (aref math-exp-str pos
) ?
,)))))
1570 (defun math-read-vector ()
1571 (let* ((val (list (math-read-expr-level 0)))
1574 (while (eq math-exp-token
'space
)
1576 (and (not (eq math-exp-token
'end
))
1577 (not (equal math-expr-data
";"))
1578 (not (equal math-expr-data math-rb-close
))
1579 (not (equal math-expr-data
"\\dots"))
1580 (not (equal math-expr-data
"\\ldots"))))
1581 (if (equal math-expr-data
",")
1583 (while (eq math-exp-token
'space
)
1585 (let ((rest (list (math-read-expr-level 0))))
1590 (defun math-read-matrix (mat)
1591 (while (equal math-expr-data
";")
1593 (while (eq math-exp-token
'space
)
1595 (setq mat
(nconc mat
(list (math-read-vector)))))
1600 ;;; arch-tag: 7902a7af-ec69-440a-8635-ebb4db263402
1601 ;;; calc-vec.el ends here