cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-map.el

   1 ;; Calculator for GNU Emacs, part II [calc-map.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-map () nil)
  30
  31
  32 (defun calc-apply (&optional oper)
  33   (interactive)
  34   (calc-wrapper
  35    (let* ((sel-mode nil)
  36           (calc-dollar-values (mapcar 'calc-get-stack-element
  37                                       (nthcdr calc-stack-top calc-stack)))
  38           (calc-dollar-used 0)
  39           (oper (or oper (calc-get-operator "Apply"
  40                                             (if (math-vectorp (calc-top 1))
  41                                                 (1- (length (calc-top 1)))
  42                                               -1))))
  43           (expr (calc-top-n (1+ calc-dollar-used))))
  44      (message "Working...")
  45      (calc-set-command-flag 'clear-message)
  46      (calc-enter-result (1+ calc-dollar-used)
  47                         (concat (substring "apl" 0 (- 4 (length (nth 2 oper))))
  48                                 (nth 2 oper))
  49                         (list 'calcFunc-apply
  50                               (math-calcFunc-to-var (nth 1 oper))
  51                               expr))))
  52 )
  53
  54 (defun calc-reduce (&optional oper accum)
  55   (interactive)
  56   (calc-wrapper
  57    (let* ((sel-mode nil)
  58           (nest (calc-is-hyperbolic))
  59           (rev (calc-is-inverse))
  60           (nargs (if (and nest (not rev)) 2 1))
  61           (calc-dollar-values (mapcar 'calc-get-stack-element
  62                                       (nthcdr calc-stack-top calc-stack)))
  63           (calc-dollar-used 0)
  64           (calc-mapping-dir (and (not accum) (not nest) ""))
  65           (oper (or oper (calc-get-operator
  66                           (if nest
  67                               (concat (if accum "Accumulate " "")
  68                                       (if rev "Fixed Point" "Nest"))
  69                             (concat (if rev "Inv " "")
  70                                     (if accum "Accumulate" "Reduce")))
  71                           (if nest 1 2)))))
  72      (message "Working...")
  73      (calc-set-command-flag 'clear-message)
  74      (calc-enter-result (+ calc-dollar-used nargs)
  75                         (concat (substring (if nest
  76                                                (if rev "fxp" "nst")
  77                                              (if accum "acc" "red"))
  78                                            0 (- 4 (length (nth 2 oper))))
  79                                 (nth 2 oper))
  80                         (if nest
  81                             (cons (if rev
  82                                       (if accum 'calcFunc-afixp 'calcFunc-fixp)
  83                                     (if accum 'calcFunc-anest 'calcFunc-nest))
  84                                   (cons (math-calcFunc-to-var (nth 1 oper))
  85                                         (calc-top-list-n
  86                                          nargs (1+ calc-dollar-used))))
  87                           (list (if accum
  88                                     (if rev 'calcFunc-raccum 'calcFunc-accum)
  89                                   (intern (concat "calcFunc-"
  90                                                   (if rev "r" "")
  91                                                   "reduce"
  92                                                   calc-mapping-dir)))
  93                                 (math-calcFunc-to-var (nth 1 oper))
  94                                 (calc-top-n (1+ calc-dollar-used)))))))
  95 )
  96
  97 (defun calc-accumulate (&optional oper)
  98   (interactive)
  99   (calc-reduce oper t)
 100 )
 101
 102 (defun calc-map (&optional oper)
 103   (interactive)
 104   (calc-wrapper
 105    (let* ((sel-mode nil)
 106           (calc-dollar-values (mapcar 'calc-get-stack-element
 107                                       (nthcdr calc-stack-top calc-stack)))
 108           (calc-dollar-used 0)
 109           (calc-mapping-dir "")
 110           (oper (or oper (calc-get-operator "Map")))
 111           (nargs (car oper)))
 112      (message "Working...")
 113      (calc-set-command-flag 'clear-message)
 114      (calc-enter-result (+ nargs calc-dollar-used)
 115                         (concat (substring "map" 0 (- 4 (length (nth 2 oper))))
 116                                 (nth 2 oper))
 117                         (cons (intern (concat "calcFunc-map" calc-mapping-dir))
 118                               (cons (math-calcFunc-to-var (nth 1 oper))
 119                                     (calc-top-list-n
 120                                      nargs
 121                                      (1+ calc-dollar-used)))))))
 122 )
 123
 124 (defun calc-map-equation (&optional oper)
 125   (interactive)
 126   (calc-wrapper
 127    (let* ((sel-mode nil)
 128           (calc-dollar-values (mapcar 'calc-get-stack-element
 129                                       (nthcdr calc-stack-top calc-stack)))
 130           (calc-dollar-used 0)
 131           (oper (or oper (calc-get-operator "Map-equation")))
 132           (nargs (car oper)))
 133      (message "Working...")
 134      (calc-set-command-flag 'clear-message)
 135      (calc-enter-result (+ nargs calc-dollar-used)
 136                         (concat (substring "map" 0 (- 4 (length (nth 2 oper))))
 137                                 (nth 2 oper))
 138                         (cons (if (calc-is-inverse)
 139                                   'calcFunc-mapeqr
 140                                 (if (calc-is-hyperbolic)
 141                                     'calcFunc-mapeqp 'calcFunc-mapeq))
 142                               (cons (math-calcFunc-to-var (nth 1 oper))
 143                                     (calc-top-list-n
 144                                      nargs
 145                                      (1+ calc-dollar-used)))))))
 146 )
 147
 148 (defun calc-map-stack ()
 149   "This is meant to be called by calc-keypad mode."
 150   (interactive)
 151   (let ((calc-verify-arglist nil))
 152     (calc-unread-command ?\$)
 153     (calc-map))
 154 )
 155
 156 (defun calc-outer-product (&optional oper)
 157   (interactive)
 158   (calc-wrapper
 159    (let* ((sel-mode nil)
 160           (calc-dollar-values (mapcar 'calc-get-stack-element
 161                                       (nthcdr calc-stack-top calc-stack)))
 162           (calc-dollar-used 0)
 163           (oper (or oper (calc-get-operator "Outer" 2))))
 164      (message "Working...")
 165      (calc-set-command-flag 'clear-message)
 166      (calc-enter-result (+ 2 calc-dollar-used)
 167                         (concat (substring "out" 0 (- 4 (length (nth 2 oper))))
 168                                 (nth 2 oper))
 169                         (cons 'calcFunc-outer
 170                               (cons (math-calcFunc-to-var (nth 1 oper))
 171                                     (calc-top-list-n
 172                                      2 (1+ calc-dollar-used)))))))
 173 )
 174
 175 (defun calc-inner-product (&optional mul-oper add-oper)
 176   (interactive)
 177   (calc-wrapper
 178    (let* ((sel-mode nil)
 179           (calc-dollar-values (mapcar 'calc-get-stack-element
 180                                       (nthcdr calc-stack-top calc-stack)))
 181           (calc-dollar-used 0)
 182           (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2)))
 183           (mul-used calc-dollar-used)
 184           (calc-dollar-values (if (> mul-used 0)
 185                                   (cdr calc-dollar-values)
 186                                 calc-dollar-values))
 187           (calc-dollar-used 0)
 188           (add-oper (or add-oper (calc-get-operator "Inner (Add)" 2))))
 189      (message "Working...")
 190      (calc-set-command-flag 'clear-message)
 191      (calc-enter-result (+ 2 mul-used calc-dollar-used)
 192                         (concat "in"
 193                                 (substring (nth 2 mul-oper) 0 1)
 194                                 (substring (nth 2 add-oper) 0 1))
 195                         (nconc (list 'calcFunc-inner
 196                                      (math-calcFunc-to-var (nth 1 mul-oper))
 197                                      (math-calcFunc-to-var (nth 1 add-oper)))
 198                                (calc-top-list-n
 199                                 2 (+ 1 mul-used calc-dollar-used))))))
 200 )
 201
 202 ;;; Return a list of the form (nargs func name)
 203 (defun calc-get-operator (msg &optional nargs)
 204   (setq calc-aborted-prefix nil)
 205   (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil)
 206         done key oper (which 0)
 207         (msgs '( "(Press ? for help)"
 208                  "+, -, *, /, ^, %, \\, :, &, !, |, Neg"
 209                  "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
 210                  "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
 211                  "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc."
 212                  "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
 213                  "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
 214                  "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc."
 215                  "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc."
 216                  "Time/date + newYear, Incmonth, etc."
 217                  "Vectors + Length, Row, Col, Diag, Mask, etc."
 218                  "_ = mapr/reducea, : = mapc/reduced, = = reducer"
 219                  "X or Z = any function by name; ' = alg entry; $ = stack")))
 220     (while (not done)
 221       (message "%s%s: %s: %s%s%s"
 222                msg
 223                (cond ((equal calc-mapping-dir "r") " rows")
 224                      ((equal calc-mapping-dir "c") " columns")
 225                      ((equal calc-mapping-dir "a") " across")
 226                      ((equal calc-mapping-dir "d") " down")
 227                      (t ""))
 228                (if forcenargs
 229                    (format "(%d arg%s)"
 230                            forcenargs (if (= forcenargs 1) "" "s"))
 231                  (nth which msgs))
 232                (if inv "Inv " "") (if hyp "Hyp " "")
 233                (if prefix (concat (char-to-string prefix) "-") ""))
 234       (setq key (read-char))
 235       (if (>= key 128) (setq key (- key 128)))
 236       (cond ((memq key '(?\C-g ?q))
 237              (keyboard-quit))
 238             ((memq key '(?\C-u ?\e)))
 239             ((= key ??)
 240              (setq which (% (1+ which) (length msgs))))
 241             ((and (= key ?I) (null prefix))
 242              (setq inv (not inv)))
 243             ((and (= key ?H) (null prefix))
 244              (setq hyp (not hyp)))
 245             ((and (eq key prefix) (not (eq key ?v)))
 246              (setq prefix nil))
 247             ((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V))
 248                   (null prefix))
 249              (setq prefix (downcase key)))
 250             ((and (eq key ?\=) (null prefix))
 251              (if calc-mapping-dir
 252                  (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
 253                                             "" "r"))
 254                (beep)))
 255             ((and (eq key ?\_) (null prefix))
 256              (if calc-mapping-dir
 257                  (if (string-match "map$" msg)
 258                      (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
 259                                                 "" "r"))
 260                    (setq calc-mapping-dir (if (equal calc-mapping-dir "a")
 261                                               "" "a")))
 262                (beep)))
 263             ((and (eq key ?\:) (null prefix))
 264              (if calc-mapping-dir
 265                  (if (string-match "map$" msg)
 266                      (setq calc-mapping-dir (if (equal calc-mapping-dir "c")
 267                                                 "" "c"))
 268                    (setq calc-mapping-dir (if (equal calc-mapping-dir "d")
 269                                               "" "d")))
 270                (beep)))
 271             ((and (>= key ?0) (<= key ?9) (null prefix))
 272              (setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0)))
 273              (and nargs forcenargs (/= nargs forcenargs) (>= nargs 0)
 274                   (error "Must be a %d-argument operator" nargs)))
 275             ((memq key '(?\$ ?\'))
 276              (let* ((arglist nil)
 277                     (has-args nil)
 278                     (record-entry nil)
 279                     (expr (if (eq key ?\$)
 280                               (progn
 281                                 (setq calc-dollar-used 1)
 282                                 (if calc-dollar-values
 283                                     (car calc-dollar-values)
 284                                   (error "Stack underflow")))
 285                             (let* ((calc-dollar-values calc-arg-values)
 286                                    (calc-dollar-used 0)
 287                                    (calc-hashes-used 0)
 288                                    (func (calc-do-alg-entry "" "Function: ")))
 289                               (setq record-entry t)
 290                               (or (= (length func) 1)
 291                                   (error "Bad format"))
 292                               (if (> calc-dollar-used 0)
 293                                   (progn
 294                                     (setq has-args calc-dollar-used
 295                                           arglist (calc-invent-args has-args))
 296                                     (math-multi-subst (car func)
 297                                                       (reverse arglist)
 298                                                       arglist))
 299                                 (if (> calc-hashes-used 0)
 300                                     (setq has-args calc-hashes-used
 301                                           arglist (calc-invent-args has-args)))
 302                                 (car func))))))
 303                (if (eq (car-safe expr) 'calcFunc-lambda)
 304                    (setq oper (list "$" (- (length expr) 2) expr)
 305                          done t)
 306                  (or has-args
 307                      (progn
 308                        (calc-default-formula-arglist expr)
 309                        (setq record-entry t
 310                              arglist (sort arglist 'string-lessp))
 311                        (if calc-verify-arglist
 312                            (setq arglist (read-from-minibuffer
 313                                           "Function argument list: "
 314                                           (if arglist
 315                                               (prin1-to-string arglist)
 316                                             "()")
 317                                           minibuffer-local-map
 318                                           t)))
 319                        (setq arglist (mapcar (function
 320                                               (lambda (x)
 321                                                 (list 'var
 322                                                       x
 323                                                       (intern
 324                                                        (concat
 325                                                         "var-"
 326                                                         (symbol-name x))))))
 327                                              arglist))))
 328                  (setq oper (list "$"
 329                                   (length arglist)
 330                                   (append '(calcFunc-lambda) arglist
 331                                           (list expr)))
 332                        done t))
 333                (if record-entry
 334                    (calc-record (nth 2 oper) "oper"))))
 335             ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0))
 336                                        (if prefix
 337                                            (symbol-value
 338                                             (intern (format "calc-%c-oper-keys"
 339                                                             prefix)))
 340                                          calc-oper-keys))))
 341              (if (eq (nth 1 oper) 'user)
 342                  (let ((func (intern
 343                               (completing-read "Function name: "
 344                                                obarray 'fboundp
 345                                                nil "calcFunc-"))))
 346                    (if (or forcenargs nargs)
 347                        (setq oper (list "z" (or forcenargs nargs) func)
 348                              done t)
 349                      (if (fboundp func)
 350                          (let* ((defn (symbol-function func)))
 351                            (and (symbolp defn)
 352                                 (setq defn (symbol-function defn)))
 353                            (if (eq (car-safe defn) 'lambda)
 354                                (let ((args (nth 1 defn))
 355                                      (nargs 0))
 356                                  (while (not (memq (car args) '(&optional
 357                                                                 &rest nil)))
 358                                    (setq nargs (1+ nargs)
 359                                          args (cdr args)))
 360                                  (setq oper (list "z" nargs func)
 361                                        done t))
 362                              (error
 363                               "Function is not suitable for this operation")))
 364                        (message "Number of arguments: ")
 365                        (let ((nargs (read-char)))
 366                          (if (and (>= nargs ?0) (<= nargs ?9))
 367                              (setq oper (list "z" (- nargs ?0) func)
 368                                    done t)
 369                            (beep))))))
 370                (if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U)))
 371                        (and (eq prefix ?a) (eq key ?M)))
 372                    (let* ((dir (cond ((and (equal calc-mapping-dir "")
 373                                            (string-match "map$" msg))
 374                                       (setq calc-mapping-dir "r")
 375                                       " rows")
 376                                      ((equal calc-mapping-dir "r") " rows")
 377                                      ((equal calc-mapping-dir "c") " columns")
 378                                      ((equal calc-mapping-dir "a") " across")
 379                                      ((equal calc-mapping-dir "d") " down")
 380                                      (t "")))
 381                           (calc-mapping-dir (and (memq (nth 2 oper)
 382                                                        '(calcFunc-map
 383                                                          calcFunc-reduce
 384                                                          calcFunc-rreduce))
 385                                                  ""))
 386                           (oper2 (calc-get-operator
 387                                   (format "%s%s, %s%s" msg dir
 388                                           (substring (symbol-name (nth 2 oper))
 389                                                      9)
 390                                           (if (eq key ?I) " (mult)" ""))
 391                                   (cdr (assq (nth 2 oper)
 392                                              '((calcFunc-reduce  . 2)
 393                                                (calcFunc-rreduce . 2)
 394                                                (calcFunc-accum   . 2)
 395                                                (calcFunc-raccum  . 2)
 396                                                (calcFunc-nest    . 2)
 397                                                (calcFunc-anest   . 2)
 398                                                (calcFunc-fixp    . 2)
 399                                                (calcFunc-afixp   . 2))))))
 400                           (oper3 (if (eq (nth 2 oper) 'calcFunc-inner)
 401                                      (calc-get-operator
 402                                       (format "%s%s, inner (add)" msg dir
 403                                               (substring
 404                                                (symbol-name (nth 2 oper))
 405                                                9)))
 406                                    '(0 0 0)))
 407                           (args nil)
 408                           (nargs (if (> (nth 1 oper) 0)
 409                                      (nth 1 oper)
 410                                    (car oper2)))
 411                           (n nargs)
 412                           (p calc-arg-values))
 413                      (while (and p (> n 0))
 414                        (or (math-expr-contains (nth 1 oper2) (car p))
 415                            (math-expr-contains (nth 1 oper3) (car p))
 416                            (setq args (nconc args (list (car p)))
 417                                  n (1- n)))
 418                        (setq p (cdr p)))
 419                      (setq oper (list "" nargs
 420                                       (append
 421                                        '(calcFunc-lambda)
 422                                        args
 423                                        (list (math-build-call
 424                                               (intern
 425                                                (concat
 426                                                 (symbol-name (nth 2 oper))
 427                                                 calc-mapping-dir))
 428                                               (cons (math-calcFunc-to-var
 429                                                      (nth 1 oper2))
 430                                                     (if (eq key ?I)
 431                                                         (cons
 432                                                          (math-calcFunc-to-var
 433                                                           (nth 1 oper3))
 434                                                          args)
 435                                                       args))))))
 436                            done t))
 437                  (setq done t))))
 438             (t (beep))))
 439     (and nargs (>= nargs 0)
 440          (/= nargs (nth 1 oper))
 441          (error "Must be a %d-argument operator" nargs))
 442     (append (if forcenargs
 443                 (cons forcenargs (cdr (cdr oper)))
 444               (cdr oper))
 445             (list
 446              (let ((name (concat (if inv "I" "") (if hyp "H" "")
 447                                  (if prefix (char-to-string prefix) "")
 448                                  (char-to-string key))))
 449                (if (> (length name) 3)
 450                    (substring name 0 3)
 451                  name)))))
 452 )
 453 (setq calc-verify-arglist t)
 454 (setq calc-mapping-dir nil)
 455
 456 (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )
 457                               ( ?- 2 calcFunc-sub )
 458                               ( ?* 2 calcFunc-mul )
 459                               ( ?/ 2 calcFunc-div )
 460                               ( ?^ 2 calcFunc-pow )
 461                               ( ?| 2 calcFunc-vconcat )
 462                               ( ?% 2 calcFunc-mod )
 463                               ( ?\\ 2 calcFunc-idiv )
 464                               ( ?! 1 calcFunc-fact )
 465                               ( ?& 1 calcFunc-inv )
 466                               ( ?n 1 calcFunc-neg )
 467                               ( ?x user )
 468                               ( ?z user )
 469                               ( ?A 1 calcFunc-abs )
 470                               ( ?J 1 calcFunc-conj )
 471                               ( ?G 1 calcFunc-arg )
 472                               ( ?Q 1 calcFunc-sqrt )
 473                               ( ?N 2 calcFunc-min )
 474                               ( ?X 2 calcFunc-max )
 475                               ( ?F 1 calcFunc-floor )
 476                               ( ?R 1 calcFunc-round )
 477                               ( ?S 1 calcFunc-sin )
 478                               ( ?C 1 calcFunc-cos )
 479                               ( ?T 1 calcFunc-tan )
 480                               ( ?L 1 calcFunc-ln )
 481                               ( ?E 1 calcFunc-exp )
 482                               ( ?B 2 calcFunc-log ) )
 483                             ( ( ?F 1 calcFunc-ceil )     ; inverse
 484                               ( ?R 1 calcFunc-trunc )
 485                               ( ?Q 1 calcFunc-sqr )
 486                               ( ?S 1 calcFunc-arcsin )
 487                               ( ?C 1 calcFunc-arccos )
 488                               ( ?T 1 calcFunc-arctan )
 489                               ( ?L 1 calcFunc-exp )
 490                               ( ?E 1 calcFunc-ln )
 491                               ( ?B 2 calcFunc-alog )
 492                               ( ?^ 2 calcFunc-nroot )
 493                               ( ?| 2 calcFunc-vconcatrev ) )
 494                             ( ( ?F 1 calcFunc-ffloor )   ; hyperbolic
 495                               ( ?R 1 calcFunc-fround )
 496                               ( ?S 1 calcFunc-sinh )
 497                               ( ?C 1 calcFunc-cosh )
 498                               ( ?T 1 calcFunc-tanh )
 499                               ( ?L 1 calcFunc-log10 )
 500                               ( ?E 1 calcFunc-exp10 )
 501                               ( ?| 2 calcFunc-append ) )
 502                             ( ( ?F 1 calcFunc-fceil )    ; inverse-hyperbolic
 503                               ( ?R 1 calcFunc-ftrunc )
 504                               ( ?S 1 calcFunc-arcsinh )
 505                               ( ?C 1 calcFunc-arccosh )
 506                               ( ?T 1 calcFunc-arctanh )
 507                               ( ?L 1 calcFunc-exp10 )
 508                               ( ?E 1 calcFunc-log10 )
 509                               ( ?| 2 calcFunc-appendrev ) )
 510 ))
 511 (defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart )
 512                                 ( ?b 3 calcFunc-subst )
 513                                 ( ?c 2 calcFunc-collect )
 514                                 ( ?d 2 calcFunc-deriv )
 515                                 ( ?e 1 calcFunc-esimplify )
 516                                 ( ?f 2 calcFunc-factor )
 517                                 ( ?g 2 calcFunc-pgcd )
 518                                 ( ?i 2 calcFunc-integ )
 519                                 ( ?m 2 calcFunc-match )
 520                                 ( ?n 1 calcFunc-nrat )
 521                                 ( ?r 2 calcFunc-rewrite )
 522                                 ( ?s 1 calcFunc-simplify )
 523                                 ( ?t 3 calcFunc-taylor )
 524                                 ( ?x 1 calcFunc-expand )
 525                                 ( ?M 2 calcFunc-mapeq )
 526                                 ( ?N 3 calcFunc-minimize )
 527                                 ( ?P 2 calcFunc-roots )
 528                                 ( ?R 3 calcFunc-root )
 529                                 ( ?S 2 calcFunc-solve )
 530                                 ( ?T 4 calcFunc-table )
 531                                 ( ?X 3 calcFunc-maximize )
 532                                 ( ?= 2 calcFunc-eq )
 533                                 ( ?\# 2 calcFunc-neq )
 534                                 ( ?< 2 calcFunc-lt )
 535                                 ( ?> 2 calcFunc-gt )
 536                                 ( ?\[ 2 calcFunc-leq )
 537                                 ( ?\] 2 calcFunc-geq )
 538                                 ( ?{ 2 calcFunc-in )
 539                                 ( ?! 1 calcFunc-lnot )
 540                                 ( ?& 2 calcFunc-land )
 541                                 ( ?\| 2 calcFunc-lor )
 542                                 ( ?: 3 calcFunc-if )
 543                                 ( ?. 2 calcFunc-rmeq )
 544                                 ( ?+ 4 calcFunc-sum )
 545                                 ( ?- 4 calcFunc-asum )
 546                                 ( ?* 4 calcFunc-prod )
 547                                 ( ?_ 2 calcFunc-subscr )
 548                                 ( ?\\ 2 calcFunc-pdiv )
 549                                 ( ?% 2 calcFunc-prem )
 550                                 ( ?/ 2 calcFunc-pdivrem ) )
 551                               ( ( ?m 2 calcFunc-matchnot )
 552                                 ( ?M 2 calcFunc-mapeqr )
 553                                 ( ?S 2 calcFunc-finv ) )
 554                               ( ( ?d 2 calcFunc-tderiv )
 555                                 ( ?f 2 calcFunc-factors )
 556                                 ( ?M 2 calcFunc-mapeqp )
 557                                 ( ?N 3 calcFunc-wminimize )
 558                                 ( ?R 3 calcFunc-wroot )
 559                                 ( ?S 2 calcFunc-fsolve )
 560                                 ( ?X 3 calcFunc-wmaximize )
 561                                 ( ?/ 2 calcFunc-pdivide ) )
 562                               ( ( ?S 2 calcFunc-ffinv ) )
 563 ))
 564 (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )
 565                                 ( ?o 2 calcFunc-or )
 566                                 ( ?x 2 calcFunc-xor )
 567                                 ( ?d 2 calcFunc-diff )
 568                                 ( ?n 1 calcFunc-not )
 569                                 ( ?c 1 calcFunc-clip )
 570                                 ( ?l 2 calcFunc-lsh )
 571                                 ( ?r 2 calcFunc-rsh )
 572                                 ( ?L 2 calcFunc-ash )
 573                                 ( ?R 2 calcFunc-rash )
 574                                 ( ?t 2 calcFunc-rot )
 575                                 ( ?p 1 calcFunc-vpack )
 576                                 ( ?u 1 calcFunc-vunpack )
 577                                 ( ?D 4 calcFunc-ddb )
 578                                 ( ?F 3 calcFunc-fv )
 579                                 ( ?I 1 calcFunc-irr )
 580                                 ( ?M 3 calcFunc-pmt )
 581                                 ( ?N 2 calcFunc-npv )
 582                                 ( ?P 3 calcFunc-pv )
 583                                 ( ?S 3 calcFunc-sln )
 584                                 ( ?T 3 calcFunc-rate )
 585                                 ( ?Y 4 calcFunc-syd )
 586                                 ( ?\# 3 calcFunc-nper )
 587                                 ( ?\% 2 calcFunc-relch ) )
 588                               ( ( ?F 3 calcFunc-fvb )
 589                                 ( ?I 1 calcFunc-irrb )
 590                                 ( ?M 3 calcFunc-pmtb )
 591                                 ( ?N 2 calcFunc-npvb )
 592                                 ( ?P 3 calcFunc-pvb )
 593                                 ( ?T 3 calcFunc-rateb )
 594                                 ( ?\# 3 calcFunc-nperb ) )
 595                               ( ( ?F 3 calcFunc-fvl )
 596                                 ( ?M 3 calcFunc-pmtl )
 597                                 ( ?P 3 calcFunc-pvl )
 598                                 ( ?T 3 calcFunc-ratel )
 599                                 ( ?\# 3 calcFunc-nperl ) )
 600 ))
 601 (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )
 602                                 ( ?r 1 calcFunc-rad )
 603                                 ( ?h 1 calcFunc-hms )
 604                                 ( ?f 1 calcFunc-float )
 605                                 ( ?F 1 calcFunc-frac ) )
 606 ))
 607 (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )
 608                                 ( ?e 1 calcFunc-erf )
 609                                 ( ?g 1 calcFunc-gamma )
 610                                 ( ?h 2 calcFunc-hypot )
 611                                 ( ?i 1 calcFunc-im )
 612                                 ( ?j 2 calcFunc-besJ )
 613                                 ( ?n 2 calcFunc-min )
 614                                 ( ?r 1 calcFunc-re )
 615                                 ( ?s 1 calcFunc-sign )
 616                                 ( ?x 2 calcFunc-max )
 617                                 ( ?y 2 calcFunc-besY )
 618                                 ( ?A 1 calcFunc-abssqr )
 619                                 ( ?B 3 calcFunc-betaI )
 620                                 ( ?E 1 calcFunc-expm1 )
 621                                 ( ?G 2 calcFunc-gammaP )
 622                                 ( ?I 2 calcFunc-ilog )
 623                                 ( ?L 1 calcFunc-lnp1 )
 624                                 ( ?M 1 calcFunc-mant )
 625                                 ( ?Q 1 calcFunc-isqrt )
 626                                 ( ?S 1 calcFunc-scf )
 627                                 ( ?T 2 calcFunc-arctan2 )
 628                                 ( ?X 1 calcFunc-xpon )
 629                                 ( ?\[ 2 calcFunc-decr )
 630                                 ( ?\] 2 calcFunc-incr ) )
 631                               ( ( ?e 1 calcFunc-erfc )
 632                                 ( ?E 1 calcFunc-lnp1 )
 633                                 ( ?G 2 calcFunc-gammaQ )
 634                                 ( ?L 1 calcFunc-expm1 ) )
 635                               ( ( ?B 3 calcFunc-betaB )
 636                                 ( ?G 2 calcFunc-gammag) )
 637                               ( ( ?G 2 calcFunc-gammaG ) )
 638 ))
 639 (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )
 640                                 ( ?c 2 calcFunc-choose )
 641                                 ( ?d 1 calcFunc-dfact )
 642                                 ( ?e 1 calcFunc-euler )
 643                                 ( ?f 1 calcFunc-prfac )
 644                                 ( ?g 2 calcFunc-gcd )
 645                                 ( ?h 2 calcFunc-shuffle )
 646                                 ( ?l 2 calcFunc-lcm )
 647                                 ( ?m 1 calcFunc-moebius )
 648                                 ( ?n 1 calcFunc-nextprime )
 649                                 ( ?r 1 calcFunc-random )
 650                                 ( ?s 2 calcFunc-stir1 )
 651                                 ( ?t 1 calcFunc-totient )
 652                                 ( ?B 3 calcFunc-utpb )
 653                                 ( ?C 2 calcFunc-utpc )
 654                                 ( ?F 3 calcFunc-utpf )
 655                                 ( ?N 3 calcFunc-utpn )
 656                                 ( ?P 2 calcFunc-utpp )
 657                                 ( ?T 2 calcFunc-utpt ) )
 658                               ( ( ?n 1 calcFunc-prevprime )
 659                                 ( ?B 3 calcFunc-ltpb )
 660                                 ( ?C 2 calcFunc-ltpc )
 661                                 ( ?F 3 calcFunc-ltpf )
 662                                 ( ?N 3 calcFunc-ltpn )
 663                                 ( ?P 2 calcFunc-ltpp )
 664                                 ( ?T 2 calcFunc-ltpt ) )
 665                               ( ( ?b 2 calcFunc-bern )
 666                                 ( ?c 2 calcFunc-perm )
 667                                 ( ?e 2 calcFunc-euler )
 668                                 ( ?s 2 calcFunc-stir2 ) )
 669 ))
 670 (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )
 671                                 ( ?= 1 calcFunc-evalto ) )
 672 ))
 673 (defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv )
 674                                 ( ?D 1 calcFunc-date )
 675                                 ( ?I 2 calcFunc-incmonth )
 676                                 ( ?J 1 calcFunc-julian )
 677                                 ( ?M 1 calcFunc-newmonth )
 678                                 ( ?W 1 calcFunc-newweek )
 679                                 ( ?U 1 calcFunc-unixtime )
 680                                 ( ?Y 1 calcFunc-newyear ) )
 681 ))
 682 (defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov )
 683                                 ( ?G 1 calcFunc-vgmean )
 684                                 ( ?M 1 calcFunc-vmean )
 685                                 ( ?N 1 calcFunc-vmin )
 686                                 ( ?S 1 calcFunc-vsdev )
 687                                 ( ?X 1 calcFunc-vmax ) )
 688                               ( ( ?C 2 calcFunc-vpcov )
 689                                 ( ?M 1 calcFunc-vmeane )
 690                                 ( ?S 1 calcFunc-vpsdev ) )
 691                               ( ( ?C 2 calcFunc-vcorr )
 692                                 ( ?G 1 calcFunc-agmean )
 693                                 ( ?M 1 calcFunc-vmedian )
 694                                 ( ?S 1 calcFunc-vvar ) )
 695                               ( ( ?M 1 calcFunc-vhmean )
 696                                 ( ?S 1 calcFunc-vpvar ) )
 697 ))
 698 (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )
 699                                 ( ?b 2 calcFunc-cvec )
 700                                 ( ?c 2 calcFunc-mcol )
 701                                 ( ?d 2 calcFunc-diag )
 702                                 ( ?e 2 calcFunc-vexp )
 703                                 ( ?f 2 calcFunc-find )
 704                                 ( ?h 1 calcFunc-head )
 705                                 ( ?k 2 calcFunc-cons )
 706                                 ( ?l 1 calcFunc-vlen )
 707                                 ( ?m 2 calcFunc-vmask )
 708                                 ( ?n 1 calcFunc-rnorm )
 709                                 ( ?p 2 calcFunc-pack )
 710                                 ( ?r 2 calcFunc-mrow )
 711                                 ( ?s 3 calcFunc-subvec )
 712                                 ( ?t 1 calcFunc-trn )
 713                                 ( ?u 1 calcFunc-unpack )
 714                                 ( ?v 1 calcFunc-rev )
 715                                 ( ?x 1 calcFunc-index )
 716                                 ( ?A 1 calcFunc-apply )
 717                                 ( ?C 1 calcFunc-cross )
 718                                 ( ?D 1 calcFunc-det )
 719                                 ( ?E 1 calcFunc-venum )
 720                                 ( ?F 1 calcFunc-vfloor )
 721                                 ( ?G 1 calcFunc-grade )
 722                                 ( ?H 2 calcFunc-histogram )
 723                                 ( ?I 2 calcFunc-inner )
 724                                 ( ?L 1 calcFunc-lud )
 725                                 ( ?M 0 calcFunc-map )
 726                                 ( ?N 1 calcFunc-cnorm )
 727                                 ( ?O 2 calcFunc-outer )
 728                                 ( ?R 1 calcFunc-reduce )
 729                                 ( ?S 1 calcFunc-sort )
 730                                 ( ?T 1 calcFunc-tr )
 731                                 ( ?U 1 calcFunc-accum )
 732                                 ( ?V 2 calcFunc-vunion )
 733                                 ( ?X 2 calcFunc-vxor )
 734                                 ( ?- 2 calcFunc-vdiff )
 735                                 ( ?^ 2 calcFunc-vint )
 736                                 ( ?~ 1 calcFunc-vcompl )
 737                                 ( ?# 1 calcFunc-vcard )
 738                                 ( ?: 1 calcFunc-vspan )
 739                                 ( ?+ 1 calcFunc-rdup ) )
 740                               ( ( ?h 1 calcFunc-tail )
 741                                 ( ?s 3 calcFunc-rsubvec )
 742                                 ( ?G 1 calcFunc-rgrade )
 743                                 ( ?R 1 calcFunc-rreduce )
 744                                 ( ?S 1 calcFunc-rsort )
 745                                 ( ?U 1 calcFunc-raccum ) )
 746                               ( ( ?e 3 calcFunc-vexp )
 747                                 ( ?h 1 calcFunc-rhead )
 748                                 ( ?k 2 calcFunc-rcons )
 749                                 ( ?H 3 calcFunc-histogram )
 750                                 ( ?R 2 calcFunc-nest )
 751                                 ( ?U 2 calcFunc-anest ) )
 752                               ( ( ?h 1 calcFunc-rtail )
 753                                 ( ?R 1 calcFunc-fixp )
 754                                 ( ?U 1 calcFunc-afixp ) )
 755 ))
 756
 757
 758 ;;; Convert a variable name (as a formula) into a like-looking function name.
 759 (defun math-var-to-calcFunc (f)
 760   (if (eq (car-safe f) 'var)
 761       (if (fboundp (nth 2 f))
 762           (nth 2 f)
 763         (intern (concat "calcFunc-" (symbol-name (nth 1 f)))))
 764     (if (memq (car-safe f) '(lambda calcFunc-lambda))
 765         f
 766       (math-reject-arg f "*Expected a function name")))
 767 )
 768
 769 ;;; Convert a function name into a like-looking variable name formula.
 770 (defun math-calcFunc-to-var (f)
 771   (if (symbolp f)
 772       (let* ((func (or (cdr (assq f '( ( + . calcFunc-add )
 773                                        ( - . calcFunc-sub )
 774                                        ( * . calcFunc-mul )
 775                                        ( / . calcFunc-div )
 776                                        ( ^ . calcFunc-pow )
 777                                        ( % . calcFunc-mod )
 778                                        ( neg . calcFunc-neg )
 779                                        ( | . calcFunc-vconcat ) )))
 780                        f))
 781              (base (if (string-match "\\`calcFunc-\\(.+\\)\\'"
 782                                      (symbol-name func))
 783                        (math-match-substring (symbol-name func) 1)
 784                      (symbol-name func))))
 785         (list 'var
 786               (intern base)
 787               (intern (concat "var-" base))))
 788     f)
 789 )
 790
 791 ;;; Expand a function call using "lambda" notation.
 792 (defun math-build-call (f args)
 793   (if (eq (car-safe f) 'calcFunc-lambda)
 794       (if (= (length args) (- (length f) 2))
 795           (math-multi-subst (nth (1- (length f)) f) (cdr f) args)
 796         (calc-record-why "*Wrong number of arguments" f)
 797         (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
 798     (if (and (eq f 'calcFunc-neg)
 799              (= (length args) 1))
 800         (list 'neg (car args))
 801       (let ((func (assq f '( ( calcFunc-add . + )
 802                              ( calcFunc-sub . - )
 803                              ( calcFunc-mul . * )
 804                              ( calcFunc-div . / )
 805                              ( calcFunc-pow . ^ )
 806                              ( calcFunc-mod . % )
 807                              ( calcFunc-vconcat . | ) ))))
 808         (if (and func (= (length args) 2))
 809             (cons (cdr func) args)
 810           (cons f args)))))
 811 )
 812
 813 ;;; Do substitutions in parallel to avoid crosstalk.
 814 (defun math-multi-subst (expr olds news)
 815   (let ((args nil)
 816         temp)
 817     (while (and olds news)
 818       (setq args (cons (cons (car olds) (car news)) args)
 819             olds (cdr olds)
 820             news (cdr news)))
 821     (math-multi-subst-rec expr))
 822 )
 823
 824 (defun math-multi-subst-rec (expr)
 825   (cond ((setq temp (assoc expr args)) (cdr temp))
 826         ((Math-primp expr) expr)
 827         ((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2))
 828          (let ((new (list (car expr)))
 829                (args args))
 830            (while (cdr (setq expr (cdr expr)))
 831              (setq new (cons (car expr) new))
 832              (if (assoc (car expr) args)
 833                  (setq args (cons (cons (car expr) (car expr)) args))))
 834            (nreverse (cons (math-multi-subst-rec (car expr)) new))))
 835         (t
 836          (cons (car expr)
 837                (mapcar 'math-multi-subst-rec (cdr expr)))))
 838 )
 839
 840 (defun calcFunc-call (f &rest args)
 841   (setq args (math-build-call (math-var-to-calcFunc f) args))
 842   (if (eq (car-safe args) 'calcFunc-call)
 843       args
 844     (math-normalize args))
 845 )
 846
 847 (defun calcFunc-apply (f args)
 848   (or (Math-vectorp args)
 849       (math-reject-arg args 'vectorp))
 850   (apply 'calcFunc-call (cons f (cdr args)))
 851 )
 852
 853
 854
 855
 856 ;;; Map a function over a vector symbolically. [Public]
 857 (defun math-symb-map (f mode args)
 858   (let* ((func (math-var-to-calcFunc f))
 859          (nargs (length args))
 860          (ptrs (vconcat args))
 861          (vflags (make-vector nargs nil))
 862          (heads '(vec))
 863          (head nil)
 864          (vec nil)
 865          (i -1)
 866          (math-working-step 0)
 867          (math-working-step-2 nil)
 868          len cols obj expr)
 869     (if (eq mode 'eqn)
 870         (setq mode 'elems
 871               heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt
 872                                   calcFunc-leq calcFunc-geq))
 873       (while (and (< (setq i (1+ i)) nargs)
 874                   (not (math-matrixp (aref ptrs i)))))
 875       (if (< i nargs)
 876           (if (eq mode 'elems)
 877               (setq func (list 'lambda '(&rest x)
 878                                (list 'math-symb-map
 879                                      (list 'quote f) '(quote elems) 'x))
 880                     mode 'rows)
 881             (if (eq mode 'cols)
 882                 (while (< i nargs)
 883                   (if (math-matrixp (aref ptrs i))
 884                       (aset ptrs i (math-transpose (aref ptrs i))))
 885                   (setq i (1+ i)))))
 886         (setq mode 'elems))
 887       (setq i -1))
 888     (while (< (setq i (1+ i)) nargs)
 889       (setq obj (aref ptrs i))
 890       (if (and (memq (car-safe obj) heads)
 891                (or (eq mode 'elems)
 892                    (math-matrixp obj)))
 893           (progn
 894             (aset vflags i t)
 895             (if head
 896                 (if (cdr heads)
 897                     (setq head (nth
 898                                 (aref (aref [ [0 1 2 3 4 5]
 899                                               [1 1 2 3 2 3]
 900                                               [2 2 2 1 2 1]
 901                                               [3 3 1 3 1 3]
 902                                               [4 2 2 1 4 1]
 903                                               [5 3 1 3 1 5] ]
 904                                             (- 6 (length (memq head heads))))
 905                                       (- 6 (length (memq (car obj) heads))))
 906                                 heads)))
 907               (setq head (car obj)))
 908             (if len
 909                 (or (= (length obj) len)
 910                     (math-dimension-error))
 911               (setq len (length obj))))))
 912     (or len
 913         (if (= nargs 1)
 914             (math-reject-arg (aref ptrs 0) 'vectorp)
 915           (math-reject-arg nil "At least one argument must be a vector")))
 916     (setq math-working-step-2 (1- len))
 917     (while (> (setq len (1- len)) 0)
 918       (setq expr nil
 919             i -1)
 920       (while (< (setq i (1+ i)) nargs)
 921         (if (aref vflags i)
 922             (progn
 923               (aset ptrs i (cdr (aref ptrs i)))
 924               (setq expr (nconc expr (list (car (aref ptrs i))))))
 925           (setq expr (nconc expr (list (aref ptrs i))))))
 926       (setq math-working-step (1+ math-working-step)
 927             vec (cons (math-normalize (math-build-call func expr)) vec)))
 928     (setq vec (cons head (nreverse vec)))
 929     (if (and (eq mode 'cols) (math-matrixp vec))
 930         (math-transpose vec)
 931       vec))
 932 )
 933
 934 (defun calcFunc-map (func &rest args)
 935   (math-symb-map func 'elems args)
 936 )
 937
 938 (defun calcFunc-mapr (func &rest args)
 939   (math-symb-map func 'rows args)
 940 )
 941
 942 (defun calcFunc-mapc (func &rest args)
 943   (math-symb-map func 'cols args)
 944 )
 945
 946 (defun calcFunc-mapa (func arg)
 947   (if (math-matrixp arg)
 948       (math-symb-map func 'elems (cdr (math-transpose arg)))
 949     (math-symb-map func 'elems arg))
 950 )
 951
 952 (defun calcFunc-mapd (func arg)
 953   (if (math-matrixp arg)
 954       (math-symb-map func 'elems (cdr arg))
 955     (math-symb-map func 'elems arg))
 956 )
 957
 958 (defun calcFunc-mapeq (func &rest args)
 959   (if (and (or (equal func '(var mul var-mul))
 960                (equal func '(var div var-div)))
 961            (= (length args) 2))
 962       (if (math-negp (car args))
 963           (let ((func (nth 1 (assq (car-safe (nth 1 args))
 964                                    calc-tweak-eqn-table))))
 965             (and func (setq args (list (car args)
 966                                        (cons func (cdr (nth 1 args)))))))
 967         (if (math-negp (nth 1 args))
 968             (let ((func (nth 1 (assq (car-safe (car args))
 969                                      calc-tweak-eqn-table))))
 970               (and func (setq args (list (cons func (cdr (car args)))
 971                                          (nth 1 args))))))))
 972   (if (or (and (equal func '(var div var-div))
 973                (assq (car-safe (nth 1 args)) calc-tweak-eqn-table))
 974           (equal func '(var neg var-neg))
 975           (equal func '(var inv var-inv)))
 976       (apply 'calcFunc-mapeqr func args)
 977     (apply 'calcFunc-mapeqp func args))
 978 )
 979
 980 (defun calcFunc-mapeqr (func &rest args)
 981   (setq args (mapcar (function (lambda (x)
 982                                  (let ((func (assq (car-safe x)
 983                                                    calc-tweak-eqn-table)))
 984                                    (if func
 985                                        (cons (nth 1 func) (cdr x))
 986                                      x))))
 987                      args))
 988   (apply 'calcFunc-mapeqp func args)
 989 )
 990
 991 (defun calcFunc-mapeqp (func &rest args)
 992   (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq))
 993                (memq (car-safe (nth 1 args)) '(calcFunc-gt calcFunc-geq)))
 994           (and (memq (car-safe (car args)) '(calcFunc-gt calcFunc-geq))
 995                (memq (car-safe (nth 1 args)) '(calcFunc-lt calcFunc-leq))))
 996       (setq args (cons (car args)
 997                        (cons (list (nth 1 (assq (car (nth 1 args))
 998                                                 calc-tweak-eqn-table))
 999                                    (nth 2 (nth 1 args))
1000                                    (nth 1 (nth 1 args)))
1001                              (cdr (cdr args))))))
1002   (math-symb-map func 'eqn args)
1003 )
1004
1005
1006
1007 ;;; Reduce a function over a vector symbolically. [Public]
1008 (defun calcFunc-reduce (func vec)
1009   (if (math-matrixp vec)
1010       (let (expr row)
1011         (setq func (math-var-to-calcFunc func))
1012         (while (setq vec (cdr vec))
1013           (setq row (car vec))
1014           (while (setq row (cdr row))
1015             (setq expr (if expr
1016                            (if (Math-numberp expr)
1017                                (math-normalize
1018                                 (math-build-call func (list expr (car row))))
1019                              (math-build-call func (list expr (car row))))
1020                          (car row)))))
1021         (math-normalize expr))
1022     (calcFunc-reducer func vec))
1023 )
1024
1025 (defun calcFunc-rreduce (func vec)
1026   (if (math-matrixp vec)
1027       (let (expr row)
1028         (setq func (math-var-to-calcFunc func)
1029               vec (reverse (cdr vec)))
1030         (while vec
1031           (setq row (reverse (cdr (car vec))))
1032           (while row
1033             (setq expr (if expr
1034                            (math-build-call func (list (car row) expr))
1035                          (car row))
1036                   row (cdr row)))
1037           (setq vec (cdr vec)))
1038         (math-normalize expr))
1039     (calcFunc-rreducer func vec))
1040 )
1041
1042 (defun calcFunc-reducer (func vec)
1043   (setq func (math-var-to-calcFunc func))
1044   (or (math-vectorp vec)
1045       (math-reject-arg vec 'vectorp))
1046   (let ((expr (car (setq vec (cdr vec)))))
1047     (if expr
1048         (progn
1049           (condition-case err
1050               (and (symbolp func)
1051                    (let ((lfunc (or (cdr (assq func
1052                                                '( (calcFunc-add . math-add)
1053                                                   (calcFunc-sub . math-sub)
1054                                                   (calcFunc-mul . math-mul)
1055                                                   (calcFunc-div . math-div)
1056                                                   (calcFunc-pow . math-pow)
1057                                                   (calcFunc-mod . math-mod)
1058                                                   (calcFunc-vconcat .
1059                                                    math-concat) )))
1060                                     lfunc)))
1061                      (while (cdr vec)
1062                        (setq expr (funcall lfunc expr (nth 1 vec))
1063                              vec (cdr vec)))))
1064             (error nil))
1065           (while (setq vec (cdr vec))
1066             (setq expr (math-build-call func (list expr (car vec)))))
1067           (math-normalize expr))
1068       (or (math-identity-value func)
1069           (math-reject-arg vec "*Vector is empty"))))
1070 )
1071
1072 (defun math-identity-value (func)
1073   (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0)
1074                      (calcFunc-mul . 1) (calcFunc-div . 1)
1075                      (calcFunc-idiv . 1) (calcFunc-fdiv . 1)
1076                      (calcFunc-min . (var inf var-inf))
1077                      (calcFunc-max . (neg (var inf var-inf)))
1078                      (calcFunc-vconcat . (vec))
1079                      (calcFunc-append . (vec)) )))
1080 )
1081
1082 (defun calcFunc-rreducer (func vec)
1083   (setq func (math-var-to-calcFunc func))
1084   (or (math-vectorp vec)
1085       (math-reject-arg vec 'vectorp))
1086   (if (eq func 'calcFunc-sub)   ; do this in a way that looks nicer
1087       (let ((expr (car (setq vec (cdr vec)))))
1088         (if expr
1089             (progn
1090               (while (setq vec (cdr vec))
1091                 (setq expr (math-build-call func (list expr (car vec)))
1092                       func (if (eq func 'calcFunc-sub)
1093                                'calcFunc-add 'calcFunc-sub)))
1094               (math-normalize expr))
1095           0))
1096     (let ((expr (car (setq vec (reverse (cdr vec))))))
1097       (if expr
1098           (progn
1099             (while (setq vec (cdr vec))
1100               (setq expr (math-build-call func (list (car vec) expr))))
1101             (math-normalize expr))
1102         (or (math-identity-value func)
1103             (math-reject-arg vec "*Vector is empty")))))
1104 )
1105
1106 (defun calcFunc-reducec (func vec)
1107   (if (math-matrixp vec)
1108       (calcFunc-reducer func (math-transpose vec))
1109     (calcFunc-reducer func vec))
1110 )
1111
1112 (defun calcFunc-rreducec (func vec)
1113   (if (math-matrixp vec)
1114       (calcFunc-rreducer func (math-transpose vec))
1115     (calcFunc-rreducer func vec))
1116 )
1117
1118 (defun calcFunc-reducea (func vec)
1119   (if (math-matrixp vec)
1120       (cons 'vec
1121             (mapcar (function (lambda (x) (calcFunc-reducer func x)))
1122                     (cdr vec)))
1123     (calcFunc-reducer func vec))
1124 )
1125
1126 (defun calcFunc-rreducea (func vec)
1127   (if (math-matrixp vec)
1128       (cons 'vec
1129             (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
1130                     (cdr vec)))
1131     (calcFunc-rreducer func vec))
1132 )
1133
1134 (defun calcFunc-reduced (func vec)
1135   (if (math-matrixp vec)
1136       (cons 'vec
1137             (mapcar (function (lambda (x) (calcFunc-reducer func x)))
1138                     (cdr (math-transpose vec))))
1139     (calcFunc-reducer func vec))
1140 )
1141
1142 (defun calcFunc-rreduced (func vec)
1143   (if (math-matrixp vec)
1144       (cons 'vec
1145             (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
1146                     (cdr (math-transpose vec))))
1147     (calcFunc-rreducer func vec))
1148 )
1149
1150 (defun calcFunc-accum (func vec)
1151   (setq func (math-var-to-calcFunc func))
1152   (or (math-vectorp vec)
1153       (math-reject-arg vec 'vectorp))
1154   (let* ((expr (car (setq vec (cdr vec))))
1155          (res (list 'vec expr)))
1156     (or expr
1157         (math-reject-arg vec "*Vector is empty"))
1158     (while (setq vec (cdr vec))
1159       (setq expr (math-build-call func (list expr (car vec)))
1160             res (nconc res (list expr))))
1161     (math-normalize res))
1162 )
1163
1164 (defun calcFunc-raccum (func vec)
1165   (setq func (math-var-to-calcFunc func))
1166   (or (math-vectorp vec)
1167       (math-reject-arg vec 'vectorp))
1168   (let* ((expr (car (setq vec (reverse (cdr vec)))))
1169          (res (list expr)))
1170     (or expr
1171         (math-reject-arg vec "*Vector is empty"))
1172     (while (setq vec (cdr vec))
1173       (setq expr (math-build-call func (list (car vec) expr))
1174             res (cons (list expr) res)))
1175     (math-normalize (cons 'vec res)))
1176 )
1177
1178
1179 (defun math-nest-calls (func base iters accum tol)
1180   (or (symbolp tol)
1181       (if (math-realp tol)
1182           (or (math-numberp base) (math-reject-arg base 'numberp))
1183         (math-reject-arg tol 'realp)))
1184   (setq func (math-var-to-calcFunc func))
1185   (or (null iters)
1186       (if (equal iters '(var inf var-inf))
1187           (setq iters nil)
1188         (progn
1189           (if (math-messy-integerp iters)
1190               (setq iters (math-trunc iters)))
1191           (or (integerp iters) (math-reject-arg iters 'fixnump))
1192           (or (not tol) (natnump iters) (math-reject-arg iters 'fixnatnump))
1193           (if (< iters 0)
1194               (let* ((dummy '(var DummyArg var-DummyArg))
1195                      (dummy2 '(var DummyArg2 var-DummyArg2))
1196                      (finv (math-solve-for (math-build-call func (list dummy2))
1197                                            dummy dummy2 nil)))
1198                 (or finv (math-reject-arg nil "*Unable to find an inverse"))
1199                 (if (and (= (length finv) 2)
1200                          (equal (nth 1 finv) dummy))
1201                     (setq func (car finv))
1202                   (setq func (list 'calcFunc-lambda dummy finv)))
1203                 (setq iters (- iters)))))))
1204   (math-with-extra-prec 1
1205     (let ((value base)
1206           (ovalue nil)
1207           (avalues (list base))
1208           (math-working-step 0)
1209           (math-working-step-2 iters))
1210       (while (and (or (null iters)
1211                       (>= (setq iters (1- iters)) 0))
1212                   (or (null tol)
1213                       (null ovalue)
1214                       (if (eq tol t)
1215                           (not (if (and (Math-numberp value)
1216                                         (Math-numberp ovalue))
1217                                    (math-nearly-equal value ovalue)
1218                                  (Math-equal value ovalue)))
1219                         (if (math-numberp value)
1220                             (Math-lessp tol (math-abs (math-sub value ovalue)))
1221                           (math-reject-arg value 'numberp)))))
1222         (setq ovalue value
1223               math-working-step (1+ math-working-step)
1224               value (math-normalize (math-build-call func (list value))))
1225         (if accum
1226             (setq avalues (cons value avalues))))
1227       (if accum
1228           (cons 'vec (nreverse avalues))
1229         value)))
1230 )
1231
1232 (defun calcFunc-nest (func base iters)
1233   (math-nest-calls func base iters nil nil)
1234 )
1235
1236 (defun calcFunc-anest (func base iters)
1237   (math-nest-calls func base iters t nil)
1238 )
1239
1240 (defun calcFunc-fixp (func base &optional iters tol)
1241   (math-nest-calls func base iters nil (or tol t))
1242 )
1243
1244 (defun calcFunc-afixp (func base &optional iters tol)
1245   (math-nest-calls func base iters t (or tol t))
1246 )
1247
1248
1249 (defun calcFunc-outer (func a b)
1250   (or (math-vectorp a) (math-reject-arg a 'vectorp))
1251   (or (math-vectorp b) (math-reject-arg b 'vectorp))
1252   (setq func (math-var-to-calcFunc func))
1253   (let ((mat nil))
1254     (while (setq a (cdr a))
1255       (setq mat (cons (cons 'vec
1256                             (mapcar (function (lambda (x)
1257                                                 (math-build-call func
1258                                                                  (list (car a)
1259                                                                        x))))
1260                                     (cdr b)))
1261                       mat)))
1262     (math-normalize (cons 'vec (nreverse mat))))
1263 )
1264
1265
1266 (defun calcFunc-inner (mul-func add-func a b)
1267   (or (math-vectorp a) (math-reject-arg a 'vectorp))
1268   (or (math-vectorp b) (math-reject-arg b 'vectorp))
1269   (if (math-matrixp a)
1270       (if (math-matrixp b)
1271           (if (= (length (nth 1 a)) (length b))
1272               (math-inner-mats a b)
1273             (math-dimension-error))
1274         (if (= (length (nth 1 a)) 2)
1275             (if (= (length a) (length b))
1276                 (math-inner-mats a (list 'vec b))
1277               (math-dimension-error))
1278           (if (= (length (nth 1 a)) (length b))
1279               (math-mat-col (math-inner-mats a (math-col-matrix b))
1280                             1)
1281             (math-dimension-error))))
1282     (if (math-matrixp b)
1283         (nth 1 (math-inner-mats (list 'vec a) b))
1284       (calcFunc-reduce add-func (calcFunc-map mul-func a b))))
1285 )
1286
1287 (defun math-inner-mats (a b)
1288   (let ((mat nil)
1289         (cols (length (nth 1 b)))
1290         row col ap bp accum)
1291     (while (setq a (cdr a))
1292       (setq col cols
1293             row nil)
1294       (while (> (setq col (1- col)) 0)
1295         (setq row (cons (calcFunc-reduce add-func
1296                                          (calcFunc-map mul-func
1297                                                        (car a)
1298                                                        (math-mat-col b col)))
1299                         row)))
1300       (setq mat (cons (cons 'vec row) mat)))
1301     (cons 'vec (nreverse mat)))
1302 )
1303
1304
1305