calc-map.el 39.7 KB
Newer Older
1 2
;;; calc-map.el --- higher-order functions for Calc

Jay Belanger's avatar
Jay Belanger committed
3
;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007 Free Software Foundation, Inc.
5 6

;; Author: David Gillespie <daveg@synaptics.com>
Jay Belanger's avatar
Jay Belanger committed
7
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
Eli Zaretskii's avatar
Eli Zaretskii committed
8 9 10

;; This file is part of GNU Emacs.

11 12 13 14 15
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

Eli Zaretskii's avatar
Eli Zaretskii committed
16
;; GNU Emacs is distributed in the hope that it will be useful,
17 18 19 20 21 22 23 24
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Eli Zaretskii's avatar
Eli Zaretskii committed
25

26
;;; Commentary:
Eli Zaretskii's avatar
Eli Zaretskii committed
27

28
;;; Code:
Eli Zaretskii's avatar
Eli Zaretskii committed
29 30 31

;; This file is autoloaded from calc-ext.el.

Jay Belanger's avatar
Jay Belanger committed
32
(require 'calc-ext)
Eli Zaretskii's avatar
Eli Zaretskii committed
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
(require 'calc-macs)

(defun calc-apply (&optional oper)
  (interactive)
  (calc-wrapper
   (let* ((sel-mode nil)
	  (calc-dollar-values (mapcar 'calc-get-stack-element
				      (nthcdr calc-stack-top calc-stack)))
	  (calc-dollar-used 0)
	  (oper (or oper (calc-get-operator "Apply"
					    (if (math-vectorp (calc-top 1))
						(1- (length (calc-top 1)))
					      -1))))
	  (expr (calc-top-n (1+ calc-dollar-used))))
     (message "Working...")
     (calc-set-command-flag 'clear-message)
     (calc-enter-result (1+ calc-dollar-used)
			(concat (substring "apl" 0 (- 4 (length (nth 2 oper))))
				(nth 2 oper))
			(list 'calcFunc-apply
			      (math-calcFunc-to-var (nth 1 oper))
54
			      expr)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95

(defun calc-reduce (&optional oper accum)
  (interactive)
  (calc-wrapper
   (let* ((sel-mode nil)
	  (nest (calc-is-hyperbolic))
	  (rev (calc-is-inverse))
	  (nargs (if (and nest (not rev)) 2 1))
	  (calc-dollar-values (mapcar 'calc-get-stack-element
				      (nthcdr calc-stack-top calc-stack)))
	  (calc-dollar-used 0)
	  (calc-mapping-dir (and (not accum) (not nest) ""))
	  (oper (or oper (calc-get-operator
			  (if nest
			      (concat (if accum "Accumulate " "")
				      (if rev "Fixed Point" "Nest"))
			    (concat (if rev "Inv " "")
				    (if accum "Accumulate" "Reduce")))
			  (if nest 1 2)))))
     (message "Working...")
     (calc-set-command-flag 'clear-message)
     (calc-enter-result (+ calc-dollar-used nargs)
			(concat (substring (if nest
					       (if rev "fxp" "nst")
					     (if accum "acc" "red"))
					   0 (- 4 (length (nth 2 oper))))
				(nth 2 oper))
			(if nest
			    (cons (if rev
				      (if accum 'calcFunc-afixp 'calcFunc-fixp)
				    (if accum 'calcFunc-anest 'calcFunc-nest))
				  (cons (math-calcFunc-to-var (nth 1 oper))
					(calc-top-list-n
					 nargs (1+ calc-dollar-used))))
			  (list (if accum
				    (if rev 'calcFunc-raccum 'calcFunc-accum)
				  (intern (concat "calcFunc-"
						  (if rev "r" "")
						  "reduce"
						  calc-mapping-dir)))
				(math-calcFunc-to-var (nth 1 oper))
96
				(calc-top-n (1+ calc-dollar-used))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
97 98 99

(defun calc-accumulate (&optional oper)
  (interactive)
100
  (calc-reduce oper t))
Eli Zaretskii's avatar
Eli Zaretskii committed
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120

(defun calc-map (&optional oper)
  (interactive)
  (calc-wrapper
   (let* ((sel-mode nil)
	  (calc-dollar-values (mapcar 'calc-get-stack-element
				      (nthcdr calc-stack-top calc-stack)))
	  (calc-dollar-used 0)
	  (calc-mapping-dir "")
	  (oper (or oper (calc-get-operator "Map")))
	  (nargs (car oper)))
     (message "Working...")
     (calc-set-command-flag 'clear-message)
     (calc-enter-result (+ nargs calc-dollar-used)
			(concat (substring "map" 0 (- 4 (length (nth 2 oper))))
				(nth 2 oper))
			(cons (intern (concat "calcFunc-map" calc-mapping-dir))
			      (cons (math-calcFunc-to-var (nth 1 oper))
				    (calc-top-list-n
				     nargs
121
				     (1+ calc-dollar-used))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143

(defun calc-map-equation (&optional oper)
  (interactive)
  (calc-wrapper
   (let* ((sel-mode nil)
	  (calc-dollar-values (mapcar 'calc-get-stack-element
				      (nthcdr calc-stack-top calc-stack)))
	  (calc-dollar-used 0)
	  (oper (or oper (calc-get-operator "Map-equation")))
	  (nargs (car oper)))
     (message "Working...")
     (calc-set-command-flag 'clear-message)
     (calc-enter-result (+ nargs calc-dollar-used)
			(concat (substring "map" 0 (- 4 (length (nth 2 oper))))
				(nth 2 oper))
			(cons (if (calc-is-inverse)
				  'calcFunc-mapeqr
				(if (calc-is-hyperbolic)
				    'calcFunc-mapeqp 'calcFunc-mapeq))
			      (cons (math-calcFunc-to-var (nth 1 oper))
				    (calc-top-list-n
				     nargs
144
				     (1+ calc-dollar-used))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
145

146 147
(defvar calc-verify-arglist t)
(defvar calc-mapping-dir nil)
Eli Zaretskii's avatar
Eli Zaretskii committed
148 149 150 151 152
(defun calc-map-stack ()
  "This is meant to be called by calc-keypad mode."
  (interactive)
  (let ((calc-verify-arglist nil))
    (calc-unread-command ?\$)
153
    (calc-map)))
Eli Zaretskii's avatar
Eli Zaretskii committed
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170

(defun calc-outer-product (&optional oper)
  (interactive)
  (calc-wrapper
   (let* ((sel-mode nil)
	  (calc-dollar-values (mapcar 'calc-get-stack-element
				      (nthcdr calc-stack-top calc-stack)))
	  (calc-dollar-used 0)
	  (oper (or oper (calc-get-operator "Outer" 2))))
     (message "Working...")
     (calc-set-command-flag 'clear-message)
     (calc-enter-result (+ 2 calc-dollar-used)
			(concat (substring "out" 0 (- 4 (length (nth 2 oper))))
				(nth 2 oper))
			(cons 'calcFunc-outer
			      (cons (math-calcFunc-to-var (nth 1 oper))
				    (calc-top-list-n
171
				     2 (1+ calc-dollar-used))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196

(defun calc-inner-product (&optional mul-oper add-oper)
  (interactive)
  (calc-wrapper
   (let* ((sel-mode nil)
	  (calc-dollar-values (mapcar 'calc-get-stack-element
				      (nthcdr calc-stack-top calc-stack)))
	  (calc-dollar-used 0)
	  (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2)))
	  (mul-used calc-dollar-used)
	  (calc-dollar-values (if (> mul-used 0)
				  (cdr calc-dollar-values)
				calc-dollar-values))
	  (calc-dollar-used 0)
	  (add-oper (or add-oper (calc-get-operator "Inner (Add)" 2))))
     (message "Working...")
     (calc-set-command-flag 'clear-message)
     (calc-enter-result (+ 2 mul-used calc-dollar-used)
			(concat "in"
				(substring (nth 2 mul-oper) 0 1)
				(substring (nth 2 add-oper) 0 1))
			(nconc (list 'calcFunc-inner
				     (math-calcFunc-to-var (nth 1 mul-oper))
				     (math-calcFunc-to-var (nth 1 add-oper)))
			       (calc-top-list-n
197
				2 (+ 1 mul-used calc-dollar-used)))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251

(defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )
			      ( ?- 2 calcFunc-sub )
			      ( ?* 2 calcFunc-mul )
			      ( ?/ 2 calcFunc-div )
			      ( ?^ 2 calcFunc-pow )
			      ( ?| 2 calcFunc-vconcat )
			      ( ?% 2 calcFunc-mod )
			      ( ?\\ 2 calcFunc-idiv )
			      ( ?! 1 calcFunc-fact )
			      ( ?& 1 calcFunc-inv )
			      ( ?n 1 calcFunc-neg )
			      ( ?x user )
			      ( ?z user )
			      ( ?A 1 calcFunc-abs )
			      ( ?J 1 calcFunc-conj )
			      ( ?G 1 calcFunc-arg )
			      ( ?Q 1 calcFunc-sqrt )
			      ( ?N 2 calcFunc-min )
			      ( ?X 2 calcFunc-max )
			      ( ?F 1 calcFunc-floor )
			      ( ?R 1 calcFunc-round )
			      ( ?S 1 calcFunc-sin )
			      ( ?C 1 calcFunc-cos )
			      ( ?T 1 calcFunc-tan )
			      ( ?L 1 calcFunc-ln )
			      ( ?E 1 calcFunc-exp )
			      ( ?B 2 calcFunc-log ) )
			    ( ( ?F 1 calcFunc-ceil )     ; inverse
			      ( ?R 1 calcFunc-trunc )
			      ( ?Q 1 calcFunc-sqr )
			      ( ?S 1 calcFunc-arcsin )
			      ( ?C 1 calcFunc-arccos )
			      ( ?T 1 calcFunc-arctan )
			      ( ?L 1 calcFunc-exp )
			      ( ?E 1 calcFunc-ln )
			      ( ?B 2 calcFunc-alog )
			      ( ?^ 2 calcFunc-nroot )
			      ( ?| 2 calcFunc-vconcatrev ) )
			    ( ( ?F 1 calcFunc-ffloor )   ; hyperbolic
			      ( ?R 1 calcFunc-fround )
			      ( ?S 1 calcFunc-sinh )
			      ( ?C 1 calcFunc-cosh )
			      ( ?T 1 calcFunc-tanh )
			      ( ?L 1 calcFunc-log10 )
			      ( ?E 1 calcFunc-exp10 )
			      ( ?| 2 calcFunc-append ) )
			    ( ( ?F 1 calcFunc-fceil )    ; inverse-hyperbolic
			      ( ?R 1 calcFunc-ftrunc )
			      ( ?S 1 calcFunc-arcsinh )
			      ( ?C 1 calcFunc-arccosh )
			      ( ?T 1 calcFunc-arctanh )
			      ( ?L 1 calcFunc-exp10 )
			      ( ?E 1 calcFunc-log10 )
252 253
			      ( ?| 2 calcFunc-appendrev ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304
(defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart )
				( ?b 3 calcFunc-subst )
				( ?c 2 calcFunc-collect )
				( ?d 2 calcFunc-deriv )
				( ?e 1 calcFunc-esimplify )
				( ?f 2 calcFunc-factor )
				( ?g 2 calcFunc-pgcd )
				( ?i 2 calcFunc-integ )
				( ?m 2 calcFunc-match )
				( ?n 1 calcFunc-nrat )
				( ?r 2 calcFunc-rewrite )
				( ?s 1 calcFunc-simplify )
				( ?t 3 calcFunc-taylor )
				( ?x 1 calcFunc-expand )
				( ?M 2 calcFunc-mapeq )
				( ?N 3 calcFunc-minimize )
				( ?P 2 calcFunc-roots )
				( ?R 3 calcFunc-root )
				( ?S 2 calcFunc-solve )
				( ?T 4 calcFunc-table )
				( ?X 3 calcFunc-maximize )
				( ?= 2 calcFunc-eq )
				( ?\# 2 calcFunc-neq )
				( ?< 2 calcFunc-lt )
				( ?> 2 calcFunc-gt )
				( ?\[ 2 calcFunc-leq )
				( ?\] 2 calcFunc-geq )
				( ?{ 2 calcFunc-in )
				( ?! 1 calcFunc-lnot )
				( ?& 2 calcFunc-land )
				( ?\| 2 calcFunc-lor )
				( ?: 3 calcFunc-if )
				( ?. 2 calcFunc-rmeq )
				( ?+ 4 calcFunc-sum )
				( ?- 4 calcFunc-asum )
				( ?* 4 calcFunc-prod )
				( ?_ 2 calcFunc-subscr )
				( ?\\ 2 calcFunc-pdiv )
				( ?% 2 calcFunc-prem )
				( ?/ 2 calcFunc-pdivrem ) )
			      ( ( ?m 2 calcFunc-matchnot )
				( ?M 2 calcFunc-mapeqr )
				( ?S 2 calcFunc-finv ) )
			      ( ( ?d 2 calcFunc-tderiv )
				( ?f 2 calcFunc-factors )
				( ?M 2 calcFunc-mapeqp )
				( ?N 3 calcFunc-wminimize )
				( ?R 3 calcFunc-wroot )
				( ?S 2 calcFunc-fsolve )
				( ?X 3 calcFunc-wmaximize )
				( ?/ 2 calcFunc-pdivide ) )
305 306
			      ( ( ?S 2 calcFunc-ffinv ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
(defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )
				( ?o 2 calcFunc-or )
				( ?x 2 calcFunc-xor )
				( ?d 2 calcFunc-diff )
				( ?n 1 calcFunc-not )
				( ?c 1 calcFunc-clip )
				( ?l 2 calcFunc-lsh )
				( ?r 2 calcFunc-rsh )
				( ?L 2 calcFunc-ash )
				( ?R 2 calcFunc-rash )
				( ?t 2 calcFunc-rot )
				( ?p 1 calcFunc-vpack )
				( ?u 1 calcFunc-vunpack )
				( ?D 4 calcFunc-ddb )
				( ?F 3 calcFunc-fv )
				( ?I 1 calcFunc-irr )
				( ?M 3 calcFunc-pmt )
				( ?N 2 calcFunc-npv )
				( ?P 3 calcFunc-pv )
				( ?S 3 calcFunc-sln )
				( ?T 3 calcFunc-rate )
				( ?Y 4 calcFunc-syd )
				( ?\# 3 calcFunc-nper )
				( ?\% 2 calcFunc-relch ) )
			      ( ( ?F 3 calcFunc-fvb )
				( ?I 1 calcFunc-irrb )
				( ?M 3 calcFunc-pmtb )
				( ?N 2 calcFunc-npvb )
				( ?P 3 calcFunc-pvb )
				( ?T 3 calcFunc-rateb )
				( ?\# 3 calcFunc-nperb ) )
			      ( ( ?F 3 calcFunc-fvl )
				( ?M 3 calcFunc-pmtl )
				( ?P 3 calcFunc-pvl )
				( ?T 3 calcFunc-ratel )
342 343
				( ?\# 3 calcFunc-nperl ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
344 345 346 347
(defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )
				( ?r 1 calcFunc-rad )
				( ?h 1 calcFunc-hms )
				( ?f 1 calcFunc-float )
348 349
				( ?F 1 calcFunc-frac ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379
(defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )
				( ?e 1 calcFunc-erf )
				( ?g 1 calcFunc-gamma )
				( ?h 2 calcFunc-hypot )
				( ?i 1 calcFunc-im )
				( ?j 2 calcFunc-besJ )
				( ?n 2 calcFunc-min )
				( ?r 1 calcFunc-re )
				( ?s 1 calcFunc-sign )
				( ?x 2 calcFunc-max )
				( ?y 2 calcFunc-besY )
				( ?A 1 calcFunc-abssqr )
				( ?B 3 calcFunc-betaI )
				( ?E 1 calcFunc-expm1 )
				( ?G 2 calcFunc-gammaP )
				( ?I 2 calcFunc-ilog )
				( ?L 1 calcFunc-lnp1 )
				( ?M 1 calcFunc-mant )
				( ?Q 1 calcFunc-isqrt )
				( ?S 1 calcFunc-scf )
				( ?T 2 calcFunc-arctan2 )
				( ?X 1 calcFunc-xpon )
				( ?\[ 2 calcFunc-decr )
				( ?\] 2 calcFunc-incr ) )
			      ( ( ?e 1 calcFunc-erfc )
				( ?E 1 calcFunc-lnp1 )
				( ?G 2 calcFunc-gammaQ )
				( ?L 1 calcFunc-expm1 ) )
			      ( ( ?B 3 calcFunc-betaB )
				( ?G 2 calcFunc-gammag) )
380 381
			      ( ( ?G 2 calcFunc-gammaG ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410
(defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )
				( ?c 2 calcFunc-choose )
				( ?d 1 calcFunc-dfact )
				( ?e 1 calcFunc-euler )
				( ?f 1 calcFunc-prfac )
				( ?g 2 calcFunc-gcd )
				( ?h 2 calcFunc-shuffle )
				( ?l 2 calcFunc-lcm )
				( ?m 1 calcFunc-moebius )
				( ?n 1 calcFunc-nextprime )
				( ?r 1 calcFunc-random )
				( ?s 2 calcFunc-stir1 )
				( ?t 1 calcFunc-totient )
				( ?B 3 calcFunc-utpb )
				( ?C 2 calcFunc-utpc )
				( ?F 3 calcFunc-utpf )
				( ?N 3 calcFunc-utpn )
				( ?P 2 calcFunc-utpp )
				( ?T 2 calcFunc-utpt ) )
			      ( ( ?n 1 calcFunc-prevprime )
				( ?B 3 calcFunc-ltpb )
				( ?C 2 calcFunc-ltpc )
				( ?F 3 calcFunc-ltpf )
				( ?N 3 calcFunc-ltpn )
				( ?P 2 calcFunc-ltpp )
				( ?T 2 calcFunc-ltpt ) )
			      ( ( ?b 2 calcFunc-bern )
				( ?c 2 calcFunc-perm )
				( ?e 2 calcFunc-euler )
411 412
				( ?s 2 calcFunc-stir2 ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
413
(defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )
414 415
				( ?= 1 calcFunc-evalto ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
416 417 418 419 420 421 422
(defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv )
				( ?D 1 calcFunc-date )
				( ?I 2 calcFunc-incmonth )
				( ?J 1 calcFunc-julian )
				( ?M 1 calcFunc-newmonth )
				( ?W 1 calcFunc-newweek )
				( ?U 1 calcFunc-unixtime )
423 424
				( ?Y 1 calcFunc-newyear ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
425 426 427 428 429 430 431 432 433 434 435 436 437 438
(defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov )
				( ?G 1 calcFunc-vgmean )
				( ?M 1 calcFunc-vmean )
				( ?N 1 calcFunc-vmin )
				( ?S 1 calcFunc-vsdev )
				( ?X 1 calcFunc-vmax ) )
			      ( ( ?C 2 calcFunc-vpcov )
				( ?M 1 calcFunc-vmeane )
				( ?S 1 calcFunc-vpsdev ) )
			      ( ( ?C 2 calcFunc-vcorr )
				( ?G 1 calcFunc-agmean )
				( ?M 1 calcFunc-vmedian )
				( ?S 1 calcFunc-vvar ) )
			      ( ( ?M 1 calcFunc-vhmean )
439 440
				( ?S 1 calcFunc-vpvar ) )))

Eli Zaretskii's avatar
Eli Zaretskii committed
441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
(defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )
				( ?b 2 calcFunc-cvec )
				( ?c 2 calcFunc-mcol )
				( ?d 2 calcFunc-diag )
				( ?e 2 calcFunc-vexp )
				( ?f 2 calcFunc-find )
				( ?h 1 calcFunc-head )
				( ?k 2 calcFunc-cons )
				( ?l 1 calcFunc-vlen )
				( ?m 2 calcFunc-vmask )
				( ?n 1 calcFunc-rnorm )
				( ?p 2 calcFunc-pack )
				( ?r 2 calcFunc-mrow )
				( ?s 3 calcFunc-subvec )
				( ?t 1 calcFunc-trn )
				( ?u 1 calcFunc-unpack )
				( ?v 1 calcFunc-rev )
				( ?x 1 calcFunc-index )
				( ?A 1 calcFunc-apply )
				( ?C 1 calcFunc-cross )
				( ?D 1 calcFunc-det )
				( ?E 1 calcFunc-venum )
				( ?F 1 calcFunc-vfloor )
				( ?G 1 calcFunc-grade )
				( ?H 2 calcFunc-histogram )
				( ?I 2 calcFunc-inner )
				( ?L 1 calcFunc-lud )
				( ?M 0 calcFunc-map )
				( ?N 1 calcFunc-cnorm )
				( ?O 2 calcFunc-outer )
				( ?R 1 calcFunc-reduce )
				( ?S 1 calcFunc-sort )
				( ?T 1 calcFunc-tr )
				( ?U 1 calcFunc-accum )
				( ?V 2 calcFunc-vunion )
				( ?X 2 calcFunc-vxor )
				( ?- 2 calcFunc-vdiff )
				( ?^ 2 calcFunc-vint )
				( ?~ 1 calcFunc-vcompl )
				( ?# 1 calcFunc-vcard )
				( ?: 1 calcFunc-vspan )
				( ?+ 1 calcFunc-rdup ) )
			      ( ( ?h 1 calcFunc-tail )
				( ?s 3 calcFunc-rsubvec )
				( ?G 1 calcFunc-rgrade )
				( ?R 1 calcFunc-rreduce )
				( ?S 1 calcFunc-rsort )
				( ?U 1 calcFunc-raccum ) )
			      ( ( ?e 3 calcFunc-vexp )
				( ?h 1 calcFunc-rhead )
				( ?k 2 calcFunc-rcons )
				( ?H 3 calcFunc-histogram )
				( ?R 2 calcFunc-nest )
				( ?U 2 calcFunc-anest ) )
			      ( ( ?h 1 calcFunc-rtail )
				( ?R 1 calcFunc-fixp )
497 498 499 500
				( ?U 1 calcFunc-afixp ) )))


;;; Return a list of the form (nargs func name)
501 502 503
(defvar calc-get-operator-history nil
  "History for calc-get-operator.")

504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588
(defun calc-get-operator (msg &optional nargs)
  (setq calc-aborted-prefix nil)
  (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil)
	done key oper (which 0)
	(msgs '( "(Press ? for help)"
		 "+, -, *, /, ^, %, \\, :, &, !, |, Neg"
		 "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
		 "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
		 "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc."
		 "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
		 "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
		 "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc."
		 "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc."
		 "Time/date + newYear, Incmonth, etc."
		 "Vectors + Length, Row, Col, Diag, Mask, etc."
		 "_ = mapr/reducea, : = mapc/reduced, = = reducer"
		 "X or Z = any function by name; ' = alg entry; $ = stack")))
    (while (not done)
      (message "%s%s: %s: %s%s%s"
	       msg
	       (cond ((equal calc-mapping-dir "r") " rows")
		     ((equal calc-mapping-dir "c") " columns")
		     ((equal calc-mapping-dir "a") " across")
		     ((equal calc-mapping-dir "d") " down")
		     (t ""))
	       (if forcenargs
		   (format "(%d arg%s)"
			   forcenargs (if (= forcenargs 1) "" "s"))
		 (nth which msgs))
	       (if inv "Inv " "") (if hyp "Hyp " "")
	       (if prefix (concat (char-to-string prefix) "-") ""))
      (setq key (read-char))
      (if (>= key 128) (setq key (- key 128)))
      (cond ((memq key '(?\C-g ?q))
	     (keyboard-quit))
	    ((memq key '(?\C-u ?\e)))
	    ((= key ??)
	     (setq which (% (1+ which) (length msgs))))
	    ((and (= key ?I) (null prefix))
	     (setq inv (not inv)))
	    ((and (= key ?H) (null prefix))
	     (setq hyp (not hyp)))
	    ((and (eq key prefix) (not (eq key ?v)))
	     (setq prefix nil))
	    ((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V))
		  (null prefix))
	     (setq prefix (downcase key)))
	    ((and (eq key ?\=) (null prefix))
	     (if calc-mapping-dir
		 (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
					    "" "r"))
	       (beep)))
	    ((and (eq key ?\_) (null prefix))
	     (if calc-mapping-dir
		 (if (string-match "map$" msg)
		     (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
						"" "r"))
		   (setq calc-mapping-dir (if (equal calc-mapping-dir "a")
					      "" "a")))
	       (beep)))
	    ((and (eq key ?\:) (null prefix))
	     (if calc-mapping-dir
		 (if (string-match "map$" msg)
		     (setq calc-mapping-dir (if (equal calc-mapping-dir "c")
						"" "c"))
		   (setq calc-mapping-dir (if (equal calc-mapping-dir "d")
					      "" "d")))
	       (beep)))
	    ((and (>= key ?0) (<= key ?9) (null prefix))
	     (setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0)))
	     (and nargs forcenargs (/= nargs forcenargs) (>= nargs 0)
		  (error "Must be a %d-argument operator" nargs)))
	    ((memq key '(?\$ ?\'))
	     (let* ((arglist nil)
		    (has-args nil)
		    (record-entry nil)
		    (expr (if (eq key ?\$)
			      (progn
				(setq calc-dollar-used 1)
				(if calc-dollar-values
				    (car calc-dollar-values)
				  (error "Stack underflow")))
			    (let* ((calc-dollar-values calc-arg-values)
				   (calc-dollar-used 0)
				   (calc-hashes-used 0)
589 590
				   (func (calc-do-alg-entry "" "Function: " nil
                                                      'calc-get-operator-history)))
591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703
			      (setq record-entry t)
			      (or (= (length func) 1)
				  (error "Bad format"))
			      (if (> calc-dollar-used 0)
				  (progn
				    (setq has-args calc-dollar-used
					  arglist (calc-invent-args has-args))
				    (math-multi-subst (car func)
						      (reverse arglist)
						      arglist))
				(if (> calc-hashes-used 0)
				    (setq has-args calc-hashes-used
					  arglist (calc-invent-args has-args)))
				(car func))))))
	       (if (eq (car-safe expr) 'calcFunc-lambda)
		   (setq oper (list "$" (- (length expr) 2) expr)
			 done t)
		 (or has-args
		     (progn
		       (calc-default-formula-arglist expr)
		       (setq record-entry t
			     arglist (sort arglist 'string-lessp))
		       (if calc-verify-arglist
			   (setq arglist (read-from-minibuffer
					  "Function argument list: "
					  (if arglist
					      (prin1-to-string arglist)
					    "()")
					  minibuffer-local-map
					  t)))
		       (setq arglist (mapcar (function
					      (lambda (x)
						(list 'var
						      x
						      (intern
						       (concat
							"var-"
							(symbol-name x))))))
					     arglist))))
		 (setq oper (list "$"
				  (length arglist)
				  (append '(calcFunc-lambda) arglist
					  (list expr)))
		       done t))
	       (if record-entry
		   (calc-record (nth 2 oper) "oper"))))
	    ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0))
				       (if prefix
					   (symbol-value
					    (intern (format "calc-%c-oper-keys"
							    prefix)))
					 calc-oper-keys))))
	     (if (eq (nth 1 oper) 'user)
		 (let ((func (intern
			      (completing-read "Function name: "
					       obarray 'fboundp
					       nil "calcFunc-"))))
		   (if (or forcenargs nargs)
		       (setq oper (list "z" (or forcenargs nargs) func)
			     done t)
		     (if (fboundp func)
			 (let* ((defn (symbol-function func)))
			   (and (symbolp defn)
				(setq defn (symbol-function defn)))
			   (if (eq (car-safe defn) 'lambda)
			       (let ((args (nth 1 defn))
				     (nargs 0))
				 (while (not (memq (car args) '(&optional
								&rest nil)))
				   (setq nargs (1+ nargs)
					 args (cdr args)))
				 (setq oper (list "z" nargs func)
				       done t))
			     (error
			      "Function is not suitable for this operation")))
		       (message "Number of arguments: ")
		       (let ((nargs (read-char)))
			 (if (and (>= nargs ?0) (<= nargs ?9))
			     (setq oper (list "z" (- nargs ?0) func)
				   done t)
			   (beep))))))
	       (if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U)))
		       (and (eq prefix ?a) (eq key ?M)))
		   (let* ((dir (cond ((and (equal calc-mapping-dir "")
					   (string-match "map$" msg))
				      (setq calc-mapping-dir "r")
				      " rows")
				     ((equal calc-mapping-dir "r") " rows")
				     ((equal calc-mapping-dir "c") " columns")
				     ((equal calc-mapping-dir "a") " across")
				     ((equal calc-mapping-dir "d") " down")
				     (t "")))
			  (calc-mapping-dir (and (memq (nth 2 oper)
						       '(calcFunc-map
							 calcFunc-reduce
							 calcFunc-rreduce))
						 ""))
			  (oper2 (calc-get-operator
				  (format "%s%s, %s%s" msg dir
					  (substring (symbol-name (nth 2 oper))
						     9)
					  (if (eq key ?I) " (mult)" ""))
				  (cdr (assq (nth 2 oper)
					     '((calcFunc-reduce  . 2)
					       (calcFunc-rreduce . 2)
					       (calcFunc-accum   . 2)
					       (calcFunc-raccum  . 2)
					       (calcFunc-nest    . 2)
					       (calcFunc-anest   . 2)
					       (calcFunc-fixp    . 2)
					       (calcFunc-afixp   . 2))))))
			  (oper3 (if (eq (nth 2 oper) 'calcFunc-inner)
				     (calc-get-operator
704
				      (format "%s%s, inner (add)" msg dir))
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750
				   '(0 0 0)))
			  (args nil)
			  (nargs (if (> (nth 1 oper) 0)
				     (nth 1 oper)
				   (car oper2)))
			  (n nargs)
			  (p calc-arg-values))
		     (while (and p (> n 0))
		       (or (math-expr-contains (nth 1 oper2) (car p))
			   (math-expr-contains (nth 1 oper3) (car p))
			   (setq args (nconc args (list (car p)))
				 n (1- n)))
		       (setq p (cdr p)))
		     (setq oper (list "" nargs
				      (append
				       '(calcFunc-lambda)
				       args
				       (list (math-build-call
					      (intern
					       (concat
						(symbol-name (nth 2 oper))
						calc-mapping-dir))
					      (cons (math-calcFunc-to-var
						     (nth 1 oper2))
						    (if (eq key ?I)
							(cons
							 (math-calcFunc-to-var
							  (nth 1 oper3))
							 args)
						      args))))))
			   done t))
		 (setq done t))))
	    (t (beep))))
    (and nargs (>= nargs 0)
	 (/= nargs (nth 1 oper))
	 (error "Must be a %d-argument operator" nargs))
    (append (if forcenargs
		(cons forcenargs (cdr (cdr oper)))
	      (cdr oper))
	    (list
	     (let ((name (concat (if inv "I" "") (if hyp "H" "")
				 (if prefix (char-to-string prefix) "")
				 (char-to-string key))))
	       (if (> (length name) 3)
		   (substring name 0 3)
		 name))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
751 752 753 754 755 756 757 758 759 760


;;; Convert a variable name (as a formula) into a like-looking function name.
(defun math-var-to-calcFunc (f)
  (if (eq (car-safe f) 'var)
      (if (fboundp (nth 2 f))
	  (nth 2 f)
	(intern (concat "calcFunc-" (symbol-name (nth 1 f)))))
    (if (memq (car-safe f) '(lambda calcFunc-lambda))
	f
761
      (math-reject-arg f "*Expected a function name"))))
Eli Zaretskii's avatar
Eli Zaretskii committed
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781

;;; Convert a function name into a like-looking variable name formula.
(defun math-calcFunc-to-var (f)
  (if (symbolp f)
      (let* ((func (or (cdr (assq f '( ( + . calcFunc-add )
				       ( - . calcFunc-sub )
				       ( * . calcFunc-mul )
				       ( / . calcFunc-div )
				       ( ^ . calcFunc-pow )
				       ( % . calcFunc-mod )
				       ( neg . calcFunc-neg )
				       ( | . calcFunc-vconcat ) )))
		       f))
	     (base (if (string-match "\\`calcFunc-\\(.+\\)\\'"
				     (symbol-name func))
		       (math-match-substring (symbol-name func) 1)
		     (symbol-name func))))
	(list 'var
	      (intern base)
	      (intern (concat "var-" base))))
782
    f))
Eli Zaretskii's avatar
Eli Zaretskii committed
783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802

;;; Expand a function call using "lambda" notation.
(defun math-build-call (f args)
  (if (eq (car-safe f) 'calcFunc-lambda)
      (if (= (length args) (- (length f) 2))
	  (math-multi-subst (nth (1- (length f)) f) (cdr f) args)
	(calc-record-why "*Wrong number of arguments" f)
	(cons 'calcFunc-call (cons (math-calcFunc-to-var f) args)))
    (if (and (eq f 'calcFunc-neg)
	     (= (length args) 1))
	(list 'neg (car args))
      (let ((func (assq f '( ( calcFunc-add . + )
			     ( calcFunc-sub . - )
			     ( calcFunc-mul . * )
			     ( calcFunc-div . / )
			     ( calcFunc-pow . ^ )
			     ( calcFunc-mod . % )
			     ( calcFunc-vconcat . | ) ))))
	(if (and func (= (length args) 2))
	    (cons (cdr func) args)
803
	  (cons f args))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
804 805

;;; Do substitutions in parallel to avoid crosstalk.
806 807 808 809 810 811 812

;; The variables math-ms-temp and math-ms-args are local to 
;; math-multi-subst, but are used by math-multi-subst-rec, which 
;; is called by math-multi-subst.
(defvar math-ms-temp)
(defvar math-ms-args)

Eli Zaretskii's avatar
Eli Zaretskii committed
813
(defun math-multi-subst (expr olds news)
814 815
  (let ((math-ms-args nil)
	math-ms-temp)
Eli Zaretskii's avatar
Eli Zaretskii committed
816
    (while (and olds news)
817
      (setq math-ms-args (cons (cons (car olds) (car news)) math-ms-args)
Eli Zaretskii's avatar
Eli Zaretskii committed
818 819
	    olds (cdr olds)
	    news (cdr news)))
820
    (math-multi-subst-rec expr)))
Eli Zaretskii's avatar
Eli Zaretskii committed
821 822

(defun math-multi-subst-rec (expr)
823 824
  (cond ((setq math-ms-temp (assoc expr math-ms-args)) 
         (cdr math-ms-temp))
Eli Zaretskii's avatar
Eli Zaretskii committed
825 826 827
	((Math-primp expr) expr)
	((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2))
	 (let ((new (list (car expr)))
828
	       (math-ms-args math-ms-args))
Eli Zaretskii's avatar
Eli Zaretskii committed
829 830
	   (while (cdr (setq expr (cdr expr)))
	     (setq new (cons (car expr) new))
831 832 833
	     (if (assoc (car expr) math-ms-args)
		 (setq math-ms-args (cons (cons (car expr) (car expr)) 
                                          math-ms-args))))
Eli Zaretskii's avatar
Eli Zaretskii committed
834 835 836
	   (nreverse (cons (math-multi-subst-rec (car expr)) new))))
	(t
	 (cons (car expr)
837
	       (mapcar 'math-multi-subst-rec (cdr expr))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
838 839 840 841 842

(defun calcFunc-call (f &rest args)
  (setq args (math-build-call (math-var-to-calcFunc f) args))
  (if (eq (car-safe args) 'calcFunc-call)
      args
843
    (math-normalize args)))
Eli Zaretskii's avatar
Eli Zaretskii committed
844 845 846 847

(defun calcFunc-apply (f args)
  (or (Math-vectorp args)
      (math-reject-arg args 'vectorp))
848
  (apply 'calcFunc-call (cons f (cdr args))))
Eli Zaretskii's avatar
Eli Zaretskii committed
849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927




;;; Map a function over a vector symbolically. [Public]
(defun math-symb-map (f mode args)
  (let* ((func (math-var-to-calcFunc f))
	 (nargs (length args))
	 (ptrs (vconcat args))
	 (vflags (make-vector nargs nil))
	 (heads '(vec))
	 (head nil)
	 (vec nil)
	 (i -1)
	 (math-working-step 0)
	 (math-working-step-2 nil)
	 len cols obj expr)
    (if (eq mode 'eqn)
	(setq mode 'elems
	      heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt
				  calcFunc-leq calcFunc-geq))
      (while (and (< (setq i (1+ i)) nargs)
		  (not (math-matrixp (aref ptrs i)))))
      (if (< i nargs)
	  (if (eq mode 'elems)
	      (setq func (list 'lambda '(&rest x)
			       (list 'math-symb-map
				     (list 'quote f) '(quote elems) 'x))
		    mode 'rows)
	    (if (eq mode 'cols)
		(while (< i nargs)
		  (if (math-matrixp (aref ptrs i))
		      (aset ptrs i (math-transpose (aref ptrs i))))
		  (setq i (1+ i)))))
	(setq mode 'elems))
      (setq i -1))
    (while (< (setq i (1+ i)) nargs)
      (setq obj (aref ptrs i))
      (if (and (memq (car-safe obj) heads)
	       (or (eq mode 'elems)
		   (math-matrixp obj)))
	  (progn
	    (aset vflags i t)
	    (if head
		(if (cdr heads)
		    (setq head (nth
				(aref (aref [ [0 1 2 3 4 5]
					      [1 1 2 3 2 3]
					      [2 2 2 1 2 1]
					      [3 3 1 3 1 3]
					      [4 2 2 1 4 1]
					      [5 3 1 3 1 5] ]
					    (- 6 (length (memq head heads))))
				      (- 6 (length (memq (car obj) heads))))
				heads)))
	      (setq head (car obj)))
	    (if len
		(or (= (length obj) len)
		    (math-dimension-error))
	      (setq len (length obj))))))
    (or len
	(if (= nargs 1)
	    (math-reject-arg (aref ptrs 0) 'vectorp)
	  (math-reject-arg nil "At least one argument must be a vector")))
    (setq math-working-step-2 (1- len))
    (while (> (setq len (1- len)) 0)
      (setq expr nil
	    i -1)
      (while (< (setq i (1+ i)) nargs)
	(if (aref vflags i)
	    (progn
	      (aset ptrs i (cdr (aref ptrs i)))
	      (setq expr (nconc expr (list (car (aref ptrs i))))))
	  (setq expr (nconc expr (list (aref ptrs i))))))
      (setq math-working-step (1+ math-working-step)
	    vec (cons (math-normalize (math-build-call func expr)) vec)))
    (setq vec (cons head (nreverse vec)))
    (if (and (eq mode 'cols) (math-matrixp vec))
	(math-transpose vec)
928
      vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
929 930

(defun calcFunc-map (func &rest args)
931
  (math-symb-map func 'elems args))
Eli Zaretskii's avatar
Eli Zaretskii committed
932 933

(defun calcFunc-mapr (func &rest args)
934
  (math-symb-map func 'rows args))
Eli Zaretskii's avatar
Eli Zaretskii committed
935 936

(defun calcFunc-mapc (func &rest args)
937
  (math-symb-map func 'cols args))
Eli Zaretskii's avatar
Eli Zaretskii committed
938 939 940 941

(defun calcFunc-mapa (func arg)
  (if (math-matrixp arg)
      (math-symb-map func 'elems (cdr (math-transpose arg)))
942
    (math-symb-map func 'elems arg)))
Eli Zaretskii's avatar
Eli Zaretskii committed
943 944 945 946

(defun calcFunc-mapd (func arg)
  (if (math-matrixp arg)
      (math-symb-map func 'elems (cdr arg))
947
    (math-symb-map func 'elems arg)))
Eli Zaretskii's avatar
Eli Zaretskii committed
948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967

(defun calcFunc-mapeq (func &rest args)
  (if (and (or (equal func '(var mul var-mul))
	       (equal func '(var div var-div)))
	   (= (length args) 2))
      (if (math-negp (car args))
	  (let ((func (nth 1 (assq (car-safe (nth 1 args))
				   calc-tweak-eqn-table))))
	    (and func (setq args (list (car args)
				       (cons func (cdr (nth 1 args)))))))
	(if (math-negp (nth 1 args))
	    (let ((func (nth 1 (assq (car-safe (car args))
				     calc-tweak-eqn-table))))
	      (and func (setq args (list (cons func (cdr (car args)))
					 (nth 1 args))))))))
  (if (or (and (equal func '(var div var-div))
	       (assq (car-safe (nth 1 args)) calc-tweak-eqn-table))
	  (equal func '(var neg var-neg))
	  (equal func '(var inv var-inv)))
      (apply 'calcFunc-mapeqr func args)
968
    (apply 'calcFunc-mapeqp func args)))
Eli Zaretskii's avatar
Eli Zaretskii committed
969 970 971 972 973 974 975 976 977

(defun calcFunc-mapeqr (func &rest args)
  (setq args (mapcar (function (lambda (x)
				 (let ((func (assq (car-safe x)
						   calc-tweak-eqn-table)))
				   (if func
				       (cons (nth 1 func) (cdr x))
				     x))))
		     args))
978
  (apply 'calcFunc-mapeqp func args))
Eli Zaretskii's avatar
Eli Zaretskii committed
979 980 981 982 983 984 985 986 987 988 989 990

(defun calcFunc-mapeqp (func &rest args)
  (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq))
	       (memq (car-safe (nth 1 args)) '(calcFunc-gt calcFunc-geq)))
	  (and (memq (car-safe (car args)) '(calcFunc-gt calcFunc-geq))
	       (memq (car-safe (nth 1 args)) '(calcFunc-lt calcFunc-leq))))
      (setq args (cons (car args)
		       (cons (list (nth 1 (assq (car (nth 1 args))
						calc-tweak-eqn-table))
				   (nth 2 (nth 1 args))
				   (nth 1 (nth 1 args)))
			     (cdr (cdr args))))))
991
  (math-symb-map func 'eqn args))
Eli Zaretskii's avatar
Eli Zaretskii committed
992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009



;;; Reduce a function over a vector symbolically. [Public]
(defun calcFunc-reduce (func vec)
  (if (math-matrixp vec)
      (let (expr row)
	(setq func (math-var-to-calcFunc func))
	(while (setq vec (cdr vec))
	  (setq row (car vec))
	  (while (setq row (cdr row))
	    (setq expr (if expr
			   (if (Math-numberp expr)
			       (math-normalize
				(math-build-call func (list expr (car row))))
			     (math-build-call func (list expr (car row))))
			 (car row)))))
	(math-normalize expr))
1010
    (calcFunc-reducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025

(defun calcFunc-rreduce (func vec)
  (if (math-matrixp vec)
      (let (expr row)
	(setq func (math-var-to-calcFunc func)
	      vec (reverse (cdr vec)))
	(while vec
	  (setq row (reverse (cdr (car vec))))
	  (while row
	    (setq expr (if expr
			   (math-build-call func (list (car row) expr))
			 (car row))
		  row (cdr row)))
	  (setq vec (cdr vec)))
	(math-normalize expr))
1026
    (calcFunc-rreducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045

(defun calcFunc-reducer (func vec)
  (setq func (math-var-to-calcFunc func))
  (or (math-vectorp vec)
      (math-reject-arg vec 'vectorp))
  (let ((expr (car (setq vec (cdr vec)))))
    (if expr
	(progn
	  (condition-case err
	      (and (symbolp func)
		   (let ((lfunc (or (cdr (assq func
					       '( (calcFunc-add . math-add)
						  (calcFunc-sub . math-sub)
						  (calcFunc-mul . math-mul)
						  (calcFunc-div . math-div)
						  (calcFunc-pow . math-pow)
						  (calcFunc-mod . math-mod)
						  (calcFunc-vconcat .
						   math-concat) )))
1046
				    func)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1047 1048 1049 1050 1051 1052 1053 1054
		     (while (cdr vec)
		       (setq expr (funcall lfunc expr (nth 1 vec))
			     vec (cdr vec)))))
	    (error nil))
	  (while (setq vec (cdr vec))
	    (setq expr (math-build-call func (list expr (car vec)))))
	  (math-normalize expr))
      (or (math-identity-value func)
1055
	  (math-reject-arg vec "*Vector is empty")))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1056 1057 1058 1059 1060 1061 1062 1063

(defun math-identity-value (func)
  (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0)
		     (calcFunc-mul . 1) (calcFunc-div . 1)
		     (calcFunc-idiv . 1) (calcFunc-fdiv . 1)
		     (calcFunc-min . (var inf var-inf))
		     (calcFunc-max . (neg (var inf var-inf)))
		     (calcFunc-vconcat . (vec))
1064
		     (calcFunc-append . (vec)) ))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086

(defun calcFunc-rreducer (func vec)
  (setq func (math-var-to-calcFunc func))
  (or (math-vectorp vec)
      (math-reject-arg vec 'vectorp))
  (if (eq func 'calcFunc-sub)   ; do this in a way that looks nicer
      (let ((expr (car (setq vec (cdr vec)))))
	(if expr
	    (progn
	      (while (setq vec (cdr vec))
		(setq expr (math-build-call func (list expr (car vec)))
		      func (if (eq func 'calcFunc-sub)
			       'calcFunc-add 'calcFunc-sub)))
	      (math-normalize expr))
	  0))
    (let ((expr (car (setq vec (reverse (cdr vec))))))
      (if expr
	  (progn
	    (while (setq vec (cdr vec))
	      (setq expr (math-build-call func (list (car vec) expr))))
	    (math-normalize expr))
	(or (math-identity-value func)
1087
	    (math-reject-arg vec "*Vector is empty"))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1088 1089 1090 1091

(defun calcFunc-reducec (func vec)
  (if (math-matrixp vec)
      (calcFunc-reducer func (math-transpose vec))
1092
    (calcFunc-reducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1093 1094 1095 1096

(defun calcFunc-rreducec (func vec)
  (if (math-matrixp vec)
      (calcFunc-rreducer func (math-transpose vec))
1097
    (calcFunc-rreducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1098 1099 1100 1101 1102 1103

(defun calcFunc-reducea (func vec)
  (if (math-matrixp vec)
      (cons 'vec
	    (mapcar (function (lambda (x) (calcFunc-reducer func x)))
		    (cdr vec)))
1104
    (calcFunc-reducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1105 1106 1107 1108 1109 1110

(defun calcFunc-rreducea (func vec)
  (if (math-matrixp vec)
      (cons 'vec
	    (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
		    (cdr vec)))
1111
    (calcFunc-rreducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1112 1113 1114 1115 1116 1117

(defun calcFunc-reduced (func vec)
  (if (math-matrixp vec)
      (cons 'vec
	    (mapcar (function (lambda (x) (calcFunc-reducer func x)))
		    (cdr (math-transpose vec))))
1118
    (calcFunc-reducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1119 1120 1121 1122 1123 1124

(defun calcFunc-rreduced (func vec)
  (if (math-matrixp vec)
      (cons 'vec
	    (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
		    (cdr (math-transpose vec))))
1125
    (calcFunc-rreducer func vec)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137

(defun calcFunc-accum (func vec)
  (setq func (math-var-to-calcFunc func))
  (or (math-vectorp vec)
      (math-reject-arg vec 'vectorp))
  (let* ((expr (car (setq vec (cdr vec))))
	 (res (list 'vec expr)))
    (or expr
	(math-reject-arg vec "*Vector is empty"))
    (while (setq vec (cdr vec))
      (setq expr (math-build-call func (list expr (car vec)))
	    res (nconc res (list expr))))
1138
    (math-normalize res)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150

(defun calcFunc-raccum (func vec)
  (setq func (math-var-to-calcFunc func))
  (or (math-vectorp vec)
      (math-reject-arg vec 'vectorp))
  (let* ((expr (car (setq vec (reverse (cdr vec)))))
	 (res (list expr)))
    (or expr
	(math-reject-arg vec "*Vector is empty"))
    (while (setq vec (cdr vec))
      (setq expr (math-build-call func (list (car vec) expr))
	    res (cons (list expr) res)))
1151
    (math-normalize (cons 'vec res))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203


(defun math-nest-calls (func base iters accum tol)
  (or (symbolp tol)
      (if (math-realp tol)
	  (or (math-numberp base) (math-reject-arg base 'numberp))
	(math-reject-arg tol 'realp)))
  (setq func (math-var-to-calcFunc func))
  (or (null iters)
      (if (equal iters '(var inf var-inf))
	  (setq iters nil)
	(progn
	  (if (math-messy-integerp iters)
	      (setq iters (math-trunc iters)))
	  (or (integerp iters) (math-reject-arg iters 'fixnump))
	  (or (not tol) (natnump iters) (math-reject-arg iters 'fixnatnump))
	  (if (< iters 0)
	      (let* ((dummy '(var DummyArg var-DummyArg))
		     (dummy2 '(var DummyArg2 var-DummyArg2))
		     (finv (math-solve-for (math-build-call func (list dummy2))
					   dummy dummy2 nil)))
		(or finv (math-reject-arg nil "*Unable to find an inverse"))
		(if (and (= (length finv) 2)
			 (equal (nth 1 finv) dummy))
		    (setq func (car finv))
		  (setq func (list 'calcFunc-lambda dummy finv)))
		(setq iters (- iters)))))))
  (math-with-extra-prec 1
    (let ((value base)
	  (ovalue nil)
	  (avalues (list base))
	  (math-working-step 0)
	  (math-working-step-2 iters))
      (while (and (or (null iters)
		      (>= (setq iters (1- iters)) 0))
		  (or (null tol)
		      (null ovalue)
		      (if (eq tol t)
			  (not (if (and (Math-numberp value)
					(Math-numberp ovalue))
				   (math-nearly-equal value ovalue)
				 (Math-equal value ovalue)))
			(if (math-numberp value)
			    (Math-lessp tol (math-abs (math-sub value ovalue)))
			  (math-reject-arg value 'numberp)))))
	(setq ovalue value
	      math-working-step (1+ math-working-step)
	      value (math-normalize (math-build-call func (list value))))
	(if accum
	    (setq avalues (cons value avalues))))
      (if accum
	  (cons 'vec (nreverse avalues))
1204
	value))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1205 1206

(defun calcFunc-nest (func base iters)
1207
  (math-nest-calls func base iters nil nil))
Eli Zaretskii's avatar
Eli Zaretskii committed
1208 1209

(defun calcFunc-anest (func base iters)
1210
  (math-nest-calls func base iters t nil))
Eli Zaretskii's avatar
Eli Zaretskii committed
1211 1212

(defun calcFunc-fixp (func base &optional iters tol)
1213
  (math-nest-calls func base iters nil (or tol t)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1214 1215

(defun calcFunc-afixp (func base &optional iters tol)
1216
  (math-nest-calls func base iters t (or tol t)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231


(defun calcFunc-outer (func a b)
  (or (math-vectorp a) (math-reject-arg a 'vectorp))
  (or (math-vectorp b) (math-reject-arg b 'vectorp))
  (setq func (math-var-to-calcFunc func))
  (let ((mat nil))
    (while (setq a (cdr a))
      (setq mat (cons (cons 'vec
			    (mapcar (function (lambda (x)
						(math-build-call func
								 (list (car a)
								       x))))
				    (cdr b)))
		      mat)))
1232
    (math-normalize (cons 'vec (nreverse mat)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1233 1234


1235 1236 1237 1238 1239 1240 1241
;; The variables math-inner-mul-func and math-inner-add-func are
;; local to calcFunc-inner, but are used by math-inner-mats,
;; which is called by math-inner-mats.
(defvar math-inner-mul-func)
(defvar math-inner-add-func)

(defun calcFunc-inner (math-inner-mul-func math-inner-add-func a b)
Eli Zaretskii's avatar
Eli Zaretskii committed
1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258
  (or (math-vectorp a) (math-reject-arg a 'vectorp))
  (or (math-vectorp b) (math-reject-arg b 'vectorp))
  (if (math-matrixp a)
      (if (math-matrixp b)
	  (if (= (length (nth 1 a)) (length b))
	      (math-inner-mats a b)
	    (math-dimension-error))
	(if (= (length (nth 1 a)) 2)
	    (if (= (length a) (length b))
		(math-inner-mats a (list 'vec b))
	      (math-dimension-error))
	  (if (= (length (nth 1 a)) (length b))
	      (math-mat-col (math-inner-mats a (math-col-matrix b))
			    1)
	    (math-dimension-error))))
    (if (math-matrixp b)
	(nth 1 (math-inner-mats (list 'vec a) b))
1259
      (calcFunc-reduce math-inner-add-func (calcFunc-map math-inner-mul-func a b)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1260 1261 1262 1263 1264 1265 1266 1267 1268

(defun math-inner-mats (a b)
  (let ((mat nil)
	(cols (length (nth 1 b)))
	row col ap bp accum)
    (while (setq a (cdr a))
      (setq col cols
	    row nil)
      (while (> (setq col (1- col)) 0)
1269 1270
	(setq row (cons (calcFunc-reduce math-inner-add-func
					 (calcFunc-map math-inner-mul-func
Eli Zaretskii's avatar
Eli Zaretskii committed
1271 1272 1273 1274
						       (car a)
						       (math-mat-col b col)))
			row)))
      (setq mat (cons (cons 'vec row) mat)))
1275
    (cons 'vec (nreverse mat))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1276

Jay Belanger's avatar
Jay Belanger committed
1277 1278
(provide 'calc-map)

Miles Bader's avatar
Miles Bader committed
1279
;;; arch-tag: 980eac49-00e0-4870-b72a-e726b74c7990
1280
;;; calc-map.el ends here