1 ;;; calcsel2.el --- selection functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Colin Walters <walters@debian.org>
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 (defun calc-Need-calc-sel-2 () nil
)
37 (defun calc-commute-left (arg)
40 (calc-commute-right (- arg
))
43 (let ((num (max 1 (calc-locate-cursor-element (point))))
44 (reselect calc-keep-selection
))
45 (if (= arg
0) (setq arg nil
))
46 (while (or (null arg
) (>= (setq arg
(1- arg
)) 0))
47 (let* ((entry (calc-top num
'entry
))
49 (sel (calc-auto-selection entry
))
52 (consp (setq parent
(calc-find-assoc-parent-formula
54 (error "No term is selected"))
55 (if (and calc-assoc-selections
56 (assq (car parent
) calc-assoc-ops
))
57 (let ((outer (calc-find-parent-formula parent sel
)))
58 (if (eq sel
(nth 2 outer
))
59 (setq new
(calc-replace-sub-formula
63 (nth 1 (assq (car-safe (nth 1 outer
))
65 (let* ((other (nth 2 (nth 1 outer
)))
66 (new (calc-build-assoc-term
68 (calc-build-assoc-term
73 (setq sel
(nth 2 (nth 1 new
)))
76 (calc-build-assoc-term
78 (setq sel
(math-neg sel
))
81 (calc-build-assoc-term
83 (setq sel
(calcFunc-div 1 sel
))
85 (t (calc-build-assoc-term
86 (car outer
) sel
(nth 1 outer
))))))
87 (let ((next (calc-find-parent-formula parent outer
)))
88 (if (not (and (consp next
)
89 (eq outer
(nth 2 next
))
90 (eq (car next
) (car outer
))))
92 (setq new
(calc-build-assoc-term
95 (calc-build-assoc-term
96 (car next
) (nth 1 next
) (nth 2 outer
)))
98 new
(calc-replace-sub-formula
100 (if (eq (nth 1 parent
) sel
)
102 (let ((p (nthcdr (1- (calc-find-sub-formula parent sel
))
103 (setq new
(copy-sequence parent
)))))
104 (setcar (cdr p
) (car p
))
108 (error "Term is already leftmost")
110 (calc-pop-push-list 1 (list expr
) num
'(nil)))
112 (calc-pop-push-record-list
114 (list (calc-replace-sub-formula expr parent new
))
116 (list (and (or (not (eq arg
0)) reselect
)
119 (defun calc-commute-right (arg)
122 (calc-commute-left (- arg
))
124 (calc-preserve-point)
125 (let ((num (max 1 (calc-locate-cursor-element (point))))
126 (reselect calc-keep-selection
))
127 (if (= arg
0) (setq arg nil
))
128 (while (or (null arg
) (>= (setq arg
(1- arg
)) 0))
129 (let* ((entry (calc-top num
'entry
))
131 (sel (calc-auto-selection entry
))
134 (consp (setq parent
(calc-find-assoc-parent-formula
136 (error "No term is selected"))
137 (if (and calc-assoc-selections
138 (assq (car parent
) calc-assoc-ops
))
139 (let ((outer (calc-find-parent-formula parent sel
)))
140 (if (eq sel
(nth 1 outer
))
141 (setq new
(calc-replace-sub-formula
143 (if (memq (car outer
)
144 (nth 2 (assq (car-safe (nth 2 outer
))
146 (let ((other (nth 1 (nth 2 outer
))))
147 (calc-build-assoc-term
150 (calc-build-assoc-term
153 (nth 2 (nth 2 outer
)))))
156 (calc-build-assoc-term
158 (math-neg (nth 2 outer
))
161 (calc-build-assoc-term
163 (calcFunc-div 1 (nth 2 outer
))
165 (t (calc-build-assoc-term
169 (setq sel
(nth 2 new
))
171 (let ((next (calc-find-parent-formula parent outer
)))
172 (if (not (and (consp next
)
173 (eq outer
(nth 1 next
))))
175 (setq new
(calc-build-assoc-term
177 (calc-build-assoc-term
178 (car next
) (nth 1 outer
) (nth 2 next
))
181 new
(calc-replace-sub-formula
182 parent next new
))))))
183 (if (eq (nth (1- (length parent
)) parent
) sel
)
185 (let ((p (nthcdr (calc-find-sub-formula parent sel
)
186 (setq new
(copy-sequence parent
)))))
188 (setcar (cdr p
) sel
))))
191 (error "Term is already rightmost")
193 (calc-pop-push-list 1 (list expr
) num
'(nil)))
195 (calc-pop-push-record-list
197 (list (calc-replace-sub-formula expr parent new
))
199 (list (and (or (not (eq arg
0)) reselect
)
202 (defun calc-build-assoc-term (op lhs rhs
)
203 (cond ((and (eq op
'+) (or (math-looks-negp rhs
)
204 (and (eq (car-safe rhs
) 'cplx
)
205 (math-negp (nth 1 rhs
))
206 (eq (nth 2 rhs
) 0))))
207 (list '- lhs
(math-neg rhs
)))
208 ((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
'*) (and (eq (car-safe rhs
) '/)
214 (or (math-equal-int (nth 1 rhs
) 1)
215 (equal (nth 1 rhs
) '(cplx 1 0)))))
216 (list '/ lhs
(nth 2 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 (t (list op lhs rhs
))))
223 (defun calc-sel-unpack ()
226 (calc-preserve-point)
227 (let* ((num (max 1 (calc-locate-cursor-element (point))))
228 (reselect calc-keep-selection
)
229 (entry (calc-top num
'entry
))
231 (sel (or (calc-auto-selection entry
) expr
)))
232 (or (and (not (math-primp sel
))
234 (error "Selection must be a function of one argument"))
235 (calc-pop-push-record-list 1 "unpk"
236 (list (calc-replace-sub-formula
237 expr sel
(nth 1 sel
)))
239 (list (and reselect
(nth 1 sel
)))))))
241 (defun calc-sel-isolate ()
244 (calc-preserve-point)
245 (let* ((num (max 1 (calc-locate-cursor-element (point))))
246 (reselect calc-keep-selection
)
247 (entry (calc-top num
'entry
))
249 (sel (or (calc-auto-selection entry
) (error "No selection")))
252 (while (and (or (consp (setq eqn
(calc-find-parent-formula expr eqn
)))
253 (error "Selection must be a member of an equation"))
254 (not (assq (car eqn
) calc-tweak-eqn-table
))))
255 (setq soln
(math-solve-eqn eqn sel calc-hyperbolic-flag
))
257 (error "No solution found"))
258 (setq soln
(calc-encase-atoms
259 (if (eq (not (calc-find-sub-formula (nth 2 eqn
) sel
))
260 (eq (nth 1 soln
) sel
))
262 (list (nth 1 (assq (car soln
) calc-tweak-eqn-table
))
265 (calc-pop-push-record-list 1 "isol"
266 (list (calc-replace-sub-formula
269 (list (and reselect sel
)))
270 (calc-handle-whys))))
272 (defun calc-sel-commute (many)
274 (let ((calc-assoc-selections nil
))
275 (calc-rewrite-selection "CommuteRules" many
"cmut"))
276 (calc-set-mode-line))
278 (defun calc-sel-jump-equals (many)
280 (calc-rewrite-selection "JumpRules" many
"jump"))
282 (defun calc-sel-distribute (many)
284 (calc-rewrite-selection "DistribRules" many
"dist"))
286 (defun calc-sel-merge (many)
288 (calc-rewrite-selection "MergeRules" many
"merg"))
290 (defun calc-sel-negate (many)
292 (calc-rewrite-selection "NegateRules" many
"jneg"))
294 (defun calc-sel-invert (many)
296 (calc-rewrite-selection "InvertRules" many
"jinv"))
298 ;;; calcsel2.el ends here