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