Fix up comment convention on the arch-tag lines.
[bpt/emacs.git] / lisp / calc / calcsel2.el
CommitLineData
3132f345
CW
1;;; calcsel2.el --- selection functions for Calc
2
58ba2f8f 3;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
8b72699e 4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
3132f345
CW
5
6;; Author: David Gillespie <daveg@synaptics.com>
e8fff8ed 7;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
136211a9
EZ
8
9;; This file is part of GNU Emacs.
10
7c671b23
GM
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
075969b4 13;; the Free Software Foundation; either version 3, or (at your option)
7c671b23
GM
14;; any later version.
15
136211a9 16;; GNU Emacs is distributed in the hope that it will be useful,
7c671b23
GM
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.
136211a9 25
3132f345 26;;; Commentary:
136211a9 27
3132f345 28;;; Code:
136211a9
EZ
29
30;; This file is autoloaded from calc-ext.el.
136211a9 31
25efff5f 32(require 'calc-ext)
136211a9
EZ
33(require 'calc-macs)
34
3b058174
JB
35;; The variable calc-keep-selection is declared and set in calc-sel.el.
36(defvar calc-keep-selection)
136211a9 37
1d64910f
JB
38;; The variable calc-sel-reselect is local to the methods below,
39;; but is used by some functions in calc-sel.el which are called
40;; by the functions below.
41
136211a9
EZ
42(defun calc-commute-left (arg)
43 (interactive "p")
44 (if (< arg 0)
45 (calc-commute-right (- arg))
46 (calc-wrapper
47 (calc-preserve-point)
48 (let ((num (max 1 (calc-locate-cursor-element (point))))
1d64910f 49 (calc-sel-reselect calc-keep-selection))
136211a9
EZ
50 (if (= arg 0) (setq arg nil))
51 (while (or (null arg) (>= (setq arg (1- arg)) 0))
52 (let* ((entry (calc-top num 'entry))
53 (expr (car entry))
54 (sel (calc-auto-selection entry))
55 parent new)
56 (or (and sel
57 (consp (setq parent (calc-find-assoc-parent-formula
58 expr sel))))
59 (error "No term is selected"))
60 (if (and calc-assoc-selections
61 (assq (car parent) calc-assoc-ops))
62 (let ((outer (calc-find-parent-formula parent sel)))
63 (if (eq sel (nth 2 outer))
64 (setq new (calc-replace-sub-formula
65 parent outer
66 (cond
67 ((memq (car outer)
68 (nth 1 (assq (car-safe (nth 1 outer))
69 calc-assoc-ops)))
70 (let* ((other (nth 2 (nth 1 outer)))
71 (new (calc-build-assoc-term
72 (car (nth 1 outer))
73 (calc-build-assoc-term
74 (car outer)
75 (nth 1 (nth 1 outer))
76 sel)
77 other)))
78 (setq sel (nth 2 (nth 1 new)))
79 new))
80 ((eq (car outer) '-)
81 (calc-build-assoc-term
82 '+
83 (setq sel (math-neg sel))
84 (nth 1 outer)))
85 ((eq (car outer) '/)
86 (calc-build-assoc-term
87 '*
88 (setq sel (calcFunc-div 1 sel))
89 (nth 1 outer)))
90 (t (calc-build-assoc-term
91 (car outer) sel (nth 1 outer))))))
92 (let ((next (calc-find-parent-formula parent outer)))
93 (if (not (and (consp next)
94 (eq outer (nth 2 next))
95 (eq (car next) (car outer))))
96 (setq new nil)
97 (setq new (calc-build-assoc-term
98 (car next)
99 sel
100 (calc-build-assoc-term
101 (car next) (nth 1 next) (nth 2 outer)))
102 sel (nth 1 new)
103 new (calc-replace-sub-formula
104 parent next new))))))
105 (if (eq (nth 1 parent) sel)
106 (setq new nil)
107 (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
108 (setq new (copy-sequence parent)))))
109 (setcar (cdr p) (car p))
110 (setcar p sel))))
111 (if (null new)
112 (if arg
113 (error "Term is already leftmost")
1d64910f 114 (or calc-sel-reselect
136211a9
EZ
115 (calc-pop-push-list 1 (list expr) num '(nil)))
116 (setq arg 0))
117 (calc-pop-push-record-list
118 1 "left"
119 (list (calc-replace-sub-formula expr parent new))
120 num
1d64910f 121 (list (and (or (not (eq arg 0)) calc-sel-reselect)
bf77c646 122 sel))))))))))
136211a9
EZ
123
124(defun calc-commute-right (arg)
125 (interactive "p")
126 (if (< arg 0)
127 (calc-commute-left (- arg))
128 (calc-wrapper
129 (calc-preserve-point)
130 (let ((num (max 1 (calc-locate-cursor-element (point))))
1d64910f 131 (calc-sel-reselect calc-keep-selection))
136211a9
EZ
132 (if (= arg 0) (setq arg nil))
133 (while (or (null arg) (>= (setq arg (1- arg)) 0))
134 (let* ((entry (calc-top num 'entry))
135 (expr (car entry))
136 (sel (calc-auto-selection entry))
137 parent new)
138 (or (and sel
139 (consp (setq parent (calc-find-assoc-parent-formula
140 expr sel))))
141 (error "No term is selected"))
142 (if (and calc-assoc-selections
143 (assq (car parent) calc-assoc-ops))
144 (let ((outer (calc-find-parent-formula parent sel)))
145 (if (eq sel (nth 1 outer))
146 (setq new (calc-replace-sub-formula
147 parent outer
148 (if (memq (car outer)
149 (nth 2 (assq (car-safe (nth 2 outer))
150 calc-assoc-ops)))
151 (let ((other (nth 1 (nth 2 outer))))
152 (calc-build-assoc-term
153 (car outer)
154 other
155 (calc-build-assoc-term
156 (car (nth 2 outer))
157 sel
158 (nth 2 (nth 2 outer)))))
159 (let ((new (cond
160 ((eq (car outer) '-)
161 (calc-build-assoc-term
162 '+
163 (math-neg (nth 2 outer))
164 sel))
165 ((eq (car outer) '/)
166 (calc-build-assoc-term
167 '*
168 (calcFunc-div 1 (nth 2 outer))
169 sel))
170 (t (calc-build-assoc-term
171 (car outer)
172 (nth 2 outer)
173 sel)))))
174 (setq sel (nth 2 new))
175 new))))
176 (let ((next (calc-find-parent-formula parent outer)))
177 (if (not (and (consp next)
178 (eq outer (nth 1 next))))
179 (setq new nil)
180 (setq new (calc-build-assoc-term
181 (car outer)
182 (calc-build-assoc-term
183 (car next) (nth 1 outer) (nth 2 next))
184 sel)
185 sel (nth 2 new)
186 new (calc-replace-sub-formula
187 parent next new))))))
188 (if (eq (nth (1- (length parent)) parent) sel)
189 (setq new nil)
190 (let ((p (nthcdr (calc-find-sub-formula parent sel)
191 (setq new (copy-sequence parent)))))
192 (setcar p (nth 1 p))
193 (setcar (cdr p) sel))))
194 (if (null new)
195 (if arg
196 (error "Term is already rightmost")
1d64910f 197 (or calc-sel-reselect
136211a9
EZ
198 (calc-pop-push-list 1 (list expr) num '(nil)))
199 (setq arg 0))
200 (calc-pop-push-record-list
201 1 "rght"
202 (list (calc-replace-sub-formula expr parent new))
203 num
1d64910f 204 (list (and (or (not (eq arg 0)) calc-sel-reselect)
bf77c646 205 sel))))))))))
136211a9
EZ
206
207(defun calc-build-assoc-term (op lhs rhs)
208 (cond ((and (eq op '+) (or (math-looks-negp rhs)
209 (and (eq (car-safe rhs) 'cplx)
210 (math-negp (nth 1 rhs))
211 (eq (nth 2 rhs) 0))))
212 (list '- lhs (math-neg rhs)))
213 ((and (eq op '-) (or (math-looks-negp rhs)
214 (and (eq (car-safe rhs) 'cplx)
215 (math-negp (nth 1 rhs))
216 (eq (nth 2 rhs) 0))))
217 (list '+ lhs (math-neg rhs)))
218 ((and (eq op '*) (and (eq (car-safe rhs) '/)
219 (or (math-equal-int (nth 1 rhs) 1)
220 (equal (nth 1 rhs) '(cplx 1 0)))))
221 (list '/ lhs (nth 2 rhs)))
222 ((and (eq op '/) (and (eq (car-safe rhs) '/)
223 (or (math-equal-int (nth 1 rhs) 1)
224 (equal (nth 1 rhs) '(cplx 1 0)))))
225 (list '/ lhs (nth 2 rhs)))
bf77c646 226 (t (list op lhs rhs))))
136211a9
EZ
227
228(defun calc-sel-unpack ()
229 (interactive)
230 (calc-wrapper
231 (calc-preserve-point)
232 (let* ((num (max 1 (calc-locate-cursor-element (point))))
1d64910f 233 (calc-sel-reselect calc-keep-selection)
136211a9
EZ
234 (entry (calc-top num 'entry))
235 (expr (car entry))
236 (sel (or (calc-auto-selection entry) expr)))
237 (or (and (not (math-primp sel))
238 (= (length sel) 2))
239 (error "Selection must be a function of one argument"))
240 (calc-pop-push-record-list 1 "unpk"
241 (list (calc-replace-sub-formula
242 expr sel (nth 1 sel)))
243 num
1d64910f 244 (list (and calc-sel-reselect (nth 1 sel)))))))
136211a9
EZ
245
246(defun calc-sel-isolate ()
247 (interactive)
248 (calc-slow-wrapper
249 (calc-preserve-point)
250 (let* ((num (max 1 (calc-locate-cursor-element (point))))
1d64910f 251 (calc-sel-reselect calc-keep-selection)
136211a9
EZ
252 (entry (calc-top num 'entry))
253 (expr (car entry))
254 (sel (or (calc-auto-selection entry) (error "No selection")))
255 (eqn sel)
256 soln)
257 (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
258 (error "Selection must be a member of an equation"))
259 (not (assq (car eqn) calc-tweak-eqn-table))))
260 (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
261 (or soln
262 (error "No solution found"))
263 (setq soln (calc-encase-atoms
264 (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
265 (eq (nth 1 soln) sel))
266 soln
267 (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
268 (nth 2 soln)
269 (nth 1 soln)))))
270 (calc-pop-push-record-list 1 "isol"
271 (list (calc-replace-sub-formula
272 expr eqn soln))
273 num
1d64910f 274 (list (and calc-sel-reselect sel)))
bf77c646 275 (calc-handle-whys))))
136211a9
EZ
276
277(defun calc-sel-commute (many)
278 (interactive "P")
279 (let ((calc-assoc-selections nil))
280 (calc-rewrite-selection "CommuteRules" many "cmut"))
bf77c646 281 (calc-set-mode-line))
136211a9
EZ
282
283(defun calc-sel-jump-equals (many)
284 (interactive "P")
bf77c646 285 (calc-rewrite-selection "JumpRules" many "jump"))
136211a9
EZ
286
287(defun calc-sel-distribute (many)
288 (interactive "P")
bf77c646 289 (calc-rewrite-selection "DistribRules" many "dist"))
136211a9
EZ
290
291(defun calc-sel-merge (many)
292 (interactive "P")
bf77c646 293 (calc-rewrite-selection "MergeRules" many "merg"))
136211a9
EZ
294
295(defun calc-sel-negate (many)
296 (interactive "P")
bf77c646 297 (calc-rewrite-selection "NegateRules" many "jneg"))
136211a9
EZ
298
299(defun calc-sel-invert (many)
300 (interactive "P")
bf77c646 301 (calc-rewrite-selection "InvertRules" many "jinv"))
136211a9 302
25efff5f
JB
303(provide 'calcsel2)
304
cbee283d 305;; arch-tag: 7c5b8d65-b8f0-45d9-820d-9930f8ee114b
bf77c646 306;;; calcsel2.el ends here