/[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.1 by eliz, Tue Nov 6 18:59:06 2001 UTC revision 1.2 by walters, Wed Nov 14 09:05:18 2001 UTC
# Line 1  Line 1 
1  ;; Calculator for GNU Emacs, part II [calc-map.el]  ;; Calculator for GNU Emacs, part II [calc-map.el]
2  ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.  ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
3  ;; Written by Dave Gillespie, daveg@synaptics.com.  ;; Written by Dave Gillespie, daveg@synaptics.com.
4    
5  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 48  Line 48 
48                                  (nth 2 oper))                                  (nth 2 oper))
49                          (list 'calcFunc-apply                          (list 'calcFunc-apply
50                                (math-calcFunc-to-var (nth 1 oper))                                (math-calcFunc-to-var (nth 1 oper))
51                                expr))))                                expr)))))
 )  
52    
53  (defun calc-reduce (&optional oper accum)  (defun calc-reduce (&optional oper accum)
54    (interactive)    (interactive)
# Line 91  Line 90 
90                                                    "reduce"                                                    "reduce"
91                                                    calc-mapping-dir)))                                                    calc-mapping-dir)))
92                                  (math-calcFunc-to-var (nth 1 oper))                                  (math-calcFunc-to-var (nth 1 oper))
93                                  (calc-top-n (1+ calc-dollar-used)))))))                                  (calc-top-n (1+ calc-dollar-used))))))))
 )  
94    
95  (defun calc-accumulate (&optional oper)  (defun calc-accumulate (&optional oper)
96    (interactive)    (interactive)
97    (calc-reduce oper t)    (calc-reduce oper t))
 )  
98    
99  (defun calc-map (&optional oper)  (defun calc-map (&optional oper)
100    (interactive)    (interactive)
# Line 118  Line 115 
115                                (cons (math-calcFunc-to-var (nth 1 oper))                                (cons (math-calcFunc-to-var (nth 1 oper))
116                                      (calc-top-list-n                                      (calc-top-list-n
117                                       nargs                                       nargs
118                                       (1+ calc-dollar-used)))))))                                       (1+ calc-dollar-used))))))))
 )  
119    
120  (defun calc-map-equation (&optional oper)  (defun calc-map-equation (&optional oper)
121    (interactive)    (interactive)
# Line 142  Line 138 
138                                (cons (math-calcFunc-to-var (nth 1 oper))                                (cons (math-calcFunc-to-var (nth 1 oper))
139                                      (calc-top-list-n                                      (calc-top-list-n
140                                       nargs                                       nargs
141                                       (1+ calc-dollar-used)))))))                                       (1+ calc-dollar-used))))))))
 )  
142    
143  (defun calc-map-stack ()  (defun calc-map-stack ()
144    "This is meant to be called by calc-keypad mode."    "This is meant to be called by calc-keypad mode."
145    (interactive)    (interactive)
146    (let ((calc-verify-arglist nil))    (let ((calc-verify-arglist nil))
147      (calc-unread-command ?\$)      (calc-unread-command ?\$)
148      (calc-map))      (calc-map)))
 )  
149    
150  (defun calc-outer-product (&optional oper)  (defun calc-outer-product (&optional oper)
151    (interactive)    (interactive)
# Line 169  Line 163 
163                          (cons 'calcFunc-outer                          (cons 'calcFunc-outer
164                                (cons (math-calcFunc-to-var (nth 1 oper))                                (cons (math-calcFunc-to-var (nth 1 oper))
165                                      (calc-top-list-n                                      (calc-top-list-n
166                                       2 (1+ calc-dollar-used)))))))                                       2 (1+ calc-dollar-used))))))))
 )  
167    
168  (defun calc-inner-product (&optional mul-oper add-oper)  (defun calc-inner-product (&optional mul-oper add-oper)
169    (interactive)    (interactive)
# Line 196  Line 189 
189                                       (math-calcFunc-to-var (nth 1 mul-oper))                                       (math-calcFunc-to-var (nth 1 mul-oper))
190                                       (math-calcFunc-to-var (nth 1 add-oper)))                                       (math-calcFunc-to-var (nth 1 add-oper)))
191                                 (calc-top-list-n                                 (calc-top-list-n
192                                  2 (+ 1 mul-used calc-dollar-used))))))                                  2 (+ 1 mul-used calc-dollar-used)))))))
 )  
193    
194  ;;; Return a list of the form (nargs func name)  ;;; Return a list of the form (nargs func name)
195  (defun calc-get-operator (msg &optional nargs)  (defun calc-get-operator (msg &optional nargs)
# Line 448  Line 440 
440                                   (char-to-string key))))                                   (char-to-string key))))
441                 (if (> (length name) 3)                 (if (> (length name) 3)
442                     (substring name 0 3)                     (substring name 0 3)
443                   name)))))                   name))))))
 )  
444  (setq calc-verify-arglist t)  (setq calc-verify-arglist t)
445  (setq calc-mapping-dir nil)  (setq calc-mapping-dir nil)
446    
# Line 763  Line 754 
754          (intern (concat "calcFunc-" (symbol-name (nth 1 f)))))          (intern (concat "calcFunc-" (symbol-name (nth 1 f)))))
755      (if (memq (car-safe f) '(lambda calcFunc-lambda))      (if (memq (car-safe f) '(lambda calcFunc-lambda))
756          f          f
757        (math-reject-arg f "*Expected a function name")))        (math-reject-arg f "*Expected a function name"))))
 )  
758    
759  ;;; Convert a function name into a like-looking variable name formula.  ;;; Convert a function name into a like-looking variable name formula.
760  (defun math-calcFunc-to-var (f)  (defun math-calcFunc-to-var (f)
# Line 785  Line 775 
775          (list 'var          (list 'var
776                (intern base)                (intern base)
777                (intern (concat "var-" base))))                (intern (concat "var-" base))))
778      f)      f))
 )  
779    
780  ;;; Expand a function call using "lambda" notation.  ;;; Expand a function call using "lambda" notation.
781  (defun math-build-call (f args)  (defun math-build-call (f args)
# Line 807  Line 796 
796                               ( calcFunc-vconcat . | ) ))))                               ( calcFunc-vconcat . | ) ))))
797          (if (and func (= (length args) 2))          (if (and func (= (length args) 2))
798              (cons (cdr func) args)              (cons (cdr func) args)
799            (cons f args)))))            (cons f args))))))
 )  
800    
801  ;;; Do substitutions in parallel to avoid crosstalk.  ;;; Do substitutions in parallel to avoid crosstalk.
802  (defun math-multi-subst (expr olds news)  (defun math-multi-subst (expr olds news)
# Line 818  Line 806 
806        (setq args (cons (cons (car olds) (car news)) args)        (setq args (cons (cons (car olds) (car news)) args)
807              olds (cdr olds)              olds (cdr olds)
808              news (cdr news)))              news (cdr news)))
809      (math-multi-subst-rec expr))      (math-multi-subst-rec expr)))
 )  
810    
811  (defun math-multi-subst-rec (expr)  (defun math-multi-subst-rec (expr)
812    (cond ((setq temp (assoc expr args)) (cdr temp))    (cond ((setq temp (assoc expr args)) (cdr temp))
# Line 834  Line 821 
821             (nreverse (cons (math-multi-subst-rec (car expr)) new))))             (nreverse (cons (math-multi-subst-rec (car expr)) new))))
822          (t          (t
823           (cons (car expr)           (cons (car expr)
824                 (mapcar 'math-multi-subst-rec (cdr expr)))))                 (mapcar 'math-multi-subst-rec (cdr expr))))))
 )  
825    
826  (defun calcFunc-call (f &rest args)  (defun calcFunc-call (f &rest args)
827    (setq args (math-build-call (math-var-to-calcFunc f) args))    (setq args (math-build-call (math-var-to-calcFunc f) args))
828    (if (eq (car-safe args) 'calcFunc-call)    (if (eq (car-safe args) 'calcFunc-call)
829        args        args
830      (math-normalize args))      (math-normalize args)))
 )  
831    
832  (defun calcFunc-apply (f args)  (defun calcFunc-apply (f args)
833    (or (Math-vectorp args)    (or (Math-vectorp args)
834        (math-reject-arg args 'vectorp))        (math-reject-arg args 'vectorp))
835    (apply 'calcFunc-call (cons f (cdr args)))    (apply 'calcFunc-call (cons f (cdr args))))
 )  
836    
837    
838    
# Line 928  Line 912 
912      (setq vec (cons head (nreverse vec)))      (setq vec (cons head (nreverse vec)))
913      (if (and (eq mode 'cols) (math-matrixp vec))      (if (and (eq mode 'cols) (math-matrixp vec))
914          (math-transpose vec)          (math-transpose vec)
915        vec))        vec)))
 )  
916    
917  (defun calcFunc-map (func &rest args)  (defun calcFunc-map (func &rest args)
918    (math-symb-map func 'elems args)    (math-symb-map func 'elems args))
 )  
919    
920  (defun calcFunc-mapr (func &rest args)  (defun calcFunc-mapr (func &rest args)
921    (math-symb-map func 'rows args)    (math-symb-map func 'rows args))
 )  
922    
923  (defun calcFunc-mapc (func &rest args)  (defun calcFunc-mapc (func &rest args)
924    (math-symb-map func 'cols args)    (math-symb-map func 'cols args))
 )  
925    
926  (defun calcFunc-mapa (func arg)  (defun calcFunc-mapa (func arg)
927    (if (math-matrixp arg)    (if (math-matrixp arg)
928        (math-symb-map func 'elems (cdr (math-transpose arg)))        (math-symb-map func 'elems (cdr (math-transpose arg)))
929      (math-symb-map func 'elems arg))      (math-symb-map func 'elems arg)))
 )  
930    
931  (defun calcFunc-mapd (func arg)  (defun calcFunc-mapd (func arg)
932    (if (math-matrixp arg)    (if (math-matrixp arg)
933        (math-symb-map func 'elems (cdr arg))        (math-symb-map func 'elems (cdr arg))
934      (math-symb-map func 'elems arg))      (math-symb-map func 'elems arg)))
 )  
935    
936  (defun calcFunc-mapeq (func &rest args)  (defun calcFunc-mapeq (func &rest args)
937    (if (and (or (equal func '(var mul var-mul))    (if (and (or (equal func '(var mul var-mul))
# Line 974  Line 952 
952            (equal func '(var neg var-neg))            (equal func '(var neg var-neg))
953            (equal func '(var inv var-inv)))            (equal func '(var inv var-inv)))
954        (apply 'calcFunc-mapeqr func args)        (apply 'calcFunc-mapeqr func args)
955      (apply 'calcFunc-mapeqp func args))      (apply 'calcFunc-mapeqp func args)))
 )  
956    
957  (defun calcFunc-mapeqr (func &rest args)  (defun calcFunc-mapeqr (func &rest args)
958    (setq args (mapcar (function (lambda (x)    (setq args (mapcar (function (lambda (x)
# Line 985  Line 962 
962                                         (cons (nth 1 func) (cdr x))                                         (cons (nth 1 func) (cdr x))
963                                       x))))                                       x))))
964                       args))                       args))
965    (apply 'calcFunc-mapeqp func args)    (apply 'calcFunc-mapeqp func args))
 )  
966    
967  (defun calcFunc-mapeqp (func &rest args)  (defun calcFunc-mapeqp (func &rest args)
968    (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq))    (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq))
# Line 999  Line 975 
975                                     (nth 2 (nth 1 args))                                     (nth 2 (nth 1 args))
976                                     (nth 1 (nth 1 args)))                                     (nth 1 (nth 1 args)))
977                               (cdr (cdr args))))))                               (cdr (cdr args))))))
978    (math-symb-map func 'eqn args)    (math-symb-map func 'eqn args))
 )  
979    
980    
981    
# Line 1019  Line 994 
994                               (math-build-call func (list expr (car row))))                               (math-build-call func (list expr (car row))))
995                           (car row)))))                           (car row)))))
996          (math-normalize expr))          (math-normalize expr))
997      (calcFunc-reducer func vec))      (calcFunc-reducer func vec)))
 )  
998    
999  (defun calcFunc-rreduce (func vec)  (defun calcFunc-rreduce (func vec)
1000    (if (math-matrixp vec)    (if (math-matrixp vec)
# Line 1036  Line 1010 
1010                    row (cdr row)))                    row (cdr row)))
1011            (setq vec (cdr vec)))            (setq vec (cdr vec)))
1012          (math-normalize expr))          (math-normalize expr))
1013      (calcFunc-rreducer func vec))      (calcFunc-rreducer func vec)))
 )  
1014    
1015  (defun calcFunc-reducer (func vec)  (defun calcFunc-reducer (func vec)
1016    (setq func (math-var-to-calcFunc func))    (setq func (math-var-to-calcFunc func))
# Line 1066  Line 1039 
1039              (setq expr (math-build-call func (list expr (car vec)))))              (setq expr (math-build-call func (list expr (car vec)))))
1040            (math-normalize expr))            (math-normalize expr))
1041        (or (math-identity-value func)        (or (math-identity-value func)
1042            (math-reject-arg vec "*Vector is empty"))))            (math-reject-arg vec "*Vector is empty")))))
 )  
1043    
1044  (defun math-identity-value (func)  (defun math-identity-value (func)
1045    (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0)    (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0)
# Line 1076  Line 1048 
1048                       (calcFunc-min . (var inf var-inf))                       (calcFunc-min . (var inf var-inf))
1049                       (calcFunc-max . (neg (var inf var-inf)))                       (calcFunc-max . (neg (var inf var-inf)))
1050                       (calcFunc-vconcat . (vec))                       (calcFunc-vconcat . (vec))
1051                       (calcFunc-append . (vec)) )))                       (calcFunc-append . (vec)) ))))
 )  
1052    
1053  (defun calcFunc-rreducer (func vec)  (defun calcFunc-rreducer (func vec)
1054    (setq func (math-var-to-calcFunc func))    (setq func (math-var-to-calcFunc func))
# Line 1100  Line 1071 
1071                (setq expr (math-build-call func (list (car vec) expr))))                (setq expr (math-build-call func (list (car vec) expr))))
1072              (math-normalize expr))              (math-normalize expr))
1073          (or (math-identity-value func)          (or (math-identity-value func)
1074              (math-reject-arg vec "*Vector is empty")))))              (math-reject-arg vec "*Vector is empty"))))))
 )  
1075    
1076  (defun calcFunc-reducec (func vec)  (defun calcFunc-reducec (func vec)
1077    (if (math-matrixp vec)    (if (math-matrixp vec)
1078        (calcFunc-reducer func (math-transpose vec))        (calcFunc-reducer func (math-transpose vec))
1079      (calcFunc-reducer func vec))      (calcFunc-reducer func vec)))
 )  
1080    
1081  (defun calcFunc-rreducec (func vec)  (defun calcFunc-rreducec (func vec)
1082    (if (math-matrixp vec)    (if (math-matrixp vec)
1083        (calcFunc-rreducer func (math-transpose vec))        (calcFunc-rreducer func (math-transpose vec))
1084      (calcFunc-rreducer func vec))      (calcFunc-rreducer func vec)))
 )  
1085    
1086  (defun calcFunc-reducea (func vec)  (defun calcFunc-reducea (func vec)
1087    (if (math-matrixp vec)    (if (math-matrixp vec)
1088        (cons 'vec        (cons 'vec
1089              (mapcar (function (lambda (x) (calcFunc-reducer func x)))              (mapcar (function (lambda (x) (calcFunc-reducer func x)))
1090                      (cdr vec)))                      (cdr vec)))
1091      (calcFunc-reducer func vec))      (calcFunc-reducer func vec)))
 )  
1092    
1093  (defun calcFunc-rreducea (func vec)  (defun calcFunc-rreducea (func vec)
1094    (if (math-matrixp vec)    (if (math-matrixp vec)
1095        (cons 'vec        (cons 'vec
1096              (mapcar (function (lambda (x) (calcFunc-rreducer func x)))              (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
1097                      (cdr vec)))                      (cdr vec)))
1098      (calcFunc-rreducer func vec))      (calcFunc-rreducer func vec)))
 )  
1099    
1100  (defun calcFunc-reduced (func vec)  (defun calcFunc-reduced (func vec)
1101    (if (math-matrixp vec)    (if (math-matrixp vec)
1102        (cons 'vec        (cons 'vec
1103              (mapcar (function (lambda (x) (calcFunc-reducer func x)))              (mapcar (function (lambda (x) (calcFunc-reducer func x)))
1104                      (cdr (math-transpose vec))))                      (cdr (math-transpose vec))))
1105      (calcFunc-reducer func vec))      (calcFunc-reducer func vec)))
 )  
1106    
1107  (defun calcFunc-rreduced (func vec)  (defun calcFunc-rreduced (func vec)
1108    (if (math-matrixp vec)    (if (math-matrixp vec)
1109        (cons 'vec        (cons 'vec
1110              (mapcar (function (lambda (x) (calcFunc-rreducer func x)))              (mapcar (function (lambda (x) (calcFunc-rreducer func x)))
1111                      (cdr (math-transpose vec))))                      (cdr (math-transpose vec))))
1112      (calcFunc-rreducer func vec))      (calcFunc-rreducer func vec)))
 )  
1113    
1114  (defun calcFunc-accum (func vec)  (defun calcFunc-accum (func vec)
1115    (setq func (math-var-to-calcFunc func))    (setq func (math-var-to-calcFunc func))
# Line 1158  Line 1122 
1122      (while (setq vec (cdr vec))      (while (setq vec (cdr vec))
1123        (setq expr (math-build-call func (list expr (car vec)))        (setq expr (math-build-call func (list expr (car vec)))
1124              res (nconc res (list expr))))              res (nconc res (list expr))))
1125      (math-normalize res))      (math-normalize res)))
 )  
1126    
1127  (defun calcFunc-raccum (func vec)  (defun calcFunc-raccum (func vec)
1128    (setq func (math-var-to-calcFunc func))    (setq func (math-var-to-calcFunc func))
# Line 1172  Line 1135 
1135      (while (setq vec (cdr vec))      (while (setq vec (cdr vec))
1136        (setq expr (math-build-call func (list (car vec) expr))        (setq expr (math-build-call func (list (car vec) expr))
1137              res (cons (list expr) res)))              res (cons (list expr) res)))
1138      (math-normalize (cons 'vec res)))      (math-normalize (cons 'vec res))))
 )  
1139    
1140    
1141  (defun math-nest-calls (func base iters accum tol)  (defun math-nest-calls (func base iters accum tol)
# Line 1226  Line 1188 
1188              (setq avalues (cons value avalues))))              (setq avalues (cons value avalues))))
1189        (if accum        (if accum
1190            (cons 'vec (nreverse avalues))            (cons 'vec (nreverse avalues))
1191          value)))          value))))
 )  
1192    
1193  (defun calcFunc-nest (func base iters)  (defun calcFunc-nest (func base iters)
1194    (math-nest-calls func base iters nil nil)    (math-nest-calls func base iters nil nil))
 )  
1195    
1196  (defun calcFunc-anest (func base iters)  (defun calcFunc-anest (func base iters)
1197    (math-nest-calls func base iters t nil)    (math-nest-calls func base iters t nil))
 )  
1198    
1199  (defun calcFunc-fixp (func base &optional iters tol)  (defun calcFunc-fixp (func base &optional iters tol)
1200    (math-nest-calls func base iters nil (or tol t))    (math-nest-calls func base iters nil (or tol t)))
 )  
1201    
1202  (defun calcFunc-afixp (func base &optional iters tol)  (defun calcFunc-afixp (func base &optional iters tol)
1203    (math-nest-calls func base iters t (or tol t))    (math-nest-calls func base iters t (or tol t)))
 )  
1204    
1205    
1206  (defun calcFunc-outer (func a b)  (defun calcFunc-outer (func a b)
# Line 1259  Line 1216 
1216                                                                         x))))                                                                         x))))
1217                                      (cdr b)))                                      (cdr b)))
1218                        mat)))                        mat)))
1219      (math-normalize (cons 'vec (nreverse mat))))      (math-normalize (cons 'vec (nreverse mat)))))
 )  
1220    
1221    
1222  (defun calcFunc-inner (mul-func add-func a b)  (defun calcFunc-inner (mul-func add-func a b)
# Line 1281  Line 1237 
1237              (math-dimension-error))))              (math-dimension-error))))
1238      (if (math-matrixp b)      (if (math-matrixp b)
1239          (nth 1 (math-inner-mats (list 'vec a) b))          (nth 1 (math-inner-mats (list 'vec a) b))
1240        (calcFunc-reduce add-func (calcFunc-map mul-func a b))))        (calcFunc-reduce add-func (calcFunc-map mul-func a b)))))
 )  
1241    
1242  (defun math-inner-mats (a b)  (defun math-inner-mats (a b)
1243    (let ((mat nil)    (let ((mat nil)
# Line 1298  Line 1253 
1253                                                         (math-mat-col b col)))                                                         (math-mat-col b col)))
1254                          row)))                          row)))
1255        (setq mat (cons (cons 'vec row) mat)))        (setq mat (cons (cons 'vec row) mat)))
1256      (cons 'vec (nreverse mat)))      (cons 'vec (nreverse mat))))
 )  
   
1257    
1258    ;;; calc-map.el ends here
1259    

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

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