calc-map.el

Revision 4220, 39.7 kB (checked in by miyoshi, 9 months ago)
Sync up with Emacs22.2.

Line
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, 2008 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 3, 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))