1 ;;; calcsel2.el --- selection functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This file is autoloaded from calc-ext.el.
32 ;; The variable calc-keep-selection is declared and set in calc-sel.el.
33 (defvar calc-keep-selection)
35 ;; The variable calc-sel-reselect is local to the methods below,
36 ;; but is used by some functions in calc-sel.el which are called
37 ;; by the functions below.
39 (defun calc-commute-left (arg)
42 (calc-commute-right (- arg))
45 (let ((num (max 1 (calc-locate-cursor-element (point))))
46 (calc-sel-reselect calc-keep-selection))
47 (if (= arg 0) (setq arg nil))
48 (while (or (null arg) (>= (setq arg (1- arg)) 0))
49 (let* ((entry (calc-top num 'entry))
51 (sel (calc-auto-selection entry))
54 (consp (setq parent (calc-find-assoc-parent-formula
56 (error "No term is selected"))
57 (if (and calc-assoc-selections
58 (assq (car parent) calc-assoc-ops))
59 (let ((outer (calc-find-parent-formula parent sel)))
60 (if (eq sel (nth 2 outer))
61 (setq new (calc-replace-sub-formula
65 (nth 1 (assq (car-safe (nth 1 outer))
67 (let* ((other (nth 2 (nth 1 outer)))
68 (new (calc-build-assoc-term
70 (calc-build-assoc-term
75 (setq sel (nth 2 (nth 1 new)))
78 (calc-build-assoc-term
80 (setq sel (math-neg sel))
83 (calc-build-assoc-term
85 (setq sel (calcFunc-div 1 sel))
87 (t (calc-build-assoc-term
88 (car outer) sel (nth 1 outer))))))
89 (let ((next (calc-find-parent-formula parent outer)))
90 (if (not (and (consp next)
91 (eq outer (nth 2 next))
92 (eq (car next) (car outer))))
94 (setq new (calc-build-assoc-term
97 (calc-build-assoc-term
98 (car next) (nth 1 next) (nth 2 outer)))
100 new (calc-replace-sub-formula
101 parent next new))))))
102 (if (eq (nth 1 parent) sel)
104 (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
105 (setq new (copy-sequence parent)))))
106 (setcar (cdr p) (car p))
110 (error "Term is already leftmost")
111 (or calc-sel-reselect
112 (calc-pop-push-list 1 (list expr) num '(nil)))
114 (calc-pop-push-record-list
116 (list (calc-replace-sub-formula expr parent new))
118 (list (and (or (not (eq arg 0)) calc-sel-reselect)
121 (defun calc-commute-right (arg)
124 (calc-commute-left (- arg))
126 (calc-preserve-point)
127 (let ((num (max 1 (calc-locate-cursor-element (point))))
128 (calc-sel-reselect calc-keep-selection))
129 (if (= arg 0) (setq arg nil))
130 (while (or (null arg) (>= (setq arg (1- arg)) 0))
131 (let* ((entry (calc-top num 'entry))
133 (sel (calc-auto-selection entry))
136 (consp (setq parent (calc-find-assoc-parent-formula
138 (error "No term is selected"))
139 (if (and calc-assoc-selections
140 (assq (car parent) calc-assoc-ops))
141 (let ((outer (calc-find-parent-formula parent sel)))
142 (if (eq sel (nth 1 outer))
143 (setq new (calc-replace-sub-formula
145 (if (memq (car outer)
146 (nth 2 (assq (car-safe (nth 2 outer))
148 (let ((other (nth 1 (nth 2 outer))))
149 (calc-build-assoc-term
152 (calc-build-assoc-term
155 (nth 2 (nth 2 outer)))))
158 (calc-build-assoc-term
160 (math-neg (nth 2 outer))
163 (calc-build-assoc-term
165 (calcFunc-div 1 (nth 2 outer))
167 (t (calc-build-assoc-term
171 (setq sel (nth 2 new))
173 (let ((next (calc-find-parent-formula parent outer)))
174 (if (not (and (consp next)
175 (eq outer (nth 1 next))))
177 (setq new (calc-build-assoc-term
179 (calc-build-assoc-term
180 (car next) (nth 1 outer) (nth 2 next))
183 new (calc-replace-sub-formula
184 parent next new))))))
185 (if (eq (nth (1- (length parent)) parent) sel)
187 (let ((p (nthcdr (calc-find-sub-formula parent sel)
188 (setq new (copy-sequence parent)))))
190 (setcar (cdr p) sel))))
193 (error "Term is already rightmost")
194 (or calc-sel-reselect
195 (calc-pop-push-list 1 (list expr) num '(nil)))
197 (calc-pop-push-record-list
199 (list (calc-replace-sub-formula expr parent new))
201 (list (and (or (not (eq arg 0)) calc-sel-reselect)
204 (defun calc-build-assoc-term (op lhs rhs)
205 (cond ((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 '-) (or (math-looks-negp rhs)
211 (and (eq (car-safe rhs) 'cplx)
212 (math-negp (nth 1 rhs))
213 (eq (nth 2 rhs) 0))))
214 (list '+ lhs (math-neg rhs)))
215 ((and (eq op '*) (and (eq (car-safe rhs) '/)
216 (or (math-equal-int (nth 1 rhs) 1)
217 (equal (nth 1 rhs) '(cplx 1 0)))))
218 (list '/ lhs (nth 2 rhs)))
219 ((and (eq op '/) (and (eq (car-safe rhs) '/)
220 (or (math-equal-int (nth 1 rhs) 1)
221 (equal (nth 1 rhs) '(cplx 1 0)))))
222 (list '/ lhs (nth 2 rhs)))
223 (t (list op lhs rhs))))
225 (defun calc-sel-unpack ()
228 (calc-preserve-point)
229 (let* ((num (max 1 (calc-locate-cursor-element (point))))
230 (calc-sel-reselect calc-keep-selection)
231 (entry (calc-top num 'entry))
233 (sel (or (calc-auto-selection entry) expr)))
234 (or (and (not (math-primp sel))
236 (error "Selection must be a function of one argument"))
237 (calc-pop-push-record-list 1 "unpk"
238 (list (calc-replace-sub-formula
239 expr sel (nth 1 sel)))
241 (list (and calc-sel-reselect (nth 1 sel)))))))
243 (defun calc-sel-isolate ()
246 (calc-preserve-point)
247 (let* ((num (max 1 (calc-locate-cursor-element (point))))
248 (calc-sel-reselect calc-keep-selection)
249 (entry (calc-top num 'entry))
251 (sel (or (calc-auto-selection entry) (error "No selection")))
254 (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
255 (error "Selection must be a member of an equation"))
256 (not (assq (car eqn) calc-tweak-eqn-table))))
257 (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
259 (error "No solution found"))
260 (setq soln (calc-encase-atoms
261 (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
262 (eq (nth 1 soln) sel))
264 (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
267 (calc-pop-push-record-list 1 "isol"
268 (list (calc-replace-sub-formula
271 (list (and calc-sel-reselect sel)))
272 (calc-handle-whys))))
274 (defun calc-sel-commute (many)
276 (let ((calc-assoc-selections nil))
277 (calc-rewrite-selection "CommuteRules" many "cmut"))
278 (calc-set-mode-line))
280 (defun calc-sel-jump-equals (many)
282 (calc-rewrite-selection "JumpRules" many "jump"))
284 (defun calc-sel-distribute (many)
286 (calc-rewrite-selection "DistribRules" many "dist"))
288 (defun calc-sel-merge (many)
290 (calc-rewrite-selection "MergeRules" many "merg"))
292 (defun calc-sel-negate (many)
294 (calc-rewrite-selection "NegateRules" many "jneg"))
296 (defun calc-sel-invert (many)
298 (calc-rewrite-selection "InvertRules" many "jinv"))
302 ;;; calcsel2.el ends here