1 |
;; Calculator for GNU Emacs, part II [calc-vec.el] |
;; Calculator for GNU Emacs, part II [calc-vec.el] |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
34 |
(calc-wrapper |
(calc-wrapper |
35 |
(message (if (calc-change-mode 'calc-display-strings n t t) |
(message (if (calc-change-mode 'calc-display-strings n t t) |
36 |
"Displaying vectors of integers as quoted strings." |
"Displaying vectors of integers as quoted strings." |
37 |
"Displaying vectors of integers normally."))) |
"Displaying vectors of integers normally.")))) |
|
) |
|
38 |
|
|
39 |
|
|
40 |
(defun calc-pack (n) |
(defun calc-pack (n) |
47 |
(error "Packing mode must be an integer or vector of integers")))) |
(error "Packing mode must be an integer or vector of integers")))) |
48 |
(num (calc-pack-size mode)) |
(num (calc-pack-size mode)) |
49 |
(items (calc-top-list num nn))) |
(items (calc-top-list num nn))) |
50 |
(calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items)))) |
(calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items))))) |
|
) |
|
51 |
|
|
52 |
(defun calc-pack-size (mode) |
(defun calc-pack-size (mode) |
53 |
(cond ((consp mode) |
(cond ((consp mode) |
61 |
size))) |
size))) |
62 |
((>= mode 0) mode) |
((>= mode 0) mode) |
63 |
(t (or (cdr (assq mode '((-3 . 3) (-13 . 1) (-14 . 3) (-15 . 6)))) |
(t (or (cdr (assq mode '((-3 . 3) (-13 . 1) (-14 . 3) (-15 . 6)))) |
64 |
2))) |
2)))) |
|
) |
|
65 |
|
|
66 |
(defun calc-pack-items (mode items) |
(defun calc-pack-items (mode items) |
67 |
(cond ((consp mode) |
(cond ((consp mode) |
202 |
(list 'calcFunc-float (car items)) |
(list 'calcFunc-float (car items)) |
203 |
(nth 1 items))))) |
(nth 1 items))))) |
204 |
(t |
(t |
205 |
(error "Invalid packing mode: %d" mode))) |
(error "Invalid packing mode: %d" mode)))) |
|
) |
|
206 |
|
|
207 |
(defun calc-unpack (mode) |
(defun calc-unpack (mode) |
208 |
(interactive "P") |
(interactive "P") |
211 |
(calc-pop-push-record-list 1 "unpk" (calc-unpack-item |
(calc-pop-push-record-list 1 "unpk" (calc-unpack-item |
212 |
(and mode |
(and mode |
213 |
(prefix-numeric-value mode)) |
(prefix-numeric-value mode)) |
214 |
(calc-top))))) |
(calc-top)))))) |
|
) |
|
215 |
|
|
216 |
(defun calc-unpack-type (item) |
(defun calc-unpack-type (item) |
217 |
(cond ((eq (car-safe item) 'vec) |
(cond ((eq (car-safe item) 'vec) |
223 |
(hms . -3) (sdev . -4) (mod . -5) |
(hms . -3) (sdev . -4) (mod . -5) |
224 |
(frac . -10) (float . -11) |
(frac . -10) (float . -11) |
225 |
(date . -13) ))) |
(date . -13) ))) |
226 |
(error "Argument must be a composite object")))) |
(error "Argument must be a composite object"))))) |
|
) |
|
227 |
|
|
228 |
(defun calc-unpack-item (mode item) |
(defun calc-unpack-item (mode item) |
229 |
(cond ((not mode) |
(cond ((not mode) |
327 |
(list (calcFunc-mant item) (calcFunc-xpon item)) |
(list (calcFunc-mant item) (calcFunc-xpon item)) |
328 |
(error "Expected a floating-point number"))) |
(error "Expected a floating-point number"))) |
329 |
(t |
(t |
330 |
(error "Invalid unpacking mode: %d" mode))) |
(error "Invalid unpacking mode: %d" mode)))) |
|
) |
|
331 |
(setq calc-unpack-with-type nil) |
(setq calc-unpack-with-type nil) |
332 |
|
|
333 |
(defun calc-diag (n) |
(defun calc-diag (n) |
336 |
(calc-enter-result 1 "diag" (if n |
(calc-enter-result 1 "diag" (if n |
337 |
(list 'calcFunc-diag (calc-top-n 1) |
(list 'calcFunc-diag (calc-top-n 1) |
338 |
(prefix-numeric-value n)) |
(prefix-numeric-value n)) |
339 |
(list 'calcFunc-diag (calc-top-n 1))))) |
(list 'calcFunc-diag (calc-top-n 1)))))) |
|
) |
|
340 |
|
|
341 |
(defun calc-ident (n) |
(defun calc-ident (n) |
342 |
(interactive "NDimension of identity matrix = ") |
(interactive "NDimension of identity matrix = ") |
344 |
(calc-enter-result 0 "idn" (if (eq n 0) |
(calc-enter-result 0 "idn" (if (eq n 0) |
345 |
'(calcFunc-idn 1) |
'(calcFunc-idn 1) |
346 |
(list 'calcFunc-idn 1 |
(list 'calcFunc-idn 1 |
347 |
(prefix-numeric-value n))))) |
(prefix-numeric-value n)))))) |
|
) |
|
348 |
|
|
349 |
(defun calc-index (n &optional stack) |
(defun calc-index (n &optional stack) |
350 |
(interactive "NSize of vector = \nP") |
(interactive "NSize of vector = \nP") |
352 |
(if (consp stack) |
(if (consp stack) |
353 |
(calc-enter-result 3 "indx" (cons 'calcFunc-index (calc-top-list-n 3))) |
(calc-enter-result 3 "indx" (cons 'calcFunc-index (calc-top-list-n 3))) |
354 |
(calc-enter-result 0 "indx" (list 'calcFunc-index |
(calc-enter-result 0 "indx" (list 'calcFunc-index |
355 |
(prefix-numeric-value n))))) |
(prefix-numeric-value n)))))) |
|
) |
|
356 |
|
|
357 |
(defun calc-build-vector (n) |
(defun calc-build-vector (n) |
358 |
(interactive "NSize of vector = ") |
(interactive "NSize of vector = ") |
359 |
(calc-wrapper |
(calc-wrapper |
360 |
(calc-enter-result 1 "bldv" (list 'calcFunc-cvec |
(calc-enter-result 1 "bldv" (list 'calcFunc-cvec |
361 |
(calc-top-n 1) |
(calc-top-n 1) |
362 |
(prefix-numeric-value n)))) |
(prefix-numeric-value n))))) |
|
) |
|
363 |
|
|
364 |
(defun calc-cons (arg) |
(defun calc-cons (arg) |
365 |
(interactive "P") |
(interactive "P") |
366 |
(calc-wrapper |
(calc-wrapper |
367 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
368 |
(calc-binary-op "rcns" 'calcFunc-rcons arg) |
(calc-binary-op "rcns" 'calcFunc-rcons arg) |
369 |
(calc-binary-op "cons" 'calcFunc-cons arg))) |
(calc-binary-op "cons" 'calcFunc-cons arg)))) |
|
) |
|
370 |
|
|
371 |
|
|
372 |
(defun calc-head (arg) |
(defun calc-head (arg) |
378 |
(calc-unary-op "tail" 'calcFunc-tail arg)) |
(calc-unary-op "tail" 'calcFunc-tail arg)) |
379 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
380 |
(calc-unary-op "rhed" 'calcFunc-rhead arg) |
(calc-unary-op "rhed" 'calcFunc-rhead arg) |
381 |
(calc-unary-op "head" 'calcFunc-head arg)))) |
(calc-unary-op "head" 'calcFunc-head arg))))) |
|
) |
|
382 |
|
|
383 |
(defun calc-tail (arg) |
(defun calc-tail (arg) |
384 |
(interactive "P") |
(interactive "P") |
385 |
(calc-invert-func) |
(calc-invert-func) |
386 |
(calc-head arg) |
(calc-head arg)) |
|
) |
|
387 |
|
|
388 |
(defun calc-vlength (arg) |
(defun calc-vlength (arg) |
389 |
(interactive "P") |
(interactive "P") |
390 |
(calc-wrapper |
(calc-wrapper |
391 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
392 |
(calc-unary-op "dims" 'calcFunc-mdims arg) |
(calc-unary-op "dims" 'calcFunc-mdims arg) |
393 |
(calc-unary-op "len" 'calcFunc-vlen arg))) |
(calc-unary-op "len" 'calcFunc-vlen arg)))) |
|
) |
|
394 |
|
|
395 |
(defun calc-arrange-vector (n) |
(defun calc-arrange-vector (n) |
396 |
(interactive "NNumber of columns = ") |
(interactive "NNumber of columns = ") |
397 |
(calc-wrapper |
(calc-wrapper |
398 |
(calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1) |
(calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1) |
399 |
(prefix-numeric-value n)))) |
(prefix-numeric-value n))))) |
|
) |
|
400 |
|
|
401 |
(defun calc-vector-find (arg) |
(defun calc-vector-find (arg) |
402 |
(interactive "P") |
(interactive "P") |
404 |
(let ((func (cons 'calcFunc-find (calc-top-list-n 2)))) |
(let ((func (cons 'calcFunc-find (calc-top-list-n 2)))) |
405 |
(calc-enter-result |
(calc-enter-result |
406 |
2 "find" |
2 "find" |
407 |
(if arg (append func (list (prefix-numeric-value arg))) func)))) |
(if arg (append func (list (prefix-numeric-value arg))) func))))) |
|
) |
|
408 |
|
|
409 |
(defun calc-subvector () |
(defun calc-subvector () |
410 |
(interactive) |
(interactive) |
412 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
413 |
(calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec |
(calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec |
414 |
(calc-top-list-n 3))) |
(calc-top-list-n 3))) |
415 |
(calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3))))) |
(calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3)))))) |
|
) |
|
416 |
|
|
417 |
(defun calc-reverse-vector (arg) |
(defun calc-reverse-vector (arg) |
418 |
(interactive "P") |
(interactive "P") |
419 |
(calc-wrapper |
(calc-wrapper |
420 |
(calc-unary-op "rev" 'calcFunc-rev arg)) |
(calc-unary-op "rev" 'calcFunc-rev arg))) |
|
) |
|
421 |
|
|
422 |
(defun calc-mask-vector (arg) |
(defun calc-mask-vector (arg) |
423 |
(interactive "P") |
(interactive "P") |
424 |
(calc-wrapper |
(calc-wrapper |
425 |
(calc-binary-op "vmsk" 'calcFunc-vmask arg)) |
(calc-binary-op "vmsk" 'calcFunc-vmask arg))) |
|
) |
|
426 |
|
|
427 |
(defun calc-expand-vector (arg) |
(defun calc-expand-vector (arg) |
428 |
(interactive "P") |
(interactive "P") |
429 |
(calc-wrapper |
(calc-wrapper |
430 |
(if (calc-is-hyperbolic) |
(if (calc-is-hyperbolic) |
431 |
(calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3))) |
(calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3))) |
432 |
(calc-binary-op "vexp" 'calcFunc-vexp arg))) |
(calc-binary-op "vexp" 'calcFunc-vexp arg)))) |
|
) |
|
433 |
|
|
434 |
(defun calc-sort () |
(defun calc-sort () |
435 |
(interactive) |
(interactive) |
436 |
(calc-slow-wrapper |
(calc-slow-wrapper |
437 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
438 |
(calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1))) |
(calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1))) |
439 |
(calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1))))) |
(calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1)))))) |
|
) |
|
440 |
|
|
441 |
(defun calc-grade () |
(defun calc-grade () |
442 |
(interactive) |
(interactive) |
443 |
(calc-slow-wrapper |
(calc-slow-wrapper |
444 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
445 |
(calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1))) |
(calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1))) |
446 |
(calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))) |
(calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1)))))) |
|
) |
|
447 |
|
|
448 |
(defun calc-histogram (n) |
(defun calc-histogram (n) |
449 |
(interactive "NNumber of bins: ") |
(interactive "NNumber of bins: ") |
455 |
(prefix-numeric-value n))) |
(prefix-numeric-value n))) |
456 |
(calc-enter-result 1 "hist" (list 'calcFunc-histogram |
(calc-enter-result 1 "hist" (list 'calcFunc-histogram |
457 |
(calc-top-n 1) |
(calc-top-n 1) |
458 |
(prefix-numeric-value n))))) |
(prefix-numeric-value n)))))) |
|
) |
|
459 |
|
|
460 |
(defun calc-transpose (arg) |
(defun calc-transpose (arg) |
461 |
(interactive "P") |
(interactive "P") |
462 |
(calc-wrapper |
(calc-wrapper |
463 |
(calc-unary-op "trn" 'calcFunc-trn arg)) |
(calc-unary-op "trn" 'calcFunc-trn arg))) |
|
) |
|
464 |
|
|
465 |
(defun calc-conj-transpose (arg) |
(defun calc-conj-transpose (arg) |
466 |
(interactive "P") |
(interactive "P") |
467 |
(calc-wrapper |
(calc-wrapper |
468 |
(calc-unary-op "ctrn" 'calcFunc-ctrn arg)) |
(calc-unary-op "ctrn" 'calcFunc-ctrn arg))) |
|
) |
|
469 |
|
|
470 |
(defun calc-cross (arg) |
(defun calc-cross (arg) |
471 |
(interactive "P") |
(interactive "P") |
472 |
(calc-wrapper |
(calc-wrapper |
473 |
(calc-binary-op "cros" 'calcFunc-cross arg)) |
(calc-binary-op "cros" 'calcFunc-cross arg))) |
|
) |
|
474 |
|
|
475 |
(defun calc-remove-duplicates (arg) |
(defun calc-remove-duplicates (arg) |
476 |
(interactive "P") |
(interactive "P") |
477 |
(calc-wrapper |
(calc-wrapper |
478 |
(calc-unary-op "rdup" 'calcFunc-rdup arg)) |
(calc-unary-op "rdup" 'calcFunc-rdup arg))) |
|
) |
|
479 |
|
|
480 |
(defun calc-set-union (arg) |
(defun calc-set-union (arg) |
481 |
(interactive "P") |
(interactive "P") |
482 |
(calc-wrapper |
(calc-wrapper |
483 |
(calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup)) |
(calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup))) |
|
) |
|
484 |
|
|
485 |
(defun calc-set-intersect (arg) |
(defun calc-set-intersect (arg) |
486 |
(interactive "P") |
(interactive "P") |
487 |
(calc-wrapper |
(calc-wrapper |
488 |
(calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup)) |
(calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup))) |
|
) |
|
489 |
|
|
490 |
(defun calc-set-difference (arg) |
(defun calc-set-difference (arg) |
491 |
(interactive "P") |
(interactive "P") |
492 |
(calc-wrapper |
(calc-wrapper |
493 |
(calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup)) |
(calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup))) |
|
) |
|
494 |
|
|
495 |
(defun calc-set-xor (arg) |
(defun calc-set-xor (arg) |
496 |
(interactive "P") |
(interactive "P") |
497 |
(calc-wrapper |
(calc-wrapper |
498 |
(calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup)) |
(calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup))) |
|
) |
|
499 |
|
|
500 |
(defun calc-set-complement (arg) |
(defun calc-set-complement (arg) |
501 |
(interactive "P") |
(interactive "P") |
502 |
(calc-wrapper |
(calc-wrapper |
503 |
(calc-unary-op "cmpl" 'calcFunc-vcompl arg)) |
(calc-unary-op "cmpl" 'calcFunc-vcompl arg))) |
|
) |
|
504 |
|
|
505 |
(defun calc-set-floor (arg) |
(defun calc-set-floor (arg) |
506 |
(interactive "P") |
(interactive "P") |
507 |
(calc-wrapper |
(calc-wrapper |
508 |
(calc-unary-op "vflr" 'calcFunc-vfloor arg)) |
(calc-unary-op "vflr" 'calcFunc-vfloor arg))) |
|
) |
|
509 |
|
|
510 |
(defun calc-set-enumerate (arg) |
(defun calc-set-enumerate (arg) |
511 |
(interactive "P") |
(interactive "P") |
512 |
(calc-wrapper |
(calc-wrapper |
513 |
(calc-unary-op "enum" 'calcFunc-venum arg)) |
(calc-unary-op "enum" 'calcFunc-venum arg))) |
|
) |
|
514 |
|
|
515 |
(defun calc-set-span (arg) |
(defun calc-set-span (arg) |
516 |
(interactive "P") |
(interactive "P") |
517 |
(calc-wrapper |
(calc-wrapper |
518 |
(calc-unary-op "span" 'calcFunc-vspan arg)) |
(calc-unary-op "span" 'calcFunc-vspan arg))) |
|
) |
|
519 |
|
|
520 |
(defun calc-set-cardinality (arg) |
(defun calc-set-cardinality (arg) |
521 |
(interactive "P") |
(interactive "P") |
522 |
(calc-wrapper |
(calc-wrapper |
523 |
(calc-unary-op "card" 'calcFunc-vcard arg)) |
(calc-unary-op "card" 'calcFunc-vcard arg))) |
|
) |
|
524 |
|
|
525 |
(defun calc-unpack-bits (arg) |
(defun calc-unpack-bits (arg) |
526 |
(interactive "P") |
(interactive "P") |
527 |
(calc-wrapper |
(calc-wrapper |
528 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
529 |
(calc-unary-op "bpck" 'calcFunc-vpack arg) |
(calc-unary-op "bpck" 'calcFunc-vpack arg) |
530 |
(calc-unary-op "bupk" 'calcFunc-vunpack arg))) |
(calc-unary-op "bupk" 'calcFunc-vunpack arg)))) |
|
) |
|
531 |
|
|
532 |
(defun calc-pack-bits (arg) |
(defun calc-pack-bits (arg) |
533 |
(interactive "P") |
(interactive "P") |
534 |
(calc-invert-func) |
(calc-invert-func) |
535 |
(calc-unpack-bits arg) |
(calc-unpack-bits arg)) |
|
) |
|
536 |
|
|
537 |
|
|
538 |
(defun calc-rnorm (arg) |
(defun calc-rnorm (arg) |
539 |
(interactive "P") |
(interactive "P") |
540 |
(calc-wrapper |
(calc-wrapper |
541 |
(calc-unary-op "rnrm" 'calcFunc-rnorm arg)) |
(calc-unary-op "rnrm" 'calcFunc-rnorm arg))) |
|
) |
|
542 |
|
|
543 |
(defun calc-cnorm (arg) |
(defun calc-cnorm (arg) |
544 |
(interactive "P") |
(interactive "P") |
545 |
(calc-wrapper |
(calc-wrapper |
546 |
(calc-unary-op "cnrm" 'calcFunc-cnorm arg)) |
(calc-unary-op "cnrm" 'calcFunc-cnorm arg))) |
|
) |
|
547 |
|
|
548 |
(defun calc-mrow (n &optional nn) |
(defun calc-mrow (n &optional nn) |
549 |
(interactive "NRow number: \nP") |
(interactive "NRow number: \nP") |
557 |
(calc-enter-result 1 "rrow" (list 'calcFunc-mrrow |
(calc-enter-result 1 "rrow" (list 'calcFunc-mrrow |
558 |
(calc-top-n 1) (- n))) |
(calc-top-n 1) (- n))) |
559 |
(calc-enter-result 1 "mrow" (list 'calcFunc-mrow |
(calc-enter-result 1 "mrow" (list 'calcFunc-mrow |
560 |
(calc-top-n 1) n)))))) |
(calc-top-n 1) n))))))) |
|
) |
|
561 |
|
|
562 |
(defun calc-mcol (n &optional nn) |
(defun calc-mcol (n &optional nn) |
563 |
(interactive "NColumn number: \nP") |
(interactive "NColumn number: \nP") |
571 |
(calc-enter-result 1 "rcol" (list 'calcFunc-mrcol |
(calc-enter-result 1 "rcol" (list 'calcFunc-mrcol |
572 |
(calc-top-n 1) (- n))) |
(calc-top-n 1) (- n))) |
573 |
(calc-enter-result 1 "mcol" (list 'calcFunc-mcol |
(calc-enter-result 1 "mcol" (list 'calcFunc-mcol |
574 |
(calc-top-n 1) n)))))) |
(calc-top-n 1) n))))))) |
|
) |
|
575 |
|
|
576 |
|
|
577 |
;;;; Vectors. |
;;;; Vectors. |
579 |
(defun calcFunc-mdims (m) |
(defun calcFunc-mdims (m) |
580 |
(or (math-vectorp m) |
(or (math-vectorp m) |
581 |
(math-reject-arg m 'vectorp)) |
(math-reject-arg m 'vectorp)) |
582 |
(cons 'vec (math-mat-dimens m)) |
(cons 'vec (math-mat-dimens m))) |
|
) |
|
583 |
|
|
584 |
|
|
585 |
;;; Apply a function elementwise to vector A. [V X V; N X N] [Public] |
;;; Apply a function elementwise to vector A. [V X V; N X N] [Public] |
586 |
(defun math-map-vec (f a) |
(defun math-map-vec (f a) |
587 |
(if (math-vectorp a) |
(if (math-vectorp a) |
588 |
(cons 'vec (mapcar f (cdr a))) |
(cons 'vec (mapcar f (cdr a))) |
589 |
(funcall f a)) |
(funcall f a))) |
|
) |
|
590 |
|
|
591 |
(defun math-dimension-error () |
(defun math-dimension-error () |
592 |
(calc-record-why "*Dimension error") |
(calc-record-why "*Dimension error") |
593 |
(signal 'wrong-type-argument nil) |
(signal 'wrong-type-argument nil)) |
|
) |
|
594 |
|
|
595 |
|
|
596 |
;;; Build a vector out of a list of objects. [Public] |
;;; Build a vector out of a list of objects. [Public] |
597 |
(defun calcFunc-vec (&rest objs) |
(defun calcFunc-vec (&rest objs) |
598 |
(cons 'vec objs) |
(cons 'vec objs)) |
|
) |
|
599 |
|
|
600 |
|
|
601 |
;;; Build a constant vector or matrix. [Public] |
;;; Build a constant vector or matrix. [Public] |
602 |
(defun calcFunc-cvec (obj &rest dims) |
(defun calcFunc-cvec (obj &rest dims) |
603 |
(math-make-vec-dimen obj dims) |
(math-make-vec-dimen obj dims)) |
|
) |
|
604 |
|
|
605 |
(defun math-make-vec-dimen (obj dims) |
(defun math-make-vec-dimen (obj dims) |
606 |
(if dims |
(if dims |
612 |
(math-make-vec-dimen obj (cdr dims))))) |
(math-make-vec-dimen obj (cdr dims))))) |
613 |
(cons 'vec (make-list (car dims) obj))) |
(cons 'vec (make-list (car dims) obj))) |
614 |
(math-reject-arg (car dims) 'fixnatnump)) |
(math-reject-arg (car dims) 'fixnatnump)) |
615 |
obj) |
obj)) |
|
) |
|
616 |
|
|
617 |
(defun calcFunc-head (vec) |
(defun calcFunc-head (vec) |
618 |
(if (and (Math-vectorp vec) |
(if (and (Math-vectorp vec) |
619 |
(cdr vec)) |
(cdr vec)) |
620 |
(nth 1 vec) |
(nth 1 vec) |
621 |
(calc-record-why 'vectorp vec) |
(calc-record-why 'vectorp vec) |
622 |
(list 'calcFunc-head vec)) |
(list 'calcFunc-head vec))) |
|
) |
|
623 |
|
|
624 |
(defun calcFunc-tail (vec) |
(defun calcFunc-tail (vec) |
625 |
(if (and (Math-vectorp vec) |
(if (and (Math-vectorp vec) |
626 |
(cdr vec)) |
(cdr vec)) |
627 |
(cons 'vec (cdr (cdr vec))) |
(cons 'vec (cdr (cdr vec))) |
628 |
(calc-record-why 'vectorp vec) |
(calc-record-why 'vectorp vec) |
629 |
(list 'calcFunc-tail vec)) |
(list 'calcFunc-tail vec))) |
|
) |
|
630 |
|
|
631 |
(defun calcFunc-cons (head tail) |
(defun calcFunc-cons (head tail) |
632 |
(if (Math-vectorp tail) |
(if (Math-vectorp tail) |
633 |
(cons 'vec (cons head (cdr tail))) |
(cons 'vec (cons head (cdr tail))) |
634 |
(calc-record-why 'vectorp tail) |
(calc-record-why 'vectorp tail) |
635 |
(list 'calcFunc-cons head tail)) |
(list 'calcFunc-cons head tail))) |
|
) |
|
636 |
|
|
637 |
(defun calcFunc-rhead (vec) |
(defun calcFunc-rhead (vec) |
638 |
(if (and (Math-vectorp vec) |
(if (and (Math-vectorp vec) |
641 |
(setcdr (nthcdr (- (length vec) 2) vec) nil) |
(setcdr (nthcdr (- (length vec) 2) vec) nil) |
642 |
vec) |
vec) |
643 |
(calc-record-why 'vectorp vec) |
(calc-record-why 'vectorp vec) |
644 |
(list 'calcFunc-rhead vec)) |
(list 'calcFunc-rhead vec))) |
|
) |
|
645 |
|
|
646 |
(defun calcFunc-rtail (vec) |
(defun calcFunc-rtail (vec) |
647 |
(if (and (Math-vectorp vec) |
(if (and (Math-vectorp vec) |
648 |
(cdr vec)) |
(cdr vec)) |
649 |
(nth (1- (length vec)) vec) |
(nth (1- (length vec)) vec) |
650 |
(calc-record-why 'vectorp vec) |
(calc-record-why 'vectorp vec) |
651 |
(list 'calcFunc-rtail vec)) |
(list 'calcFunc-rtail vec))) |
|
) |
|
652 |
|
|
653 |
(defun calcFunc-rcons (head tail) |
(defun calcFunc-rcons (head tail) |
654 |
(if (Math-vectorp head) |
(if (Math-vectorp head) |
655 |
(append head (list tail)) |
(append head (list tail)) |
656 |
(calc-record-why 'vectorp head) |
(calc-record-why 'vectorp head) |
657 |
(list 'calcFunc-rcons head tail)) |
(list 'calcFunc-rcons head tail))) |
|
) |
|
658 |
|
|
659 |
|
|
660 |
|
|
678 |
(while (setq b (cdr b)) |
(while (setq b (cdr b)) |
679 |
(setq v (cons (funcall f a (car b)) v))) |
(setq v (cons (funcall f a (car b)) v))) |
680 |
(cons 'vec (nreverse v))) |
(cons 'vec (nreverse v))) |
681 |
(funcall f a b))) |
(funcall f a b)))) |
|
) |
|
682 |
|
|
683 |
|
|
684 |
|
|
691 |
(setq accum (funcall f accum (car a)))) |
(setq accum (funcall f accum (car a)))) |
692 |
accum) |
accum) |
693 |
0) |
0) |
694 |
a) |
a)) |
|
) |
|
695 |
|
|
696 |
;;; Reduce a function over the columns of matrix A. [V X V] [Public] |
;;; Reduce a function over the columns of matrix A. [V X V] [Public] |
697 |
(defun math-reduce-cols (f a) |
(defun math-reduce-cols (f a) |
698 |
(if (math-matrixp a) |
(if (math-matrixp a) |
699 |
(cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a)))) |
(cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a)))) |
700 |
a) |
a)) |
|
) |
|
701 |
|
|
702 |
(defun math-reduce-cols-col-step (f a col cols) |
(defun math-reduce-cols-col-step (f a col cols) |
703 |
(and (< col cols) |
(and (< col cols) |
704 |
(cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a)) |
(cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a)) |
705 |
(math-reduce-cols-col-step f a (1+ col) cols))) |
(math-reduce-cols-col-step f a (1+ col) cols)))) |
|
) |
|
706 |
|
|
707 |
(defun math-reduce-cols-row-step (f tot col a) |
(defun math-reduce-cols-row-step (f tot col a) |
708 |
(if a |
(if a |
710 |
(funcall f tot (nth col (car a))) |
(funcall f tot (nth col (car a))) |
711 |
col |
col |
712 |
(cdr a)) |
(cdr a)) |
713 |
tot) |
tot)) |
|
) |
|
714 |
|
|
715 |
|
|
716 |
|
|
720 |
(while (setq a (cdr a) b (cdr b)) |
(while (setq a (cdr a) b (cdr b)) |
721 |
(setq accum (math-add accum (math-mul (car a) (car b))))) |
(setq accum (math-add accum (math-mul (car a) (car b))))) |
722 |
accum) |
accum) |
723 |
0) |
0)) |
|
) |
|
724 |
|
|
725 |
|
|
726 |
;;; Return the number of elements in vector V. [Public] |
;;; Return the number of elements in vector V. [Public] |
729 |
(1- (length v)) |
(1- (length v)) |
730 |
(if (math-objectp v) |
(if (math-objectp v) |
731 |
0 |
0 |
732 |
(list 'calcFunc-vlen v))) |
(list 'calcFunc-vlen v)))) |
|
) |
|
733 |
|
|
734 |
;;; Get the Nth row of a matrix. |
;;; Get the Nth row of a matrix. |
735 |
(defun calcFunc-mrow (mat n) ; [Public] |
(defun calcFunc-mrow (mat n) ; [Public] |
745 |
(or (Math-vectorp mat) |
(or (Math-vectorp mat) |
746 |
(math-reject-arg mat 'vectorp)) |
(math-reject-arg mat 'vectorp)) |
747 |
(or (nth n mat) |
(or (nth n mat) |
748 |
(math-reject-arg n "*Index out of range")))) |
(math-reject-arg n "*Index out of range"))))) |
|
) |
|
749 |
|
|
750 |
(defun calcFunc-subscr (mat n &optional m) |
(defun calcFunc-subscr (mat n &optional m) |
751 |
(setq mat (calcFunc-mrow mat n)) |
(setq mat (calcFunc-mrow mat n)) |
753 |
(if (math-num-integerp n) |
(if (math-num-integerp n) |
754 |
(calcFunc-mrow mat m) |
(calcFunc-mrow mat m) |
755 |
(calcFunc-mcol mat m)) |
(calcFunc-mcol mat m)) |
756 |
mat) |
mat)) |
|
) |
|
757 |
|
|
758 |
;;; Get the Nth column of a matrix. |
;;; Get the Nth column of a matrix. |
759 |
(defun math-mat-col (mat n) |
(defun math-mat-col (mat n) |
760 |
(cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat))) |
(cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat)))) |
|
) |
|
761 |
|
|
762 |
(defun calcFunc-mcol (mat n) ; [Public] |
(defun calcFunc-mcol (mat n) ; [Public] |
763 |
(if (Math-vectorp n) |
(if (Math-vectorp n) |
776 |
(and (< n (length (nth 1 mat))) |
(and (< n (length (nth 1 mat))) |
777 |
(math-mat-col mat n)) |
(math-mat-col mat n)) |
778 |
(nth n mat)) |
(nth n mat)) |
779 |
(math-reject-arg n "*Index out of range")))) |
(math-reject-arg n "*Index out of range"))))) |
|
) |
|
780 |
|
|
781 |
;;; Remove the Nth row from a matrix. |
;;; Remove the Nth row from a matrix. |
782 |
(defun math-mat-less-row (mat n) |
(defun math-mat-less-row (mat n) |
783 |
(if (<= n 0) |
(if (<= n 0) |
784 |
(cdr mat) |
(cdr mat) |
785 |
(cons (car mat) |
(cons (car mat) |
786 |
(math-mat-less-row (cdr mat) (1- n)))) |
(math-mat-less-row (cdr mat) (1- n))))) |
|
) |
|
787 |
|
|
788 |
(defun calcFunc-mrrow (mat n) ; [Public] |
(defun calcFunc-mrrow (mat n) ; [Public] |
789 |
(and (integerp (setq n (math-check-integer n))) |
(and (integerp (setq n (math-check-integer n))) |
790 |
(> n 0) |
(> n 0) |
791 |
(< n (length mat)) |
(< n (length mat)) |
792 |
(math-mat-less-row mat n)) |
(math-mat-less-row mat n))) |
|
) |
|
793 |
|
|
794 |
;;; Remove the Nth column from a matrix. |
;;; Remove the Nth column from a matrix. |
795 |
(defun math-mat-less-col (mat n) |
(defun math-mat-less-col (mat n) |
796 |
(cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n))) |
(cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n))) |
797 |
(cdr mat))) |
(cdr mat)))) |
|
) |
|
798 |
|
|
799 |
(defun calcFunc-mrcol (mat n) ; [Public] |
(defun calcFunc-mrcol (mat n) ; [Public] |
800 |
(and (integerp (setq n (math-check-integer n))) |
(and (integerp (setq n (math-check-integer n))) |
802 |
(if (math-matrixp mat) |
(if (math-matrixp mat) |
803 |
(and (< n (length (nth 1 mat))) |
(and (< n (length (nth 1 mat))) |
804 |
(math-mat-less-col mat n)) |
(math-mat-less-col mat n)) |
805 |
(math-mat-less-row mat n))) |
(math-mat-less-row mat n)))) |
|
) |
|
806 |
|
|
807 |
(defun calcFunc-getdiag (mat) ; [Public] |
(defun calcFunc-getdiag (mat) ; [Public] |
808 |
(if (math-square-matrixp mat) |
(if (math-square-matrixp mat) |
809 |
(cons 'vec (math-get-diag-step (cdr mat) 1)) |
(cons 'vec (math-get-diag-step (cdr mat) 1)) |
810 |
(calc-record-why 'square-matrixp mat) |
(calc-record-why 'square-matrixp mat) |
811 |
(list 'calcFunc-getdiag mat)) |
(list 'calcFunc-getdiag mat))) |
|
) |
|
812 |
|
|
813 |
(defun math-get-diag-step (row n) |
(defun math-get-diag-step (row n) |
814 |
(and row |
(and row |
815 |
(cons (nth n (car row)) |
(cons (nth n (car row)) |
816 |
(math-get-diag-step (cdr row) (1+ n)))) |
(math-get-diag-step (cdr row) (1+ n))))) |
|
) |
|
817 |
|
|
818 |
(defun math-transpose (mat) ; [Public] |
(defun math-transpose (mat) ; [Public] |
819 |
(let ((m nil) |
(let ((m nil) |
820 |
(col (length (nth 1 mat)))) |
(col (length (nth 1 mat)))) |
821 |
(while (> (setq col (1- col)) 0) |
(while (> (setq col (1- col)) 0) |
822 |
(setq m (cons (math-mat-col mat col) m))) |
(setq m (cons (math-mat-col mat col) m))) |
823 |
(cons 'vec m)) |
(cons 'vec m))) |
|
) |
|
824 |
|
|
825 |
(defun calcFunc-trn (mat) |
(defun calcFunc-trn (mat) |
826 |
(if (math-vectorp mat) |
(if (math-vectorp mat) |
829 |
(math-col-matrix mat)) |
(math-col-matrix mat)) |
830 |
(if (math-numberp mat) |
(if (math-numberp mat) |
831 |
mat |
mat |
832 |
(math-reject-arg mat 'matrixp))) |
(math-reject-arg mat 'matrixp)))) |
|
) |
|
833 |
|
|
834 |
(defun calcFunc-ctrn (mat) |
(defun calcFunc-ctrn (mat) |
835 |
(calcFunc-conj (calcFunc-trn mat)) |
(calcFunc-conj (calcFunc-trn mat))) |
|
) |
|
836 |
|
|
837 |
(defun calcFunc-pack (mode els) |
(defun calcFunc-pack (mode els) |
838 |
(or (Math-vectorp els) (math-reject-arg els 'vectorp)) |
(or (Math-vectorp els) (math-reject-arg els 'vectorp)) |
843 |
(if (= (calc-pack-size mode) (1- (length els))) |
(if (= (calc-pack-size mode) (1- (length els))) |
844 |
(calc-pack-items mode (cdr els)) |
(calc-pack-items mode (cdr els)) |
845 |
(math-reject-arg els "*Wrong number of elements")) |
(math-reject-arg els "*Wrong number of elements")) |
846 |
(error (math-reject-arg els (nth 1 err)))) |
(error (math-reject-arg els (nth 1 err))))) |
|
) |
|
847 |
|
|
848 |
(defun calcFunc-unpack (mode thing) |
(defun calcFunc-unpack (mode thing) |
849 |
(or (integerp mode) (math-reject-arg mode 'fixnump)) |
(or (integerp mode) (math-reject-arg mode 'fixnump)) |
850 |
(condition-case err |
(condition-case err |
851 |
(cons 'vec (calc-unpack-item mode thing)) |
(cons 'vec (calc-unpack-item mode thing)) |
852 |
(error (math-reject-arg thing (nth 1 err)))) |
(error (math-reject-arg thing (nth 1 err))))) |
|
) |
|
853 |
|
|
854 |
(defun calcFunc-unpackt (mode thing) |
(defun calcFunc-unpackt (mode thing) |
855 |
(let ((calc-unpack-with-type 'pair)) |
(let ((calc-unpack-with-type 'pair)) |
856 |
(calcFunc-unpack mode thing)) |
(calcFunc-unpack mode thing))) |
|
) |
|
857 |
|
|
858 |
(defun calcFunc-arrange (vec cols) ; [Public] |
(defun calcFunc-arrange (vec cols) ; [Public] |
859 |
(setq cols (math-check-fixnum cols t)) |
(setq cols (math-check-fixnum cols t)) |
870 |
flat next)) |
flat next)) |
871 |
(if flat |
(if flat |
872 |
(setq mat (nconc mat (list (cons 'vec flat))))) |
(setq mat (nconc mat (list (cons 'vec flat))))) |
873 |
mat))) |
mat)))) |
|
) |
|
874 |
|
|
875 |
(defun math-flatten-vector (vec) ; [L V] |
(defun math-flatten-vector (vec) ; [L V] |
876 |
(if (math-vectorp vec) |
(if (math-vectorp vec) |
877 |
(apply 'append (mapcar 'math-flatten-vector (cdr vec))) |
(apply 'append (mapcar 'math-flatten-vector (cdr vec))) |
878 |
(list vec)) |
(list vec))) |
|
) |
|
879 |
|
|
880 |
(defun calcFunc-vconcat (a b) |
(defun calcFunc-vconcat (a b) |
881 |
(math-normalize (list '| a b)) |
(math-normalize (list '| a b))) |
|
) |
|
882 |
|
|
883 |
(defun calcFunc-vconcatrev (a b) |
(defun calcFunc-vconcatrev (a b) |
884 |
(math-normalize (list '| b a)) |
(math-normalize (list '| b a))) |
|
) |
|
885 |
|
|
886 |
(defun calcFunc-append (v1 v2) |
(defun calcFunc-append (v1 v2) |
887 |
(if (and (math-vectorp v1) (math-vectorp v2)) |
(if (and (math-vectorp v1) (math-vectorp v2)) |
888 |
(append v1 (cdr v2)) |
(append v1 (cdr v2)) |
889 |
(list 'calcFunc-append v1 v2)) |
(list 'calcFunc-append v1 v2))) |
|
) |
|
890 |
|
|
891 |
(defun calcFunc-appendrev (v1 v2) |
(defun calcFunc-appendrev (v1 v2) |
892 |
(calcFunc-append v2 v1) |
(calcFunc-append v2 v1)) |
|
) |
|
893 |
|
|
894 |
|
|
895 |
;;; Copy a matrix. [Public] |
;;; Copy a matrix. [Public] |
896 |
(defun math-copy-matrix (m) |
(defun math-copy-matrix (m) |
897 |
(if (math-vectorp (nth 1 m)) |
(if (math-vectorp (nth 1 m)) |
898 |
(cons 'vec (mapcar 'copy-sequence (cdr m))) |
(cons 'vec (mapcar 'copy-sequence (cdr m))) |
899 |
(copy-sequence m)) |
(copy-sequence m))) |
|
) |
|
900 |
|
|
901 |
;;; Convert a scalar or vector into an NxN diagonal matrix. [Public] |
;;; Convert a scalar or vector into an NxN diagonal matrix. [Public] |
902 |
(defun calcFunc-diag (a &optional n) |
(defun calcFunc-diag (a &optional n) |
912 |
(cons 'vec (math-diag-step (cdr a) 0 (1- (length a)))))) |
(cons 'vec (math-diag-step (cdr a) 0 (1- (length a)))))) |
913 |
(if n |
(if n |
914 |
(cons 'vec (math-diag-step (make-list n a) 0 n)) |
(cons 'vec (math-diag-step (make-list n a) 0 n)) |
915 |
(list 'calcFunc-diag a))) |
(list 'calcFunc-diag a)))) |
|
) |
|
916 |
|
|
917 |
(defun calcFunc-idn (a &optional n) |
(defun calcFunc-idn (a &optional n) |
918 |
(if n |
(if n |
921 |
(calcFunc-diag a n)) |
(calcFunc-diag a n)) |
922 |
(if (integerp calc-matrix-mode) |
(if (integerp calc-matrix-mode) |
923 |
(calcFunc-idn a calc-matrix-mode) |
(calcFunc-idn a calc-matrix-mode) |
924 |
(list 'calcFunc-idn a))) |
(list 'calcFunc-idn a)))) |
|
) |
|
925 |
|
|
926 |
(defun math-mimic-ident (a m) |
(defun math-mimic-ident (a m) |
927 |
(if (math-square-matrixp m) |
(if (math-square-matrixp m) |
934 |
a))) |
a))) |
935 |
(cdr m))) |
(cdr m))) |
936 |
(math-dimension-error)) |
(math-dimension-error)) |
937 |
(calcFunc-idn a))) |
(calcFunc-idn a)))) |
|
) |
|
938 |
|
|
939 |
(defun math-diag-step (a n m) |
(defun math-diag-step (a n m) |
940 |
(if (< n m) |
(if (< n m) |
943 |
(cons (car a) |
(cons (car a) |
944 |
(make-list (1- (- m n)) 0)))) |
(make-list (1- (- m n)) 0)))) |
945 |
(math-diag-step (cdr a) (1+ n) m)) |
(math-diag-step (cdr a) (1+ n) m)) |
946 |
nil) |
nil)) |
|
) |
|
947 |
|
|
948 |
;;; Create a vector of consecutive integers. [Public] |
;;; Create a vector of consecutive integers. [Public] |
949 |
(defun calcFunc-index (n &optional start incr) |
(defun calcFunc-index (n &optional start incr) |
970 |
(while (>= i n) |
(while (>= i n) |
971 |
(setq vec (cons i vec) |
(setq vec (cons i vec) |
972 |
i (1- i)))))) |
i (1- i)))))) |
973 |
(cons 'vec vec))) |
(cons 'vec vec)))) |
|
) |
|
974 |
|
|
975 |
;;; Find an element in a vector. |
;;; Find an element in a vector. |
976 |
(defun calcFunc-find (vec x &optional start) |
(defun calcFunc-find (vec x &optional start) |
981 |
(while (and vec (not (Math-equal x (car vec)))) |
(while (and vec (not (Math-equal x (car vec)))) |
982 |
(setq n (1+ n) |
(setq n (1+ n) |
983 |
vec (cdr vec))) |
vec (cdr vec))) |
984 |
(if vec n 0)) |
(if vec n 0))) |
|
) |
|
985 |
|
|
986 |
;;; Return a subvector of a vector. |
;;; Return a subvector of a vector. |
987 |
(defun calcFunc-subvec (vec start &optional end) |
(defun calcFunc-subvec (vec start &optional end) |
1000 |
(if (<= end len) |
(if (<= end len) |
1001 |
(let ((chop (nthcdr (- end start 1) (setq vec (copy-sequence vec))))) |
(let ((chop (nthcdr (- end start 1) (setq vec (copy-sequence vec))))) |
1002 |
(setcdr chop nil))) |
(setcdr chop nil))) |
1003 |
(cons 'vec vec))) |
(cons 'vec vec)))) |
|
) |
|
1004 |
|
|
1005 |
;;; Remove a subvector from a vector. |
;;; Remove a subvector from a vector. |
1006 |
(defun calcFunc-rsubvec (vec start &optional end) |
(defun calcFunc-rsubvec (vec start &optional end) |
1018 |
(let ((tail (nthcdr end vec)) |
(let ((tail (nthcdr end vec)) |
1019 |
(chop (nthcdr (1- start) (setq vec (copy-sequence vec))))) |
(chop (nthcdr (1- start) (setq vec (copy-sequence vec))))) |
1020 |
(setcdr chop nil) |
(setcdr chop nil) |
1021 |
(append vec tail)))) |
(append vec tail))))) |
|
) |
|
1022 |
|
|
1023 |
;;; Reverse the order of the elements of a vector. |
;;; Reverse the order of the elements of a vector. |
1024 |
(defun calcFunc-rev (vec) |
(defun calcFunc-rev (vec) |
1025 |
(if (math-vectorp vec) |
(if (math-vectorp vec) |
1026 |
(cons 'vec (reverse (cdr vec))) |
(cons 'vec (reverse (cdr vec))) |
1027 |
(math-reject-arg vec 'vectorp)) |
(math-reject-arg vec 'vectorp))) |
|
) |
|
1028 |
|
|
1029 |
;;; Compress a vector according to a mask vector. |
;;; Compress a vector according to a mask vector. |
1030 |
(defun calcFunc-vmask (mask vec) |
(defun calcFunc-vmask (mask vec) |
1040 |
(while (setq mask (cdr mask) vec (cdr vec)) |
(while (setq mask (cdr mask) vec (cdr vec)) |
1041 |
(or (math-zerop (car mask)) |
(or (math-zerop (car mask)) |
1042 |
(setq new (cons (car vec) new)))) |
(setq new (cons (car vec) new)))) |
1043 |
(cons 'vec (nreverse new)))) |
(cons 'vec (nreverse new))))) |
|
) |
|
1044 |
|
|
1045 |
;;; Expand a vector according to a mask vector. |
;;; Expand a vector according to a mask vector. |
1046 |
(defun calcFunc-vexp (mask vec &optional filler) |
(defun calcFunc-vexp (mask vec &optional filler) |
1057 |
(car mask)) new)) |
(car mask)) new)) |
1058 |
(setq vec (cdr vec) |
(setq vec (cdr vec) |
1059 |
new (cons (or (car vec) (car mask)) new)))) |
new (cons (or (car vec) (car mask)) new)))) |
1060 |
(cons 'vec (nreverse new))) |
(cons 'vec (nreverse new)))) |
|
) |
|
1061 |
|
|
1062 |
|
|
1063 |
;;; Compute the row and column norms of a vector or matrix. [Public] |
;;; Compute the row and column norms of a vector or matrix. [Public] |
1068 |
(math-reduce-vec 'math-max (math-map-vec 'calcFunc-cnorm a)) |
(math-reduce-vec 'math-max (math-map-vec 'calcFunc-cnorm a)) |
1069 |
(math-reduce-vec 'math-max (math-map-vec 'math-abs a))) |
(math-reduce-vec 'math-max (math-map-vec 'math-abs a))) |
1070 |
(calc-record-why 'vectorp a) |
(calc-record-why 'vectorp a) |
1071 |
(list 'calcFunc-rnorm a)) |
(list 'calcFunc-rnorm a))) |
|
) |
|
1072 |
|
|
1073 |
(defun calcFunc-cnorm (a) |
(defun calcFunc-cnorm (a) |
1074 |
(if (and (Math-vectorp a) |
(if (and (Math-vectorp a) |
1078 |
(math-reduce-cols 'math-add-abs a)) |
(math-reduce-cols 'math-add-abs a)) |
1079 |
(math-reduce-vec 'math-add-abs a)) |
(math-reduce-vec 'math-add-abs a)) |
1080 |
(calc-record-why 'vectorp a) |
(calc-record-why 'vectorp a) |
1081 |
(list 'calcFunc-cnorm a)) |
(list 'calcFunc-cnorm a))) |
|
) |
|
1082 |
|
|
1083 |
(defun math-add-abs (a b) |
(defun math-add-abs (a b) |
1084 |
(math-add (math-abs a) (math-abs b)) |
(math-add (math-abs a) (math-abs b))) |
|
) |
|
1085 |
|
|
1086 |
|
|
1087 |
;;; Sort the elements of a vector into increasing order. |
;;; Sort the elements of a vector into increasing order. |
1088 |
(defun calcFunc-sort (vec) ; [Public] |
(defun calcFunc-sort (vec) ; [Public] |
1089 |
(if (math-vectorp vec) |
(if (math-vectorp vec) |
1090 |
(cons 'vec (sort (copy-sequence (cdr vec)) 'math-beforep)) |
(cons 'vec (sort (copy-sequence (cdr vec)) 'math-beforep)) |
1091 |
(math-reject-arg vec 'vectorp)) |
(math-reject-arg vec 'vectorp))) |
|
) |
|
1092 |
|
|
1093 |
(defun calcFunc-rsort (vec) ; [Public] |
(defun calcFunc-rsort (vec) ; [Public] |
1094 |
(if (math-vectorp vec) |
(if (math-vectorp vec) |
1095 |
(cons 'vec (nreverse (sort (copy-sequence (cdr vec)) 'math-beforep))) |
(cons 'vec (nreverse (sort (copy-sequence (cdr vec)) 'math-beforep))) |
1096 |
(math-reject-arg vec 'vectorp)) |
(math-reject-arg vec 'vectorp))) |
|
) |
|
1097 |
|
|
1098 |
(defun calcFunc-grade (grade-vec) |
(defun calcFunc-grade (grade-vec) |
1099 |
(if (math-vectorp grade-vec) |
(if (math-vectorp grade-vec) |
1100 |
(let* ((len (1- (length grade-vec)))) |
(let* ((len (1- (length grade-vec)))) |
1101 |
(cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep))) |
(cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep))) |
1102 |
(math-reject-arg grade-vec 'vectorp)) |
(math-reject-arg grade-vec 'vectorp))) |
|
) |
|
1103 |
|
|
1104 |
(defun calcFunc-rgrade (grade-vec) |
(defun calcFunc-rgrade (grade-vec) |
1105 |
(if (math-vectorp grade-vec) |
(if (math-vectorp grade-vec) |
1106 |
(let* ((len (1- (length grade-vec)))) |
(let* ((len (1- (length grade-vec)))) |
1107 |
(cons 'vec (nreverse (sort (cdr (calcFunc-index len)) |
(cons 'vec (nreverse (sort (cdr (calcFunc-index len)) |
1108 |
'math-grade-beforep)))) |
'math-grade-beforep)))) |
1109 |
(math-reject-arg grade-vec 'vectorp)) |
(math-reject-arg grade-vec 'vectorp))) |
|
) |
|
1110 |
|
|
1111 |
(defun math-grade-beforep (i j) |
(defun math-grade-beforep (i j) |
1112 |
(math-beforep (nth i grade-vec) (nth j grade-vec)) |
(math-beforep (nth i grade-vec) (nth j grade-vec))) |
|
) |
|
1113 |
|
|
1114 |
|
|
1115 |
;;; Compile a histogram of data from a vector. |
;;; Compile a histogram of data from a vector. |
1135 |
(< bin n) |
(< bin n) |
1136 |
(aset res bin (math-add (aref res bin) |
(aset res bin (math-add (aref res bin) |
1137 |
(if wvec (car (setq wp (cdr wp))) wts))))) |
(if wvec (car (setq wp (cdr wp))) wts))))) |
1138 |
(cons 'vec (append res nil))) |
(cons 'vec (append res nil)))) |
|
) |
|
1139 |
|
|
1140 |
|
|
1141 |
;;; Set operations. |
;;; Set operations. |
1148 |
(setq b (list b)) |
(setq b (list b)) |
1149 |
(or (math-vectorp b) (math-reject-arg b 'vectorp)) |
(or (math-vectorp b) (math-reject-arg b 'vectorp)) |
1150 |
(setq b (cdr b))) |
(setq b (cdr b))) |
1151 |
(calcFunc-rdup (append a b)) |
(calcFunc-rdup (append a b))) |
|
) |
|
1152 |
|
|
1153 |
(defun calcFunc-vint (a b) |
(defun calcFunc-vint (a b) |
1154 |
(if (and (math-simple-set a) (math-simple-set b)) |
(if (and (math-simple-set a) (math-simple-set b)) |
1165 |
(setq b (cdr b)))) |
(setq b (cdr b)))) |
1166 |
(nreverse vec))) |
(nreverse vec))) |
1167 |
(calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) |
(calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) |
1168 |
(calcFunc-vcompl b)))) |
(calcFunc-vcompl b))))) |
|
) |
|
1169 |
|
|
1170 |
(defun calcFunc-vdiff (a b) |
(defun calcFunc-vdiff (a b) |
1171 |
(if (and (math-simple-set a) (math-simple-set b)) |
(if (and (math-simple-set a) (math-simple-set b)) |
1182 |
(setq vec (cons (car a) vec) |
(setq vec (cons (car a) vec) |
1183 |
a (cdr a)))) |
a (cdr a)))) |
1184 |
(nreverse vec))) |
(nreverse vec))) |
1185 |
(calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b))) |
(calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b)))) |
|
) |
|
1186 |
|
|
1187 |
(defun calcFunc-vxor (a b) |
(defun calcFunc-vxor (a b) |
1188 |
(if (and (math-simple-set a) (math-simple-set b)) |
(if (and (math-simple-set a) (math-simple-set b)) |
1204 |
(let ((ca (calcFunc-vcompl a)) |
(let ((ca (calcFunc-vcompl a)) |
1205 |
(cb (calcFunc-vcompl b))) |
(cb (calcFunc-vcompl b))) |
1206 |
(calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b)) |
(calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b)) |
1207 |
(calcFunc-vcompl (calcFunc-vunion a cb))))) |
(calcFunc-vcompl (calcFunc-vunion a cb)))))) |
|
) |
|
1208 |
|
|
1209 |
(defun calcFunc-vcompl (a) |
(defun calcFunc-vcompl (a) |
1210 |
(setq a (math-prepare-set a)) |
(setq a (math-prepare-set a)) |
1227 |
(setq vec (cons (list 'intv (+ closed 1) |
(setq vec (cons (list 'intv (+ closed 1) |
1228 |
prev '(var inf var-inf)) |
prev '(var inf var-inf)) |
1229 |
vec))) |
vec))) |
1230 |
(math-clean-set (nreverse vec))) |
(math-clean-set (nreverse vec)))) |
|
) |
|
1231 |
|
|
1232 |
(defun calcFunc-vspan (a) |
(defun calcFunc-vspan (a) |
1233 |
(setq a (math-prepare-set a)) |
(setq a (math-prepare-set a)) |
1237 |
(logand (nth 1 last) 1)) |
(logand (nth 1 last) 1)) |
1238 |
(nth 2 (nth 1 a)) |
(nth 2 (nth 1 a)) |
1239 |
(nth 3 last))) |
(nth 3 last))) |
1240 |
'(intv 2 0 0)) |
'(intv 2 0 0))) |
|
) |
|
1241 |
|
|
1242 |
(defun calcFunc-vfloor (a &optional always-vec) |
(defun calcFunc-vfloor (a &optional always-vec) |
1243 |
(setq a (math-prepare-set a)) |
(setq a (math-prepare-set a)) |
1263 |
(or (Math-lessp b a) |
(or (Math-lessp b a) |
1264 |
(setq vec (cons (setq prev (list 'intv mask a b)) vec))))) |
(setq vec (cons (setq prev (list 'intv mask a b)) vec))))) |
1265 |
(setq vec (nreverse vec)) |
(setq vec (nreverse vec)) |
1266 |
(math-clean-set vec always-vec)) |
(math-clean-set vec always-vec))) |
|
) |
|
1267 |
|
|
1268 |
(defun calcFunc-vcard (a) |
(defun calcFunc-vcard (a) |
1269 |
(setq a (calcFunc-vfloor a t)) |
(setq a (calcFunc-vfloor a t)) |
1274 |
(setq count (math-add count (math-sub (nth 3 (car a)) |
(setq count (math-add count (math-sub (nth 3 (car a)) |
1275 |
(nth 2 (car a)))))) |
(nth 2 (car a)))))) |
1276 |
(setq count (math-add count 1))) |
(setq count (math-add count 1))) |
1277 |
count) |
count)) |
|
) |
|
1278 |
|
|
1279 |
(defun calcFunc-venum (a) |
(defun calcFunc-venum (a) |
1280 |
(setq a (calcFunc-vfloor a t)) |
(setq a (calcFunc-vfloor a t)) |
1290 |
(nth 2 (nth 1 p)))) |
(nth 2 (nth 1 p)))) |
1291 |
(cdr (cdr p))))) |
(cdr (cdr p))))) |
1292 |
(setq p next)) |
(setq p next)) |
1293 |
a) |
a)) |
|
) |
|
1294 |
|
|
1295 |
(defun calcFunc-vpack (a) |
(defun calcFunc-vpack (a) |
1296 |
(setq a (calcFunc-vfloor a t)) |
(setq a (calcFunc-vfloor a t)) |
1310 |
(math-power-of-2 (1+ (nth 3 (car a)))) |
(math-power-of-2 (1+ (nth 3 (car a)))) |
1311 |
(math-power-of-2 (nth 2 (car a))))))) |
(math-power-of-2 (nth 2 (car a))))))) |
1312 |
(setq accum (math-add accum (math-power-of-2 (car a)))))) |
(setq accum (math-add accum (math-power-of-2 (car a)))))) |
1313 |
accum) |
accum)) |
|
) |
|
1314 |
|
|
1315 |
(defun calcFunc-vunpack (a &optional w) |
(defun calcFunc-vunpack (a &optional w) |
1316 |
(or (math-num-integerp a) (math-reject-arg a 'integerp)) |
(or (math-num-integerp a) (math-reject-arg a 'integerp)) |
1341 |
vec)))) |
vec)))) |
1342 |
(if neg |
(if neg |
1343 |
(setq vec (cons (list 'intv 2 len '(var inf var-inf)) vec))) |
(setq vec (cons (list 'intv 2 len '(var inf var-inf)) vec))) |
1344 |
(math-clean-set (nreverse vec))) |
(math-clean-set (nreverse vec)))) |
|
) |
|
1345 |
|
|
1346 |
(defun calcFunc-rdup (a) |
(defun calcFunc-rdup (a) |
1347 |
(if (math-simple-set a) |
(if (math-simple-set a) |
1355 |
(setcdr p (cdr (cdr p))) |
(setcdr p (cdr (cdr p))) |
1356 |
(setq p (cdr p))))) |
(setq p (cdr p))))) |
1357 |
(cons 'vec a)) |
(cons 'vec a)) |
1358 |
(math-clean-set (math-prepare-set a))) |
(math-clean-set (math-prepare-set a)))) |
|
) |
|
1359 |
|
|
1360 |
(defun math-prepare-set (a) |
(defun math-prepare-set (a) |
1361 |
(if (Math-objectp a) |
(if (Math-objectp a) |
1410 |
(nth 3 (nth 1 p)) |
(nth 3 (nth 1 p)) |
1411 |
(nth 3 (nth 2 p)))) |
(nth 3 (nth 2 p)))) |
1412 |
(cdr (cdr (cdr p)))))))) |
(cdr (cdr (cdr p)))))))) |
1413 |
a |
a) |
|
) |
|
1414 |
|
|
1415 |
(defun math-clean-set (a &optional always-vec) |
(defun math-clean-set (a &optional always-vec) |
1416 |
(let ((p a) res) |
(let ((p a) res) |
1423 |
(eq (car-safe (nth 1 a)) 'intv) |
(eq (car-safe (nth 1 a)) 'intv) |
1424 |
(not always-vec)) |
(not always-vec)) |
1425 |
(nth 1 a) |
(nth 1 a) |
1426 |
a)) |
a))) |
|
) |
|
1427 |
|
|
1428 |
(defun math-simple-set (a) |
(defun math-simple-set (a) |
1429 |
(or (and (Math-objectp a) |
(or (and (Math-objectp a) |
1432 |
(progn |
(progn |
1433 |
(while (and (setq a (cdr a)) |
(while (and (setq a (cdr a)) |
1434 |
(not (eq (car-safe (car a)) 'intv)))) |
(not (eq (car-safe (car a)) 'intv)))) |
1435 |
(null a)))) |
(null a))))) |
|
) |
|
1436 |
|
|
1437 |
|
|
1438 |
|
|
1451 |
(math-sub (math-mul (nth 1 a) (nth 2 b)) |
(math-sub (math-mul (nth 1 a) (nth 2 b)) |
1452 |
(math-mul (nth 2 a) (nth 1 b)))) |
(math-mul (nth 2 a) (nth 1 b)))) |
1453 |
(math-reject-arg b "*Three-vector expected")) |
(math-reject-arg b "*Three-vector expected")) |
1454 |
(math-reject-arg a "*Three-vector expected")) |
(math-reject-arg a "*Three-vector expected"))) |
|
) |
|
1455 |
|
|
1456 |
|
|
1457 |
|
|
1525 |
(throw 'syntax "Expected `]'"))) |
(throw 'syntax "Expected `]'"))) |
1526 |
(or (eq exp-token 'end) |
(or (eq exp-token 'end) |
1527 |
(math-read-token)) |
(math-read-token)) |
1528 |
vals)) |
vals))) |
|
) |
|
1529 |
|
|
1530 |
(defun math-check-for-commas (&optional balancing) |
(defun math-check-for-commas (&optional balancing) |
1531 |
(let ((count 0) |
(let ((count 0) |
1541 |
(setq count (1- count))))) |
(setq count (1- count))))) |
1542 |
(if balancing |
(if balancing |
1543 |
pos |
pos |
1544 |
(and pos (= (aref exp-str pos) ?,)))) |
(and pos (= (aref exp-str pos) ?,))))) |
|
) |
|
1545 |
|
|
1546 |
(defun math-read-vector () |
(defun math-read-vector () |
1547 |
(let* ((val (list (math-read-expr-level 0))) |
(let* ((val (list (math-read-expr-level 0))) |
1561 |
(let ((rest (list (math-read-expr-level 0)))) |
(let ((rest (list (math-read-expr-level 0)))) |
1562 |
(setcdr last rest) |
(setcdr last rest) |
1563 |
(setq last rest))) |
(setq last rest))) |
1564 |
(cons 'vec val)) |
(cons 'vec val))) |
|
) |
|
1565 |
|
|
1566 |
(defun math-read-matrix (mat) |
(defun math-read-matrix (mat) |
1567 |
(while (equal exp-data ";") |
(while (equal exp-data ";") |
1569 |
(while (eq exp-token 'space) |
(while (eq exp-token 'space) |
1570 |
(math-read-token)) |
(math-read-token)) |
1571 |
(setq mat (nconc mat (list (math-read-vector))))) |
(setq mat (nconc mat (list (math-read-vector))))) |
1572 |
mat |
mat) |
|
) |
|
1573 |
|
|
1574 |
|
;;; calc-vec.el ends here |