/[emacs]/emacs/lisp/calc/calc-vec.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-vec.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by eliz, Tue Nov 6 18:59:06 2001 UTC revision 1.2 by walters, Wed Nov 14 09:08:24 2001 UTC
# Line 1  Line 1 
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.
# Line 34  Line 34 
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)
# Line 48  Line 47 
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)
# Line 63  Line 61 
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)
# Line 205  Line 202 
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")
# Line 215  Line 211 
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)
# Line 228  Line 223 
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)
# Line 333  Line 327 
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)
# Line 343  Line 336 
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 = ")
# Line 352  Line 344 
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")
# Line 361  Line 352 
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)
# Line 390  Line 378 
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")
# Line 420  Line 404 
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)
# Line 429  Line 412 
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: ")
# Line 478  Line 455 
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")
# Line 598  Line 557 
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")
# Line 613  Line 571 
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.
# Line 622  Line 579 
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
# Line 660  Line 612 
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)
# Line 693  Line 641 
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    
# Line 733  Line 678 
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    
# Line 747  Line 691 
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
# Line 769  Line 710 
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    
# Line 780  Line 720 
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]
# Line 790  Line 729 
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]
# Line 807  Line 745 
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))
# Line 816  Line 753 
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)
# Line 841  Line 776 
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)))
# Line 871  Line 802 
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)
# Line 902  Line 829 
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))
# Line 918  Line 843 
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))
# Line 948  Line 870 
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)
# Line 997  Line 912 
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
# Line 1007  Line 921 
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)
# Line 1021  Line 934 
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)
# Line 1031  Line 943 
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)
# Line 1059  Line 970 
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)
# Line 1071  Line 981 
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)
# Line 1091  Line 1000 
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)
# Line 1110  Line 1018 
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)
# Line 1134  Line 1040 
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)
# Line 1152  Line 1057 
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]
# Line 1164  Line 1068 
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)
# Line 1175  Line 1078 
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.
# Line 1239  Line 1135 
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.
# Line 1253  Line 1148 
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))
# Line 1271  Line 1165 
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))
# Line 1289  Line 1182 
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))
# Line 1312  Line 1204 
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))
# Line 1336  Line 1227 
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))
# Line 1347  Line 1237 
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))
# Line 1374  Line 1263 
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))
# Line 1386  Line 1274 
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))
# Line 1403  Line 1290 
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))
# Line 1424  Line 1310 
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))
# Line 1456  Line 1341 
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)
# Line 1471  Line 1355 
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)
# Line 1527  Line 1410 
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)
# Line 1541  Line 1423 
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)
# Line 1551  Line 1432 
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    
# Line 1571  Line 1451 
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    
# Line 1646  Line 1525 
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)
# Line 1663  Line 1541 
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)))
# Line 1684  Line 1561 
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 ";")
# Line 1693  Line 1569 
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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26