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. |
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) |
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) |
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) |
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) |
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) |
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) |
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 |
|
|
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) |
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) |
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) |
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)) |
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 |
|
|
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)) |
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) |
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)) |
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 |
|
|
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) |
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)) |
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) |
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)) |
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)) |
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)) |
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) |
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) |
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) |
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) |
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 |
|
|