Mercurial > emacs
annotate lisp/calc/calc-sel.el @ 45005:084928cfcfcb
(Fstart_process): Update call to openp.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Tue, 30 Apr 2002 01:01:37 +0000 |
parents | fcd507927105 |
children | f4d68f97221e |
rev | line source |
---|---|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
1 ;;; calc-sel.el --- data selection functions for Calc |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
2 |
40998
ee9c2872370b
Use `frame-width' instead of `screen-width',
Eli Zaretskii <eliz@gnu.org>
parents:
40785
diff
changeset
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
4 |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
5 ;; Author: David Gillespie <daveg@synaptics.com> |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
6 ;; Maintainer: Colin Walters <walters@debian.org> |
40785 | 7 |
8 ;; This file is part of GNU Emacs. | |
9 | |
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. | |
16 | |
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. | |
24 | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
25 ;;; Commentary: |
40785 | 26 |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
27 ;;; Code: |
40785 | 28 |
29 ;; This file is autoloaded from calc-ext.el. | |
30 (require 'calc-ext) | |
31 | |
32 (require 'calc-macs) | |
33 | |
34 (defun calc-Need-calc-sel () nil) | |
35 | |
36 | |
37 ;;; Selection commands. | |
38 | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
39 (defvar calc-keep-selection t) |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
40 |
40785 | 41 (defun calc-select-here (num &optional once keep) |
42 (interactive "P") | |
43 (calc-wrapper | |
44 (calc-prepare-selection) | |
45 (let ((found (calc-find-selected-part)) | |
46 (entry calc-selection-cache-entry)) | |
47 (or (and keep (nth 2 entry)) | |
48 (progn | |
49 (if once (progn | |
50 (setq calc-keep-selection nil) | |
51 (message "(Selection will apply to next command only)"))) | |
52 (calc-change-current-selection | |
53 (if found | |
54 (if (and num (> (setq num (prefix-numeric-value num)) 0)) | |
55 (progn | |
56 (while (and (>= (setq num (1- num)) 0) | |
57 (not (eq found (car entry)))) | |
58 (setq found (calc-find-assoc-parent-formula | |
59 (car entry) found))) | |
60 found) | |
61 (calc-grow-assoc-formula (car entry) found)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
62 (car entry)))))))) |
40785 | 63 |
64 (defun calc-select-once (num) | |
65 (interactive "P") | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
66 (calc-select-here num t)) |
40785 | 67 |
68 (defun calc-select-here-maybe (num) | |
69 (interactive "P") | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
70 (calc-select-here num nil t)) |
40785 | 71 |
72 (defun calc-select-once-maybe (num) | |
73 (interactive "P") | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
74 (calc-select-here num t t)) |
40785 | 75 |
76 (defun calc-select-additional () | |
77 (interactive) | |
78 (calc-wrapper | |
79 (let (calc-keep-selection) | |
80 (calc-prepare-selection)) | |
81 (let ((found (calc-find-selected-part)) | |
82 (entry calc-selection-cache-entry)) | |
83 (calc-change-current-selection | |
84 (if found | |
85 (let ((sel (nth 2 entry))) | |
86 (if sel | |
87 (progn | |
88 (while (not (or (eq sel (car entry)) | |
89 (calc-find-sub-formula sel found))) | |
90 (setq sel (calc-find-assoc-parent-formula | |
91 (car entry) sel))) | |
92 sel) | |
93 (calc-grow-assoc-formula (car entry) found))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
94 (car entry)))))) |
40785 | 95 |
96 (defun calc-select-more (num) | |
97 (interactive "P") | |
98 (calc-wrapper | |
99 (calc-prepare-selection) | |
100 (let ((entry calc-selection-cache-entry)) | |
101 (if (nth 2 entry) | |
102 (let ((sel (nth 2 entry))) | |
103 (while (and (not (eq sel (car entry))) | |
104 (>= (setq num (1- (prefix-numeric-value num))) 0)) | |
105 (setq sel (calc-find-assoc-parent-formula (car entry) sel))) | |
106 (calc-change-current-selection sel)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
107 (calc-select-here num))))) |
40785 | 108 |
109 (defun calc-select-less (num) | |
110 (interactive "p") | |
111 (calc-wrapper | |
112 (calc-prepare-selection) | |
113 (let ((found (calc-find-selected-part)) | |
114 (entry calc-selection-cache-entry)) | |
115 (calc-change-current-selection | |
116 (and found | |
117 (let ((sel (nth 2 entry)) | |
118 old index op) | |
119 (while (and sel | |
120 (not (eq sel found)) | |
121 (>= (setq num (1- num)) 0)) | |
122 (setq old sel | |
123 index (calc-find-sub-formula sel found)) | |
124 (and (setq sel (and index (nth index old))) | |
125 calc-assoc-selections | |
126 (setq op (assq (car-safe sel) calc-assoc-ops)) | |
127 (memq (car old) (nth index op)) | |
128 (setq num (1+ num)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
129 sel)))))) |
40785 | 130 |
131 (defun calc-select-part (num) | |
132 (interactive "P") | |
133 (or num (setq num (- last-command-char ?0))) | |
134 (calc-wrapper | |
135 (calc-prepare-selection) | |
136 (let ((sel (calc-find-nth-part (or (nth 2 calc-selection-cache-entry) | |
137 (car calc-selection-cache-entry)) | |
138 num))) | |
139 (if sel | |
140 (calc-change-current-selection sel) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
141 (error "%d is not a valid sub-formula index" num))))) |
40785 | 142 |
143 (defun calc-find-nth-part (expr num) | |
144 (if (and calc-assoc-selections | |
145 (assq (car-safe expr) calc-assoc-ops)) | |
146 (let (op) | |
147 (calc-find-nth-part-rec expr)) | |
148 (if (eq (car-safe expr) 'intv) | |
149 (and (>= num 1) (<= num 2) (nth (1+ num) expr)) | |
150 (and (not (Math-primp expr)) (>= num 1) (< num (length expr)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
151 (nth num expr))))) |
40785 | 152 |
153 (defun calc-find-nth-part-rec (expr) ; uses num, op | |
154 (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops)) | |
155 (memq (car expr) (nth 1 op))) | |
156 (calc-find-nth-part-rec (nth 1 expr)) | |
157 (and (= (setq num (1- num)) 0) | |
158 (nth 1 expr))) | |
159 (if (and (setq op (assq (car-safe (nth 2 expr)) calc-assoc-ops)) | |
160 (memq (car expr) (nth 2 op))) | |
161 (calc-find-nth-part-rec (nth 2 expr)) | |
162 (and (= (setq num (1- num)) 0) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
163 (nth 2 expr))))) |
40785 | 164 |
165 (defun calc-select-next (num) | |
166 (interactive "p") | |
167 (if (< num 0) | |
168 (calc-select-previous (- num)) | |
169 (calc-wrapper | |
170 (calc-prepare-selection) | |
171 (let* ((entry calc-selection-cache-entry) | |
172 (sel (nth 2 entry))) | |
173 (if sel | |
174 (progn | |
175 (while (>= (setq num (1- num)) 0) | |
176 (let* ((parent (calc-find-parent-formula (car entry) sel)) | |
177 (p parent) | |
178 op) | |
179 (and (eq p t) (setq p nil)) | |
180 (while (and (setq p (cdr p)) | |
181 (not (eq (car p) sel)))) | |
182 (if (cdr p) | |
183 (setq sel (or (and calc-assoc-selections | |
184 (setq op (assq (car-safe (nth 1 p)) | |
185 calc-assoc-ops)) | |
186 (memq (car parent) (nth 2 op)) | |
187 (nth 1 (nth 1 p))) | |
188 (nth 1 p))) | |
189 (if (and calc-assoc-selections | |
190 (setq op (assq (car-safe parent) calc-assoc-ops)) | |
191 (consp (setq p (calc-find-parent-formula | |
192 (car entry) parent))) | |
193 (eq (nth 1 p) parent) | |
194 (memq (car p) (nth 1 op))) | |
195 (setq sel (nth 2 p)) | |
196 (error "No \"next\" sub-formula"))))) | |
197 (calc-change-current-selection sel)) | |
198 (if (Math-primp (car entry)) | |
199 (calc-change-current-selection (car entry)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
200 (calc-select-part num))))))) |
40785 | 201 |
202 (defun calc-select-previous (num) | |
203 (interactive "p") | |
204 (if (< num 0) | |
205 (calc-select-next (- num)) | |
206 (calc-wrapper | |
207 (calc-prepare-selection) | |
208 (let* ((entry calc-selection-cache-entry) | |
209 (sel (nth 2 entry))) | |
210 (if sel | |
211 (progn | |
212 (while (>= (setq num (1- num)) 0) | |
213 (let* ((parent (calc-find-parent-formula (car entry) sel)) | |
214 (p (cdr-safe parent)) | |
215 (prev nil) | |
216 op) | |
217 (if (eq (car-safe parent) 'intv) (setq p (cdr p))) | |
218 (while (and (not (eq (car p) sel)) | |
219 (setq prev (car p) | |
220 p (cdr p)))) | |
221 (if prev | |
222 (setq sel (or (and calc-assoc-selections | |
223 (setq op (assq (car-safe prev) | |
224 calc-assoc-ops)) | |
225 (memq (car parent) (nth 1 op)) | |
226 (nth 2 prev)) | |
227 prev)) | |
228 (if (and calc-assoc-selections | |
229 (setq op (assq (car-safe parent) calc-assoc-ops)) | |
230 (consp (setq p (calc-find-parent-formula | |
231 (car entry) parent))) | |
232 (eq (nth 2 p) parent) | |
233 (memq (car p) (nth 2 op))) | |
234 (setq sel (nth 1 p)) | |
235 (error "No \"previous\" sub-formula"))))) | |
236 (calc-change-current-selection sel)) | |
237 (if (Math-primp (car entry)) | |
238 (calc-change-current-selection (car entry)) | |
239 (let ((len (if (and calc-assoc-selections | |
240 (assq (car (car entry)) calc-assoc-ops)) | |
241 (let (op (num 0)) | |
242 (calc-find-nth-part-rec (car entry)) | |
243 (- 1 num)) | |
244 (length (car entry))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
245 (calc-select-part (- len num))))))))) |
40785 | 246 |
247 (defun calc-find-parent-formula (expr part) | |
248 (cond ((eq expr part) t) | |
249 ((Math-primp expr) nil) | |
250 (t | |
251 (let ((p expr) res) | |
252 (while (and (setq p (cdr p)) | |
253 (not (setq res (calc-find-parent-formula | |
254 (car p) part))))) | |
255 (and p | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
256 (if (eq res t) expr res)))))) |
40785 | 257 |
258 | |
259 (defun calc-find-assoc-parent-formula (expr part) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
260 (calc-grow-assoc-formula expr (calc-find-parent-formula expr part))) |
40785 | 261 |
262 (defun calc-grow-assoc-formula (expr part) | |
263 (if calc-assoc-selections | |
264 (let ((op (assq (car-safe part) calc-assoc-ops))) | |
265 (if op | |
266 (let (new) | |
267 (while (and (consp (setq new (calc-find-parent-formula | |
268 expr part))) | |
269 (memq (car new) | |
270 (nth (calc-find-sub-formula new part) op))) | |
271 (setq part new)))) | |
272 part) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
273 part)) |
40785 | 274 |
275 (defun calc-find-sub-formula (expr part) | |
276 (cond ((eq expr part) t) | |
277 ((Math-primp expr) nil) | |
278 (t | |
279 (let ((num 1)) | |
280 (while (and (setq expr (cdr expr)) | |
281 (not (calc-find-sub-formula (car expr) part))) | |
282 (setq num (1+ num))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
283 (and expr num))))) |
40785 | 284 |
285 (defun calc-unselect (num) | |
286 (interactive "P") | |
287 (calc-wrapper | |
288 (calc-prepare-selection num) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
289 (calc-change-current-selection nil))) |
40785 | 290 |
291 (defun calc-clear-selections () | |
292 (interactive) | |
293 (calc-wrapper | |
294 (let ((limit (calc-stack-size)) | |
295 (n 1)) | |
296 (while (<= n limit) | |
297 (if (calc-top n 'sel) | |
298 (progn | |
299 (calc-prepare-selection n) | |
300 (calc-change-current-selection nil))) | |
301 (setq n (1+ n)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
302 (calc-clear-command-flag 'position-point))) |
40785 | 303 |
304 (defun calc-show-selections (arg) | |
305 (interactive "P") | |
306 (calc-wrapper | |
307 (calc-preserve-point) | |
308 (setq calc-show-selections (if arg | |
309 (> (prefix-numeric-value arg) 0) | |
310 (not calc-show-selections))) | |
311 (let ((p calc-stack)) | |
312 (while (and p | |
313 (or (null (nth 2 (car p))) | |
314 (equal (car p) calc-selection-cache-entry))) | |
315 (setq p (cdr p))) | |
316 (or (and p | |
317 (let ((calc-selection-cache-default-entry | |
318 calc-selection-cache-entry)) | |
319 (calc-do-refresh))) | |
320 (and calc-selection-cache-entry | |
321 (let ((sel (nth 2 calc-selection-cache-entry))) | |
322 (setcar (nthcdr 2 calc-selection-cache-entry) nil) | |
323 (calc-change-current-selection sel))))) | |
324 (message (if calc-show-selections | |
325 "Displaying only selected part of formulas" | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
326 "Displaying all but selected part of formulas")))) |
40785 | 327 |
328 (defun calc-preserve-point () | |
329 (or (looking-at "\\.\n+\\'") | |
330 (progn | |
331 (setq calc-final-point-line (+ (count-lines (point-min) (point)) | |
332 (if (bolp) 1 0)) | |
333 calc-final-point-column (current-column)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
334 (calc-set-command-flag 'position-point)))) |
40785 | 335 |
336 (defun calc-enable-selections (arg) | |
337 (interactive "P") | |
338 (calc-wrapper | |
339 (calc-preserve-point) | |
340 (setq calc-use-selections (if arg | |
341 (> (prefix-numeric-value arg) 0) | |
342 (not calc-use-selections))) | |
343 (calc-set-command-flag 'renum-stack) | |
344 (message (if calc-use-selections | |
345 "Commands operate only on selected sub-formulas" | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
346 "Selections of sub-formulas have no effect")))) |
40785 | 347 |
348 (defun calc-break-selections (arg) | |
349 (interactive "P") | |
350 (calc-wrapper | |
351 (calc-preserve-point) | |
352 (setq calc-assoc-selections (if arg | |
353 (<= (prefix-numeric-value arg) 0) | |
354 (not calc-assoc-selections))) | |
355 (message (if calc-assoc-selections | |
356 "Selection treats a+b+c as a sum of three terms" | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
357 "Selection treats a+b+c as (a+b)+c")))) |
40785 | 358 |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
359 (defvar calc-selection-cache-entry nil) |
40785 | 360 (defun calc-prepare-selection (&optional num) |
361 (or num (setq num (calc-locate-cursor-element (point)))) | |
362 (setq calc-selection-true-num num | |
363 calc-keep-selection t) | |
364 (or (> num 0) (setq num 1)) | |
365 ;; (if (or (< num 1) (> num (calc-stack-size))) | |
366 ;; (error "Cursor must be positioned on a stack element")) | |
367 (let* ((entry (calc-top num 'entry)) | |
368 ww w) | |
369 (or (equal entry calc-selection-cache-entry) | |
370 (progn | |
371 (setcar entry (calc-encase-atoms (car entry))) | |
372 (setq calc-selection-cache-entry entry | |
373 calc-selection-cache-num num | |
374 calc-selection-cache-comp | |
375 (let ((math-comp-tagged t)) | |
376 (math-compose-expr (car entry) 0)) | |
377 calc-selection-cache-offset | |
378 (+ (car (math-stack-value-offset calc-selection-cache-comp)) | |
379 (length calc-left-label) | |
380 (if calc-line-numbering 4 0)))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
381 (calc-preserve-point)) |
40785 | 382 |
383 ;;; The following ensures that no two subformulas will be "eq" to each other! | |
384 (defun calc-encase-atoms (x) | |
385 (if (or (not (consp x)) | |
386 (equal x '(float 0 0))) | |
387 (list 'cplx x 0) | |
388 (calc-encase-atoms-rec x) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
389 x)) |
40785 | 390 |
391 (defun calc-encase-atoms-rec (x) | |
392 (or (Math-primp x) | |
393 (progn | |
394 (if (eq (car x) 'intv) | |
395 (setq x (cdr x))) | |
396 (while (setq x (cdr x)) | |
397 (if (or (not (consp (car x))) | |
398 (equal (car x) '(float 0 0))) | |
399 (setcar x (list 'cplx (car x) 0)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
400 (calc-encase-atoms-rec (car x))))))) |
40785 | 401 |
402 (defun calc-find-selected-part () | |
403 (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset)) | |
404 toppt | |
405 (lcount 0) | |
406 (spaces 0) | |
407 (math-comp-sel-vpos (save-excursion | |
408 (beginning-of-line) | |
409 (let ((line (point))) | |
410 (calc-cursor-stack-index | |
411 calc-selection-cache-num) | |
412 (setq toppt (point)) | |
413 (while (< (point) line) | |
414 (forward-line 1) | |
415 (setq spaces (+ spaces | |
416 (current-indentation)) | |
417 lcount (1+ lcount))) | |
418 (- lcount (math-comp-ascent | |
419 calc-selection-cache-comp) -1)))) | |
420 (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset | |
421 spaces lcount)) | |
422 (math-comp-sel-tag nil)) | |
423 (and (>= math-comp-sel-hpos 0) | |
424 (> calc-selection-true-num 0) | |
425 (math-composition-to-string calc-selection-cache-comp 1000000)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
426 (nth 1 math-comp-sel-tag))) |
40785 | 427 |
428 (defun calc-change-current-selection (sub-expr) | |
429 (or (eq sub-expr (nth 2 calc-selection-cache-entry)) | |
430 (let ((calc-prepared-composition calc-selection-cache-comp) | |
431 (buffer-read-only nil) | |
432 top) | |
433 (calc-set-command-flag 'renum-stack) | |
434 (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr) | |
435 (calc-cursor-stack-index calc-selection-cache-num) | |
436 (setq top (point)) | |
437 (calc-cursor-stack-index (1- calc-selection-cache-num)) | |
438 (delete-region top (point)) | |
439 (let ((calc-selection-cache-default-entry calc-selection-cache-entry)) | |
440 (insert (math-format-stack-value calc-selection-cache-entry) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
441 "\n"))))) |
40785 | 442 |
443 (defun calc-top-selected (&optional n m) | |
444 (and calc-any-selections | |
445 calc-use-selections | |
446 (progn | |
447 (or n (setq n 1)) | |
448 (or m (setq m 1)) | |
449 (calc-check-stack (+ n m -1)) | |
450 (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack)) | |
451 (sel nil)) | |
452 (while (>= (setq n (1- n)) 0) | |
453 (if (nth 2 (car top)) | |
454 (setq sel (if sel t (nth 2 (car top))))) | |
455 (setq top (cdr top))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
456 sel)))) |
40785 | 457 |
458 (defun calc-replace-sub-formula (expr old new) | |
459 (setq new (calc-encase-atoms new)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
460 (calc-replace-sub-formula-rec expr)) |
40785 | 461 |
462 (defun calc-replace-sub-formula-rec (expr) | |
463 (cond ((eq expr old) new) | |
464 ((Math-primp expr) expr) | |
465 (t | |
466 (cons (car expr) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
467 (mapcar 'calc-replace-sub-formula-rec (cdr expr)))))) |
40785 | 468 |
469 (defun calc-sel-error () | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
470 (error "Illegal operation on sub-formulas")) |
40785 | 471 |
472 (defun calc-replace-selections (n vals m) | |
473 (if (calc-top-selected n m) | |
474 (let ((num (length vals))) | |
475 (calc-preserve-point) | |
476 (cond | |
477 ((= n num) | |
478 (let* ((old (calc-top-list n m 'entry)) | |
479 (new nil) | |
480 (sel nil) | |
481 val) | |
482 (while old | |
483 (if (nth 2 (car old)) | |
484 (setq val (calc-encase-atoms (car vals)) | |
485 new (cons (calc-replace-sub-formula (car (car old)) | |
486 (nth 2 (car old)) | |
487 val) | |
488 new) | |
489 sel (cons val sel)) | |
490 (setq new (cons (car vals) new) | |
491 sel (cons nil sel))) | |
492 (setq vals (cdr vals) | |
493 old (cdr old))) | |
494 (calc-pop-stack n m t) | |
495 (calc-push-list (nreverse new) | |
496 m (and calc-keep-selection (nreverse sel))))) | |
497 ((= num 1) | |
498 (let* ((old (calc-top-list n m 'entry)) | |
499 more) | |
500 (while (and old (not (nth 2 (car old)))) | |
501 (setq old (cdr old))) | |
502 (setq more old) | |
503 (while (and (setq more (cdr more)) (not (nth 2 (car more))))) | |
504 (and more | |
505 (calc-sel-error)) | |
506 (calc-pop-stack n m t) | |
507 (if old | |
508 (let ((val (calc-encase-atoms (car vals)))) | |
509 (calc-push-list (list (calc-replace-sub-formula | |
510 (car (car old)) | |
511 (nth 2 (car old)) | |
512 val)) | |
513 m (and calc-keep-selection (list val)))) | |
514 (calc-push-list vals)))) | |
515 (t (calc-sel-error)))) | |
516 (calc-pop-stack n m t) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
517 (calc-push-list vals m))) |
40785 | 518 |
519 (defun calc-delete-selection (n) | |
520 (let ((entry (calc-top n 'entry))) | |
521 (if (nth 2 entry) | |
522 (if (eq (nth 2 entry) (car entry)) | |
523 (progn | |
524 (calc-pop-stack 1 n t) | |
525 (calc-push-list '(0) n)) | |
526 (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry))) | |
527 (repl nil)) | |
528 (calc-preserve-point) | |
529 (calc-pop-stack 1 n t) | |
530 (cond ((or (memq (car parent) '(* / %)) | |
531 (and (eq (car parent) '^) | |
532 (eq (nth 2 parent) (nth 2 entry)))) | |
533 (setq repl 1)) | |
534 ((memq (car parent) '(vec calcFunc-min calcFunc-max))) | |
535 ((and (assq (car parent) calc-tweak-eqn-table) | |
536 (= (length parent) 3)) | |
537 (setq repl 'del)) | |
538 (t | |
539 (setq repl 0))) | |
540 (cond | |
541 ((eq repl 'del) | |
542 (calc-push-list (list | |
543 (calc-normalize | |
544 (calc-replace-sub-formula | |
545 (car entry) | |
546 parent | |
547 (if (eq (nth 2 entry) (nth 1 parent)) | |
548 (nth 2 parent) | |
549 (nth 1 parent))))) | |
550 n)) | |
551 (repl | |
552 (calc-push-list (list | |
553 (calc-normalize | |
554 (calc-replace-sub-formula (car entry) | |
555 (nth 2 entry) | |
556 repl))) | |
557 n)) | |
558 (t | |
559 (calc-push-list (list | |
560 (calc-normalize | |
561 (calc-replace-sub-formula (car entry) | |
562 parent | |
563 (delq (nth 2 entry) | |
564 (copy-sequence | |
565 parent))))) | |
566 n))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
567 (calc-pop-stack 1 n t)))) |
40785 | 568 |
569 (defun calc-roll-down-with-selections (n m) | |
570 (let ((vals (append (calc-top-list m 1) | |
571 (calc-top-list (- n m) (1+ m)))) | |
572 (sels (append (calc-top-list m 1 'sel) | |
573 (calc-top-list (- n m) (1+ m) 'sel)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
574 (calc-pop-push-list n vals 1 sels))) |
40785 | 575 |
576 (defun calc-roll-up-with-selections (n m) | |
577 (let ((vals (append (calc-top-list (- n m) 1) | |
578 (calc-top-list m (- n m -1)))) | |
579 (sels (append (calc-top-list (- n m) 1 'sel) | |
580 (calc-top-list m (- n m -1) 'sel)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
581 (calc-pop-push-list n vals 1 sels))) |
40785 | 582 |
583 (defun calc-auto-selection (entry) | |
584 (or (nth 2 entry) | |
585 (progn | |
586 (and (boundp 'reselect) (setq reselect nil)) | |
587 (calc-prepare-selection) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
588 (calc-grow-assoc-formula (car entry) (calc-find-selected-part))))) |
40785 | 589 |
590 (defun calc-copy-selection () | |
591 (interactive) | |
592 (calc-wrapper | |
593 (calc-preserve-point) | |
594 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
595 (entry (calc-top num 'entry))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
596 (calc-push (or (calc-auto-selection entry) (car entry)))))) |
40785 | 597 |
598 (defun calc-del-selection () | |
599 (interactive) | |
600 (calc-wrapper | |
601 (calc-preserve-point) | |
602 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
603 (entry (calc-top num 'entry)) | |
604 (sel (calc-auto-selection entry))) | |
605 (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
606 (calc-delete-selection num)))) |
40785 | 607 |
608 (defun calc-enter-selection () | |
609 (interactive) | |
610 (calc-wrapper | |
611 (calc-preserve-point) | |
612 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
613 (reselect calc-keep-selection) | |
614 (entry (calc-top num 'entry)) | |
615 (expr (car entry)) | |
616 (sel (or (calc-auto-selection entry) expr)) | |
617 alg) | |
618 (let ((calc-dollar-values (list sel)) | |
619 (calc-dollar-used 0)) | |
620 (setq alg (calc-do-alg-entry "" "Replace selection with: ")) | |
621 (and alg | |
622 (progn | |
623 (setq alg (calc-encase-atoms (car alg))) | |
624 (calc-pop-push-record-list 1 "repl" | |
625 (list (calc-replace-sub-formula | |
626 expr sel alg)) | |
627 num | |
628 (list (and reselect alg)))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
629 (calc-handle-whys)))) |
40785 | 630 |
631 (defun calc-edit-selection () | |
632 (interactive) | |
633 (calc-wrapper | |
634 (calc-preserve-point) | |
635 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
636 (reselect calc-keep-selection) | |
637 (entry (calc-top num 'entry)) | |
638 (expr (car entry)) | |
639 (sel (or (calc-auto-selection entry) expr)) | |
640 alg) | |
641 (let ((str (math-showing-full-precision | |
40998
ee9c2872370b
Use `frame-width' instead of `screen-width',
Eli Zaretskii <eliz@gnu.org>
parents:
40785
diff
changeset
|
642 (math-format-nice-expr sel (frame-width))))) |
40785 | 643 (calc-edit-mode (list 'calc-finish-selection-edit |
644 num (list 'quote sel) reselect)) | |
645 (insert str "\n")))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
646 (calc-show-edit-buffer)) |
40785 | 647 |
648 (defun calc-finish-selection-edit (num sel reselect) | |
649 (let ((buf (current-buffer)) | |
650 (str (buffer-substring (point) (point-max))) | |
651 (start (point))) | |
652 (switch-to-buffer calc-original-buffer) | |
653 (let ((val (math-read-expr str))) | |
654 (if (eq (car-safe val) 'error) | |
655 (progn | |
656 (switch-to-buffer buf) | |
657 (goto-char (+ start (nth 1 val))) | |
658 (error (nth 2 val)))) | |
659 (calc-wrapper | |
660 (calc-preserve-point) | |
661 (if disp-trail | |
662 (calc-trail-display 1 t)) | |
663 (setq val (calc-encase-atoms (calc-normalize val))) | |
664 (let ((expr (calc-top num 'full))) | |
665 (if (calc-find-sub-formula expr sel) | |
666 (calc-pop-push-record-list 1 "edit" | |
667 (list (calc-replace-sub-formula | |
668 expr sel val)) | |
669 num | |
670 (list (and reselect val))) | |
671 (calc-push val) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
672 (error "Original selection has been lost"))))))) |
40785 | 673 |
674 (defun calc-sel-evaluate (arg) | |
675 (interactive "p") | |
676 (calc-slow-wrapper | |
677 (calc-preserve-point) | |
678 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
679 (reselect calc-keep-selection) | |
680 (entry (calc-top num 'entry)) | |
681 (sel (or (calc-auto-selection entry) (car entry)))) | |
682 (calc-with-default-simplification | |
683 (let ((math-simplify-only nil)) | |
684 (calc-modify-simplify-mode arg) | |
685 (let ((val (calc-encase-atoms (calc-normalize sel)))) | |
686 (calc-pop-push-record-list 1 "jsmp" | |
687 (list (calc-replace-sub-formula | |
688 (car entry) sel val)) | |
689 num | |
690 (list (and reselect val)))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
691 (calc-handle-whys)))) |
40785 | 692 |
693 (defun calc-sel-expand-formula (arg) | |
694 (interactive "p") | |
695 (calc-slow-wrapper | |
696 (calc-preserve-point) | |
697 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
698 (reselect calc-keep-selection) | |
699 (entry (calc-top num 'entry)) | |
700 (sel (or (calc-auto-selection entry) (car entry)))) | |
701 (calc-with-default-simplification | |
702 (let ((math-simplify-only nil)) | |
703 (calc-modify-simplify-mode arg) | |
704 (let* ((math-expand-formulas (> arg 0)) | |
705 (val (calc-normalize sel)) | |
706 top) | |
707 (and (<= arg 0) | |
708 (setq top (math-expand-formula val)) | |
709 (setq val (calc-normalize top))) | |
710 (setq val (calc-encase-atoms val)) | |
711 (calc-pop-push-record-list 1 "jexf" | |
712 (list (calc-replace-sub-formula | |
713 (car entry) sel val)) | |
714 num | |
715 (list (and reselect val)))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
716 (calc-handle-whys)))) |
40785 | 717 |
718 (defun calc-sel-mult-both-sides (no-simp &optional divide) | |
719 (interactive "P") | |
720 (calc-wrapper | |
721 (calc-preserve-point) | |
722 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
723 (reselect calc-keep-selection) | |
724 (entry (calc-top num 'entry)) | |
725 (expr (car entry)) | |
726 (sel (or (calc-auto-selection entry) expr)) | |
727 (func (car-safe sel)) | |
728 alg lhs rhs) | |
729 (setq alg (calc-with-default-simplification | |
730 (car (calc-do-alg-entry "" | |
731 (if divide | |
732 "Divide both sides by: " | |
733 "Multiply both sides by: "))))) | |
734 (and alg | |
735 (progn | |
736 (if (and (or (eq func '/) | |
737 (assq func calc-tweak-eqn-table)) | |
738 (= (length sel) 3)) | |
739 (progn | |
740 (or (memq func '(/ calcFunc-eq calcFunc-neq)) | |
741 (if (math-known-nonposp alg) | |
742 (progn | |
743 (setq func (nth 1 (assq func | |
744 calc-tweak-eqn-table))) | |
745 (or (math-known-negp alg) | |
746 (message "Assuming this factor is nonzero"))) | |
747 (or (math-known-posp alg) | |
748 (if (math-known-nonnegp alg) | |
749 (message "Assuming this factor is nonzero") | |
750 (message "Assuming this factor is positive"))))) | |
751 (setq lhs (list (if divide '/ '*) (nth 1 sel) alg) | |
752 rhs (list (if divide '/ '*) (nth 2 sel) alg)) | |
753 (or no-simp | |
754 (progn | |
755 (setq lhs (math-simplify lhs) | |
756 rhs (math-simplify rhs)) | |
757 (and (eq func '/) | |
758 (or (Math-equal (nth 1 sel) 1) | |
759 (Math-equal (nth 1 sel) -1) | |
760 (and (memq (car-safe (nth 2 sel)) '(+ -)) | |
761 (memq (car-safe alg) '(+ -)))) | |
762 (setq rhs (math-expand-term rhs))))) | |
763 (setq alg (calc-encase-atoms | |
764 (calc-normalize (list func lhs rhs))))) | |
765 (setq rhs (list (if divide '* '/) sel alg)) | |
766 (or no-simp | |
767 (setq rhs (math-simplify rhs))) | |
768 (setq alg (calc-encase-atoms | |
769 (calc-normalize (if divide | |
770 (list '/ rhs alg) | |
771 (list '* alg rhs)))))) | |
772 (calc-pop-push-record-list 1 (if divide "div" "mult") | |
773 (list (calc-replace-sub-formula | |
774 expr sel alg)) | |
775 num | |
776 (list (and reselect alg))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
777 (calc-handle-whys)))) |
40785 | 778 |
779 (defun calc-sel-div-both-sides (no-simp) | |
780 (interactive "P") | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
781 (calc-sel-mult-both-sides no-simp t)) |
40785 | 782 |
783 (defun calc-sel-add-both-sides (no-simp &optional subtract) | |
784 (interactive "P") | |
785 (calc-wrapper | |
786 (calc-preserve-point) | |
787 (let* ((num (max 1 (calc-locate-cursor-element (point)))) | |
788 (reselect calc-keep-selection) | |
789 (entry (calc-top num 'entry)) | |
790 (expr (car entry)) | |
791 (sel (or (calc-auto-selection entry) expr)) | |
792 (func (car-safe sel)) | |
793 alg lhs rhs) | |
794 (setq alg (calc-with-default-simplification | |
795 (car (calc-do-alg-entry "" | |
796 (if subtract | |
797 "Subtract from both sides: " | |
798 "Add to both sides: "))))) | |
799 (and alg | |
800 (progn | |
801 (if (and (assq func calc-tweak-eqn-table) | |
802 (= (length sel) 3)) | |
803 (progn | |
804 (setq lhs (list (if subtract '- '+) (nth 1 sel) alg) | |
805 rhs (list (if subtract '- '+) (nth 2 sel) alg)) | |
806 (or no-simp | |
807 (setq lhs (math-simplify lhs) | |
808 rhs (math-simplify rhs))) | |
809 (setq alg (calc-encase-atoms | |
810 (calc-normalize (list func lhs rhs))))) | |
811 (setq rhs (list (if subtract '+ '-) sel alg)) | |
812 (or no-simp | |
813 (setq rhs (math-simplify rhs))) | |
814 (setq alg (calc-encase-atoms | |
815 (calc-normalize (list (if subtract '- '+) alg rhs))))) | |
816 (calc-pop-push-record-list 1 (if subtract "sub" "add") | |
817 (list (calc-replace-sub-formula | |
818 expr sel alg)) | |
819 num | |
820 (list (and reselect alg))))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
821 (calc-handle-whys)))) |
40785 | 822 |
823 (defun calc-sel-sub-both-sides (no-simp) | |
824 (interactive "P") | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
825 (calc-sel-add-both-sides no-simp t)) |
40785 | 826 |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40998
diff
changeset
|
827 ;;; calc-sel.el ends here |