1 ;; Calculator for GNU Emacs, part II [calc-sel-2.el]
2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
3 ;; Written by Dave Gillespie, daveg@synaptics.com.
5 ;; This file is part of GNU Emacs.
7 ;; GNU Emacs is distributed in the hope that it will be useful,
8 ;; but WITHOUT ANY WARRANTY. No author or distributor
9 ;; accepts responsibility to anyone for the consequences of using it
10 ;; or for whether it serves any particular purpose or works at all,
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public
12 ;; License for full details.
14 ;; Everyone is granted permission to copy, modify and redistribute
15 ;; GNU Emacs, but only under the conditions described in the
16 ;; GNU Emacs General Public License. A copy of this license is
17 ;; supposed to have been given to you along with GNU Emacs so you
18 ;; can know your rights and responsibilities. It should be in a
19 ;; file named COPYING. Among other things, the copyright notice
20 ;; and this notice must be preserved on all copies.
24 ;; This file is autoloaded from calc-ext.el.
29 (defun calc-Need-calc-sel-2 () nil)
32 (defun calc-commute-left (arg)
35 (calc-commute-right (- arg))
38 (let ((num (max 1 (calc-locate-cursor-element (point))))
39 (reselect calc-keep-selection))
40 (if (= arg 0) (setq arg nil))
41 (while (or (null arg) (>= (setq arg (1- arg)) 0))
42 (let* ((entry (calc-top num 'entry))
44 (sel (calc-auto-selection entry))
47 (consp (setq parent (calc-find-assoc-parent-formula
49 (error "No term is selected"))
50 (if (and calc-assoc-selections
51 (assq (car parent) calc-assoc-ops))
52 (let ((outer (calc-find-parent-formula parent sel)))
53 (if (eq sel (nth 2 outer))
54 (setq new (calc-replace-sub-formula
58 (nth 1 (assq (car-safe (nth 1 outer))
60 (let* ((other (nth 2 (nth 1 outer)))
61 (new (calc-build-assoc-term
63 (calc-build-assoc-term
68 (setq sel (nth 2 (nth 1 new)))
71 (calc-build-assoc-term
73 (setq sel (math-neg sel))
76 (calc-build-assoc-term
78 (setq sel (calcFunc-div 1 sel))
80 (t (calc-build-assoc-term
81 (car outer) sel (nth 1 outer))))))
82 (let ((next (calc-find-parent-formula parent outer)))
83 (if (not (and (consp next)
84 (eq outer (nth 2 next))
85 (eq (car next) (car outer))))
87 (setq new (calc-build-assoc-term
90 (calc-build-assoc-term
91 (car next) (nth 1 next) (nth 2 outer)))
93 new (calc-replace-sub-formula
95 (if (eq (nth 1 parent) sel)
97 (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
98 (setq new (copy-sequence parent)))))
99 (setcar (cdr p) (car p))
103 (error "Term is already leftmost")
105 (calc-pop-push-list 1 (list expr) num '(nil)))
107 (calc-pop-push-record-list
109 (list (calc-replace-sub-formula expr parent new))
111 (list (and (or (not (eq arg 0)) reselect)
115 (defun calc-commute-right (arg)
118 (calc-commute-left (- arg))
120 (calc-preserve-point)
121 (let ((num (max 1 (calc-locate-cursor-element (point))))
122 (reselect calc-keep-selection))
123 (if (= arg 0) (setq arg nil))
124 (while (or (null arg) (>= (setq arg (1- arg)) 0))
125 (let* ((entry (calc-top num 'entry))
127 (sel (calc-auto-selection entry))
130 (consp (setq parent (calc-find-assoc-parent-formula
132 (error "No term is selected"))
133 (if (and calc-assoc-selections
134 (assq (car parent) calc-assoc-ops))
135 (let ((outer (calc-find-parent-formula parent sel)))
136 (if (eq sel (nth 1 outer))
137 (setq new (calc-replace-sub-formula
139 (if (memq (car outer)
140 (nth 2 (assq (car-safe (nth 2 outer))
142 (let ((other (nth 1 (nth 2 outer))))
143 (calc-build-assoc-term
146 (calc-build-assoc-term
149 (nth 2 (nth 2 outer)))))
152 (calc-build-assoc-term
154 (math-neg (nth 2 outer))
157 (calc-build-assoc-term
159 (calcFunc-div 1 (nth 2 outer))
161 (t (calc-build-assoc-term
165 (setq sel (nth 2 new))
167 (let ((next (calc-find-parent-formula parent outer)))
168 (if (not (and (consp next)
169 (eq outer (nth 1 next))))
171 (setq new (calc-build-assoc-term
173 (calc-build-assoc-term
174 (car next) (nth 1 outer) (nth 2 next))
177 new (calc-replace-sub-formula
178 parent next new))))))
179 (if (eq (nth (1- (length parent)) parent) sel)
181 (let ((p (nthcdr (calc-find-sub-formula parent sel)
182 (setq new (copy-sequence parent)))))
184 (setcar (cdr p) sel))))
187 (error "Term is already rightmost")
189 (calc-pop-push-list 1 (list expr) num '(nil)))
191 (calc-pop-push-record-list
193 (list (calc-replace-sub-formula expr parent new))
195 (list (and (or (not (eq arg 0)) reselect)
199 (defun calc-build-assoc-term (op lhs rhs)
200 (cond ((and (eq op '+) (or (math-looks-negp rhs)
201 (and (eq (car-safe rhs) 'cplx)
202 (math-negp (nth 1 rhs))
203 (eq (nth 2 rhs) 0))))
204 (list '- lhs (math-neg rhs)))
205 ((and (eq op '-) (or (math-looks-negp rhs)
206 (and (eq (car-safe rhs) 'cplx)
207 (math-negp (nth 1 rhs))
208 (eq (nth 2 rhs) 0))))
209 (list '+ lhs (math-neg rhs)))
210 ((and (eq op '*) (and (eq (car-safe rhs) '/)
211 (or (math-equal-int (nth 1 rhs) 1)
212 (equal (nth 1 rhs) '(cplx 1 0)))))
213 (list '/ lhs (nth 2 rhs)))
214 ((and (eq op '/) (and (eq (car-safe rhs) '/)
215 (or (math-equal-int (nth 1 rhs) 1)
216 (equal (nth 1 rhs) '(cplx 1 0)))))
217 (list '/ lhs (nth 2 rhs)))
218 (t (list op lhs rhs)))
221 (defun calc-sel-unpack ()
224 (calc-preserve-point)
225 (let* ((num (max 1 (calc-locate-cursor-element (point))))
226 (reselect calc-keep-selection)
227 (entry (calc-top num 'entry))
229 (sel (or (calc-auto-selection entry) expr)))
230 (or (and (not (math-primp sel))
232 (error "Selection must be a function of one argument"))
233 (calc-pop-push-record-list 1 "unpk"
234 (list (calc-replace-sub-formula
235 expr sel (nth 1 sel)))
237 (list (and reselect (nth 1 sel))))))
240 (defun calc-sel-isolate ()
243 (calc-preserve-point)
244 (let* ((num (max 1 (calc-locate-cursor-element (point))))
245 (reselect calc-keep-selection)
246 (entry (calc-top num 'entry))
248 (sel (or (calc-auto-selection entry) (error "No selection")))
251 (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
252 (error "Selection must be a member of an equation"))
253 (not (assq (car eqn) calc-tweak-eqn-table))))
254 (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
256 (error "No solution found"))
257 (setq soln (calc-encase-atoms
258 (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
259 (eq (nth 1 soln) sel))
261 (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
264 (calc-pop-push-record-list 1 "isol"
265 (list (calc-replace-sub-formula
268 (list (and reselect sel)))
272 (defun calc-sel-commute (many)
274 (let ((calc-assoc-selections nil))
275 (calc-rewrite-selection "CommuteRules" many "cmut"))
279 (defun calc-sel-jump-equals (many)
281 (calc-rewrite-selection "JumpRules" many "jump")
284 (defun calc-sel-distribute (many)
286 (calc-rewrite-selection "DistribRules" many "dist")
289 (defun calc-sel-merge (many)
291 (calc-rewrite-selection "MergeRules" many "merg")
294 (defun calc-sel-negate (many)
296 (calc-rewrite-selection "NegateRules" many "jneg")
299 (defun calc-sel-invert (many)
301 (calc-rewrite-selection "InvertRules" many "jinv")