1 ;;; calcsel2.el --- selection functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2005 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Jay Belanger <belanger@truman.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
34 ;; The variable calc-keep-selection is declared and set in calc-sel.el.
35 (defvar calc-keep-selection
)
37 ;; The variable calc-sel-reselect is local to the methods below,
38 ;; but is used by some functions in calc-sel.el which are called
39 ;; by the functions below.
41 (defun calc-commute-left (arg)
44 (calc-commute-right (- arg
))
47 (let ((num (max 1 (calc-locate-cursor-element (point))))
48 (calc-sel-reselect calc-keep-selection
))
49 (if (= arg
0) (setq arg nil
))
50 (while (or (null arg
) (>= (setq arg
(1- arg
)) 0))
51 (let* ((entry (calc-top num
'entry
))
53 (sel (calc-auto-selection entry
))
56 (consp (setq parent
(calc-find-assoc-parent-formula
58 (error "No term is selected"))
59 (if (and calc-assoc-selections
60 (assq (car parent
) calc-assoc-ops
))
61 (let ((outer (calc-find-parent-formula parent sel
)))
62 (if (eq sel
(nth 2 outer
))
63 (setq new
(calc-replace-sub-formula
67 (nth 1 (assq (car-safe (nth 1 outer
))
69 (let* ((other (nth 2 (nth 1 outer
)))
70 (new (calc-build-assoc-term
72 (calc-build-assoc-term
77 (setq sel
(nth 2 (nth 1 new
)))
80 (calc-build-assoc-term
82 (setq sel
(math-neg sel
))
85 (calc-build-assoc-term
87 (setq sel
(calcFunc-div 1 sel
))
89 (t (calc-build-assoc-term
90 (car outer
) sel
(nth 1 outer
))))))
91 (let ((next (calc-find-parent-formula parent outer
)))
92 (if (not (and (consp next
)
93 (eq outer
(nth 2 next
))
94 (eq (car next
) (car outer
))))
96 (setq new
(calc-build-assoc-term
99 (calc-build-assoc-term
100 (car next
) (nth 1 next
) (nth 2 outer
)))
102 new
(calc-replace-sub-formula
103 parent next new
))))))
104 (if (eq (nth 1 parent
) sel
)
106 (let ((p (nthcdr (1- (calc-find-sub-formula parent sel
))
107 (setq new
(copy-sequence parent
)))))
108 (setcar (cdr p
) (car p
))
112 (error "Term is already leftmost")
113 (or calc-sel-reselect
114 (calc-pop-push-list 1 (list expr
) num
'(nil)))
116 (calc-pop-push-record-list
118 (list (calc-replace-sub-formula expr parent new
))
120 (list (and (or (not (eq arg
0)) calc-sel-reselect
)
123 (defun calc-commute-right (arg)
126 (calc-commute-left (- arg
))
128 (calc-preserve-point)
129 (let ((num (max 1 (calc-locate-cursor-element (point))))
130 (calc-sel-reselect calc-keep-selection
))
131 (if (= arg
0) (setq arg nil
))
132 (while (or (null arg
) (>= (setq arg
(1- arg
)) 0))
133 (let* ((entry (calc-top num
'entry
))
135 (sel (calc-auto-selection entry
))
138 (consp (setq parent
(calc-find-assoc-parent-formula
140 (error "No term is selected"))
141 (if (and calc-assoc-selections
142 (assq (car parent
) calc-assoc-ops
))
143 (let ((outer (calc-find-parent-formula parent sel
)))
144 (if (eq sel
(nth 1 outer
))
145 (setq new
(calc-replace-sub-formula
147 (if (memq (car outer
)
148 (nth 2 (assq (car-safe (nth 2 outer
))
150 (let ((other (nth 1 (nth 2 outer
))))
151 (calc-build-assoc-term
154 (calc-build-assoc-term
157 (nth 2 (nth 2 outer
)))))
160 (calc-build-assoc-term
162 (math-neg (nth 2 outer
))
165 (calc-build-assoc-term
167 (calcFunc-div 1 (nth 2 outer
))
169 (t (calc-build-assoc-term
173 (setq sel
(nth 2 new
))
175 (let ((next (calc-find-parent-formula parent outer
)))
176 (if (not (and (consp next
)
177 (eq outer
(nth 1 next
))))
179 (setq new
(calc-build-assoc-term
181 (calc-build-assoc-term
182 (car next
) (nth 1 outer
) (nth 2 next
))
185 new
(calc-replace-sub-formula
186 parent next new
))))))
187 (if (eq (nth (1- (length parent
)) parent
) sel
)
189 (let ((p (nthcdr (calc-find-sub-formula parent sel
)
190 (setq new
(copy-sequence parent
)))))
192 (setcar (cdr p
) sel
))))
195 (error "Term is already rightmost")
196 (or calc-sel-reselect
197 (calc-pop-push-list 1 (list expr
) num
'(nil)))
199 (calc-pop-push-record-list
201 (list (calc-replace-sub-formula expr parent new
))
203 (list (and (or (not (eq arg
0)) calc-sel-reselect
)
206 (defun calc-build-assoc-term (op lhs rhs
)
207 (cond ((and (eq op
'+) (or (math-looks-negp rhs
)
208 (and (eq (car-safe rhs
) 'cplx
)
209 (math-negp (nth 1 rhs
))
210 (eq (nth 2 rhs
) 0))))
211 (list '- lhs
(math-neg rhs
)))
212 ((and (eq op
'-
) (or (math-looks-negp rhs
)
213 (and (eq (car-safe rhs
) 'cplx
)
214 (math-negp (nth 1 rhs
))
215 (eq (nth 2 rhs
) 0))))
216 (list '+ lhs
(math-neg rhs
)))
217 ((and (eq op
'*) (and (eq (car-safe rhs
) '/)
218 (or (math-equal-int (nth 1 rhs
) 1)
219 (equal (nth 1 rhs
) '(cplx 1 0)))))
220 (list '/ lhs
(nth 2 rhs
)))
221 ((and (eq op
'/) (and (eq (car-safe rhs
) '/)
222 (or (math-equal-int (nth 1 rhs
) 1)
223 (equal (nth 1 rhs
) '(cplx 1 0)))))
224 (list '/ lhs
(nth 2 rhs
)))
225 (t (list op lhs rhs
))))
227 (defun calc-sel-unpack ()
230 (calc-preserve-point)
231 (let* ((num (max 1 (calc-locate-cursor-element (point))))
232 (calc-sel-reselect calc-keep-selection
)
233 (entry (calc-top num
'entry
))
235 (sel (or (calc-auto-selection entry
) expr
)))
236 (or (and (not (math-primp sel
))
238 (error "Selection must be a function of one argument"))
239 (calc-pop-push-record-list 1 "unpk"
240 (list (calc-replace-sub-formula
241 expr sel
(nth 1 sel
)))
243 (list (and calc-sel-reselect
(nth 1 sel
)))))))
245 (defun calc-sel-isolate ()
248 (calc-preserve-point)
249 (let* ((num (max 1 (calc-locate-cursor-element (point))))
250 (calc-sel-reselect calc-keep-selection
)
251 (entry (calc-top num
'entry
))
253 (sel (or (calc-auto-selection entry
) (error "No selection")))
256 (while (and (or (consp (setq eqn
(calc-find-parent-formula expr eqn
)))
257 (error "Selection must be a member of an equation"))
258 (not (assq (car eqn
) calc-tweak-eqn-table
))))
259 (setq soln
(math-solve-eqn eqn sel calc-hyperbolic-flag
))
261 (error "No solution found"))
262 (setq soln
(calc-encase-atoms
263 (if (eq (not (calc-find-sub-formula (nth 2 eqn
) sel
))
264 (eq (nth 1 soln
) sel
))
266 (list (nth 1 (assq (car soln
) calc-tweak-eqn-table
))
269 (calc-pop-push-record-list 1 "isol"
270 (list (calc-replace-sub-formula
273 (list (and calc-sel-reselect sel
)))
274 (calc-handle-whys))))
276 (defun calc-sel-commute (many)
278 (let ((calc-assoc-selections nil
))
279 (calc-rewrite-selection "CommuteRules" many
"cmut"))
280 (calc-set-mode-line))
282 (defun calc-sel-jump-equals (many)
284 (calc-rewrite-selection "JumpRules" many
"jump"))
286 (defun calc-sel-distribute (many)
288 (calc-rewrite-selection "DistribRules" many
"dist"))
290 (defun calc-sel-merge (many)
292 (calc-rewrite-selection "MergeRules" many
"merg"))
294 (defun calc-sel-negate (many)
296 (calc-rewrite-selection "NegateRules" many
"jneg"))
298 (defun calc-sel-invert (many)
300 (calc-rewrite-selection "InvertRules" many
"jinv"))
304 ;;; arch-tag: 7c5b8d65-b8f0-45d9-820d-9930f8ee114b
305 ;;; calcsel2.el ends here