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

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

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

revision 1.2 by walters, Wed Nov 14 09:05:18 2001 UTC revision 1.3 by walters, Mon Nov 19 07:36:14 2001 UTC
# Line 1  Line 1 
1  ;; Calculator for GNU Emacs, part II [calc-map.el]  ;;; calc-map.el --- higher-order functions for Calc
2    
3  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
4  ;; Written by Dave Gillespie, daveg@synaptics.com.  
5    ;; Author: David Gillespie <daveg@synaptics.com>
6    ;; Maintainer: Colin Walters <walters@debian.org>
7    
8  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
9    
# Line 19  Line 22 
22  ;; file named COPYING.  Among other things, the copyright notice  ;; file named COPYING.  Among other things, the copyright notice
23  ;; and this notice must be preserved on all copies.  ;; and this notice must be preserved on all copies.
24    
25    ;;; Commentary:
26    
27    ;;; Code:
28    
29  ;; This file is autoloaded from calc-ext.el.  ;; This file is autoloaded from calc-ext.el.
30  (require 'calc-ext)  (require 'calc-ext)
# Line 140  Line 145 
145                                       nargs                                       nargs
146                                       (1+ calc-dollar-used))))))))                                       (1+ calc-dollar-used))))))))
147    
148    (defvar calc-verify-arglist t)
149    (defvar calc-mapping-dir nil)
150  (defun calc-map-stack ()  (defun calc-map-stack ()
151    "This is meant to be called by calc-keypad mode."    "This is meant to be called by calc-keypad mode."
152    (interactive)    (interactive)
# Line 191  Line 198 
198                                 (calc-top-list-n                                 (calc-top-list-n
199                                  2 (+ 1 mul-used calc-dollar-used)))))))                                  2 (+ 1 mul-used calc-dollar-used)))))))
200    
 ;;; Return a list of the form (nargs func name)  
 (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)  
                                    (func (calc-do-alg-entry "" "Function: ")))  
                               (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  
                                       (format "%s%s, inner (add)" msg dir  
                                               (substring  
                                                (symbol-name (nth 2 oper))  
                                                9)))  
                                    '(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))))))  
 (setq calc-verify-arglist t)  
 (setq calc-mapping-dir nil)  
   
201  (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )  (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )
202                                ( ?- 2 calcFunc-sub )                                ( ?- 2 calcFunc-sub )
203                                ( ?* 2 calcFunc-mul )                                ( ?* 2 calcFunc-mul )
# Line 497  Line 251 
251                                ( ?T 1 calcFunc-arctanh )                                ( ?T 1 calcFunc-arctanh )
252                                ( ?L 1 calcFunc-exp10 )                                ( ?L 1 calcFunc-exp10 )
253                                ( ?E 1 calcFunc-log10 )                                ( ?E 1 calcFunc-log10 )
254                                ( ?| 2 calcFunc-appendrev ) )                                ( ?| 2 calcFunc-appendrev ) )))
255  ))  
256  (defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart )  (defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart )
257                                  ( ?b 3 calcFunc-subst )                                  ( ?b 3 calcFunc-subst )
258                                  ( ?c 2 calcFunc-collect )                                  ( ?c 2 calcFunc-collect )
# Line 550  Line 304 
304                                  ( ?S 2 calcFunc-fsolve )                                  ( ?S 2 calcFunc-fsolve )
305                                  ( ?X 3 calcFunc-wmaximize )                                  ( ?X 3 calcFunc-wmaximize )
306                                  ( ?/ 2 calcFunc-pdivide ) )                                  ( ?/ 2 calcFunc-pdivide ) )
307                                ( ( ?S 2 calcFunc-ffinv ) )                                ( ( ?S 2 calcFunc-ffinv ) )))
308  ))  
309  (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )  (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )
310                                  ( ?o 2 calcFunc-or )                                  ( ?o 2 calcFunc-or )
311                                  ( ?x 2 calcFunc-xor )                                  ( ?x 2 calcFunc-xor )
# Line 587  Line 341 
341                                  ( ?M 3 calcFunc-pmtl )                                  ( ?M 3 calcFunc-pmtl )
342                                  ( ?P 3 calcFunc-pvl )                                  ( ?P 3 calcFunc-pvl )
343                                  ( ?T 3 calcFunc-ratel )                                  ( ?T 3 calcFunc-ratel )
344                                  ( ?\# 3 calcFunc-nperl ) )                                  ( ?\# 3 calcFunc-nperl ) )))
345  ))  
346  (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )  (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )
347                                  ( ?r 1 calcFunc-rad )                                  ( ?r 1 calcFunc-rad )
348                                  ( ?h 1 calcFunc-hms )                                  ( ?h 1 calcFunc-hms )
349                                  ( ?f 1 calcFunc-float )                                  ( ?f 1 calcFunc-float )
350                                  ( ?F 1 calcFunc-frac ) )                                  ( ?F 1 calcFunc-frac ) )))
351  ))  
352  (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )  (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )
353                                  ( ?e 1 calcFunc-erf )                                  ( ?e 1 calcFunc-erf )
354                                  ( ?g 1 calcFunc-gamma )                                  ( ?g 1 calcFunc-gamma )
# Line 625  Line 379 
379                                  ( ?L 1 calcFunc-expm1 ) )                                  ( ?L 1 calcFunc-expm1 ) )
380                                ( ( ?B 3 calcFunc-betaB )                                ( ( ?B 3 calcFunc-betaB )
381                                  ( ?G 2 calcFunc-gammag) )                                  ( ?G 2 calcFunc-gammag) )
382                                ( ( ?G 2 calcFunc-gammaG ) )                                ( ( ?G 2 calcFunc-gammaG ) )))
383  ))  
384  (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )  (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )
385                                  ( ?c 2 calcFunc-choose )                                  ( ?c 2 calcFunc-choose )
386                                  ( ?d 1 calcFunc-dfact )                                  ( ?d 1 calcFunc-dfact )
# Line 656  Line 410 
410                                ( ( ?b 2 calcFunc-bern )                                ( ( ?b 2 calcFunc-bern )
411                                  ( ?c 2 calcFunc-perm )                                  ( ?c 2 calcFunc-perm )
412                                  ( ?e 2 calcFunc-euler )                                  ( ?e 2 calcFunc-euler )
413                                  ( ?s 2 calcFunc-stir2 ) )                                  ( ?s 2 calcFunc-stir2 ) )))
414  ))  
415  (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )  (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )
416                                  ( ?= 1 calcFunc-evalto ) )                                  ( ?= 1 calcFunc-evalto ) )))
417  ))  
418  (defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv )  (defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv )
419                                  ( ?D 1 calcFunc-date )                                  ( ?D 1 calcFunc-date )
420                                  ( ?I 2 calcFunc-incmonth )                                  ( ?I 2 calcFunc-incmonth )
# Line 668  Line 422 
422                                  ( ?M 1 calcFunc-newmonth )                                  ( ?M 1 calcFunc-newmonth )
423                                  ( ?W 1 calcFunc-newweek )                                  ( ?W 1 calcFunc-newweek )
424                                  ( ?U 1 calcFunc-unixtime )                                  ( ?U 1 calcFunc-unixtime )
425                                  ( ?Y 1 calcFunc-newyear ) )                                  ( ?Y 1 calcFunc-newyear ) )))
426  ))  
427  (defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov )  (defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov )
428                                  ( ?G 1 calcFunc-vgmean )                                  ( ?G 1 calcFunc-vgmean )
429                                  ( ?M 1 calcFunc-vmean )                                  ( ?M 1 calcFunc-vmean )
# Line 684  Line 438 
438                                  ( ?M 1 calcFunc-vmedian )                                  ( ?M 1 calcFunc-vmedian )
439                                  ( ?S 1 calcFunc-vvar ) )                                  ( ?S 1 calcFunc-vvar ) )
440                                ( ( ?M 1 calcFunc-vhmean )                                ( ( ?M 1 calcFunc-vhmean )
441                                  ( ?S 1 calcFunc-vpvar ) )                                  ( ?S 1 calcFunc-vpvar ) )))
442  ))  
443  (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )  (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )
444                                  ( ?b 2 calcFunc-cvec )                                  ( ?b 2 calcFunc-cvec )
445                                  ( ?c 2 calcFunc-mcol )                                  ( ?c 2 calcFunc-mcol )
# Line 742  Line 496 
496                                  ( ?U 2 calcFunc-anest ) )                                  ( ?U 2 calcFunc-anest ) )
497                                ( ( ?h 1 calcFunc-rtail )                                ( ( ?h 1 calcFunc-rtail )
498                                  ( ?R 1 calcFunc-fixp )                                  ( ?R 1 calcFunc-fixp )
499                                  ( ?U 1 calcFunc-afixp ) )                                  ( ?U 1 calcFunc-afixp ) )))
500  ))  
501    
502    ;;; Return a list of the form (nargs func name)
503    (defun calc-get-operator (msg &optional nargs)
504      (setq calc-aborted-prefix nil)
505      (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil)
506            done key oper (which 0)
507            (msgs '( "(Press ? for help)"
508                     "+, -, *, /, ^, %, \\, :, &, !, |, Neg"
509                     "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
510                     "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
511                     "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc."
512                     "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
513                     "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
514                     "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc."
515                     "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc."
516                     "Time/date + newYear, Incmonth, etc."
517                     "Vectors + Length, Row, Col, Diag, Mask, etc."
518                     "_ = mapr/reducea, : = mapc/reduced, = = reducer"
519                     "X or Z = any function by name; ' = alg entry; $ = stack")))
520        (while (not done)
521          (message "%s%s: %s: %s%s%s"
522                   msg
523                   (cond ((equal calc-mapping-dir "r") " rows")
524                         ((equal calc-mapping-dir "c") " columns")
525                         ((equal calc-mapping-dir "a") " across")
526                         ((equal calc-mapping-dir "d") " down")
527                         (t ""))
528                   (if forcenargs
529                       (format "(%d arg%s)"
530                               forcenargs (if (= forcenargs 1) "" "s"))
531                     (nth which msgs))
532                   (if inv "Inv " "") (if hyp "Hyp " "")
533                   (if prefix (concat (char-to-string prefix) "-") ""))
534          (setq key (read-char))
535          (if (>= key 128) (setq key (- key 128)))
536          (cond ((memq key '(?\C-g ?q))
537                 (keyboard-quit))
538                ((memq key '(?\C-u ?\e)))
539                ((= key ??)
540                 (setq which (% (1+ which) (length msgs))))
541                ((and (= key ?I) (null prefix))
542                 (setq inv (not inv)))
543                ((and (= key ?H) (null prefix))
544                 (setq hyp (not hyp)))
545                ((and (eq key prefix) (not (eq key ?v)))
546                 (setq prefix nil))
547                ((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V))
548                      (null prefix))
549                 (setq prefix (downcase key)))
550                ((and (eq key ?\=) (null prefix))
551                 (if calc-mapping-dir
552                     (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
553                                                "" "r"))
554                   (beep)))
555                ((and (eq key ?\_) (null prefix))
556                 (if calc-mapping-dir
557                     (if (string-match "map$" msg)
558                         (setq calc-mapping-dir (if (equal calc-mapping-dir "r")
559                                                    "" "r"))
560                       (setq calc-mapping-dir (if (equal calc-mapping-dir "a")
561                                                  "" "a")))
562                   (beep)))
563                ((and (eq key ?\:) (null prefix))
564                 (if calc-mapping-dir
565                     (if (string-match "map$" msg)
566                         (setq calc-mapping-dir (if (equal calc-mapping-dir "c")
567                                                    "" "c"))
568                       (setq calc-mapping-dir (if (equal calc-mapping-dir "d")
569                                                  "" "d")))
570                   (beep)))
571                ((and (>= key ?0) (<= key ?9) (null prefix))
572                 (setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0)))
573                 (and nargs forcenargs (/= nargs forcenargs) (>= nargs 0)
574                      (error "Must be a %d-argument operator" nargs)))
575                ((memq key '(?\$ ?\'))
576                 (let* ((arglist nil)
577                        (has-args nil)
578                        (record-entry nil)
579                        (expr (if (eq key ?\$)
580                                  (progn
581                                    (setq calc-dollar-used 1)
582                                    (if calc-dollar-values
583                                        (car calc-dollar-values)
584                                      (error "Stack underflow")))
585                                (let* ((calc-dollar-values calc-arg-values)
586                                       (calc-dollar-used 0)
587                                       (calc-hashes-used 0)
588                                       (func (calc-do-alg-entry "" "Function: ")))
589                                  (setq record-entry t)
590                                  (or (= (length func) 1)
591                                      (error "Bad format"))
592                                  (if (> calc-dollar-used 0)
593                                      (progn
594                                        (setq has-args calc-dollar-used
595                                              arglist (calc-invent-args has-args))
596                                        (math-multi-subst (car func)
597                                                          (reverse arglist)
598                                                          arglist))
599                                    (if (> calc-hashes-used 0)
600                                        (setq has-args calc-hashes-used
601                                              arglist (calc-invent-args has-args)))
602                                    (car func))))))
603                   (if (eq (car-safe expr) 'calcFunc-lambda)
604                       (setq oper (list "$" (- (length expr) 2) expr)
605                             done t)
606                     (or has-args
607                         (progn
608                           (calc-default-formula-arglist expr)
609                           (setq record-entry t
610                                 arglist (sort arglist 'string-lessp))
611                           (if calc-verify-arglist
612                               (setq arglist (read-from-minibuffer
613                                              "Function argument list: "
614                                              (if arglist
615                                                  (prin1-to-string arglist)
616                                                "()")
617                                              minibuffer-local-map
618                                              t)))
619                           (setq arglist (mapcar (function
620                                                  (lambda (x)
621                                                    (list 'var
622                                                          x
623                                                          (intern
624                                                           (concat
625                                                            "var-"
626                                                            (symbol-name x))))))
627                                                 arglist))))
628                     (setq oper (list "$"
629                                      (length arglist)
630                                      (append '(calcFunc-lambda) arglist
631                                              (list expr)))
632                           done t))
633                   (if record-entry
634                       (calc-record (nth 2 oper) "oper"))))
635                ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0))
636                                           (if prefix
637                                               (symbol-value
638                                                (intern (format "calc-%c-oper-keys"
639                                                                prefix)))
640                                             calc-oper-keys))))
641                 (if (eq (nth 1 oper) 'user)
642                     (let ((func (intern
643                                  (completing-read "Function name: "
644                                                   obarray 'fboundp
645                                                   nil "calcFunc-"))))
646                       (if (or forcenargs nargs)
647                           (setq oper (list "z" (or forcenargs nargs) func)
648                                 done t)
649                         (if (fboundp func)
650                             (let* ((defn (symbol-function func)))
651                               (and (symbolp defn)
652                                    (setq defn (symbol-function defn)))
653                               (if (eq (car-safe defn) 'lambda)
654                                   (let ((args (nth 1 defn))
655                                         (nargs 0))
656                                     (while (not (memq (car args) '(&optional
657                                                                    &rest nil)))
658                                       (setq nargs (1+ nargs)
659                                             args (cdr args)))
660                                     (setq oper (list "z" nargs func)
661                                           done t))
662                                 (error
663                                  "Function is not suitable for this operation")))
664                           (message "Number of arguments: ")
665                           (let ((nargs (read-char)))
666                             (if (and (>= nargs ?0) (<= nargs ?9))
667                                 (setq oper (list "z" (- nargs ?0) func)
668                                       done t)
669                               (beep))))))
670                   (if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U)))
671                           (and (eq prefix ?a) (eq key ?M)))
672                       (let* ((dir (cond ((and (equal calc-mapping-dir "")
673                                               (string-match "map$" msg))
674                                          (setq calc-mapping-dir "r")
675                                          " rows")
676                                         ((equal calc-mapping-dir "r") " rows")
677                                         ((equal calc-mapping-dir "c") " columns")
678                                         ((equal calc-mapping-dir "a") " across")
679                                         ((equal calc-mapping-dir "d") " down")
680                                         (t "")))
681                              (calc-mapping-dir (and (memq (nth 2 oper)
682                                                           '(calcFunc-map
683                                                             calcFunc-reduce
684                                                             calcFunc-rreduce))
685                                                     ""))
686                              (oper2 (calc-get-operator
687                                      (format "%s%s, %s%s" msg dir
688                                              (substring (symbol-name (nth 2 oper))
689                                                         9)
690                                              (if (eq key ?I) " (mult)" ""))
691                                      (cdr (assq (nth 2 oper)
692                                                 '((calcFunc-reduce  . 2)
693                                                   (calcFunc-rreduce . 2)
694                                                   (calcFunc-accum   . 2)
695                                                   (calcFunc-raccum  . 2)
696                                                   (calcFunc-nest    . 2)
697                                                   (calcFunc-anest   . 2)
698                                                   (calcFunc-fixp    . 2)
699                                                   (calcFunc-afixp   . 2))))))
700                              (oper3 (if (eq (nth 2 oper) 'calcFunc-inner)
701                                         (calc-get-operator
702                                          (format "%s%s, inner (add)" msg dir
703                                                  (substring
704                                                   (symbol-name (nth 2 oper))
705                                                   9)))
706                                       '(0 0 0)))
707                              (args nil)
708                              (nargs (if (> (nth 1 oper) 0)
709                                         (nth 1 oper)
710                                       (car oper2)))
711                              (n nargs)
712                              (p calc-arg-values))
713                         (while (and p (> n 0))
714                           (or (math-expr-contains (nth 1 oper2) (car p))
715                               (math-expr-contains (nth 1 oper3) (car p))
716                               (setq args (nconc args (list (car p)))
717                                     n (1- n)))
718                           (setq p (cdr p)))
719                         (setq oper (list "" nargs
720                                          (append
721                                           '(calcFunc-lambda)
722                                           args
723                                           (list (math-build-call
724                                                  (intern
725                                                   (concat
726                                                    (symbol-name (nth 2 oper))
727                                                    calc-mapping-dir))
728                                                  (cons (math-calcFunc-to-var
729                                                         (nth 1 oper2))
730                                                        (if (eq key ?I)
731                                                            (cons
732                                                             (math-calcFunc-to-var
733                                                              (nth 1 oper3))
734                                                             args)
735                                                          args))))))
736                               done t))
737                     (setq done t))))
738                (t (beep))))
739        (and nargs (>= nargs 0)
740             (/= nargs (nth 1 oper))
741             (error "Must be a %d-argument operator" nargs))
742        (append (if forcenargs
743                    (cons forcenargs (cdr (cdr oper)))
744                  (cdr oper))
745                (list
746                 (let ((name (concat (if inv "I" "") (if hyp "H" "")
747                                     (if prefix (char-to-string prefix) "")
748                                     (char-to-string key))))
749                   (if (> (length name) 3)
750                       (substring name 0 3)
751                     name))))))
752    
753    
754  ;;; Convert a variable name (as a formula) into a like-looking function name.  ;;; Convert a variable name (as a formula) into a like-looking function name.

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

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