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