annotate lisp/calc/calc-sel.el @ 97528:184bb2071e3f

mail/: Add new (temporary) libaries for which to test Rmail/mbox such that Rmail/babyl is not affected. This creates a facility/feature called "pmail" (analagous to "rmail") that can be used independently from Rmail for testing purposes. The plan is to replace the "rmail" files eventually and remove "pmail" entirely at that point. In the interim, interested developers can use either Rmail or Pmail or both (which is not recommended for the casual User or the faint of heart).

;;; calc-sel.el --- data selection functions for Calc

;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: David Gillespie <[e-mail]>
;; Maintainer: Jay Belanger <[e-mail]>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.

(require 'calc-ext)
(require 'calc-macs)

;;; Selection commands.

(defvar calc-keep-selection t)

(defvar calc-selection-cache-entry nil)
(defvar calc-selection-cache-num)
(defvar calc-selection-cache-comp)
(defvar calc-selection-cache-offset)
(defvar calc-selection-true-num)

(defun calc-select-here (num &optional once keep)
  (interactive "P")
  (calc-wrapper
   (calc-prepare-selection)
   (let ((found (calc-find-selected-part))
	 (entry calc-selection-cache-entry))
     (or (and keep (nth 2 entry))
	 (progn
	   (if once (progn
		      (setq calc-keep-selection nil)
		      (message "(Selection will apply to next command only)")))
	   (calc-change-current-selection
	    (if found
		(if (and num (> (setq num (prefix-numeric-value num)) 0))
		    (progn
		      (while (and (>= (setq num (1- num)) 0)
				  (not (eq found (car entry))))
			(setq found (calc-find-assoc-parent-formula
				     (car entry) found)))
		      found)
		  (calc-grow-assoc-formula (car entry) found))
	      (car entry))))))))

(defun calc-select-once (num)
  (interactive "P")
  (calc-select-here num t))

(defun calc-select-here-maybe (num)
  (interactive "P")
  (calc-select-here num nil t))

(defun calc-select-once-maybe (num)
  (interactive "P")
  (calc-select-here num t t))

(defun calc-select-additional ()
  (interactive)
  (calc-wrapper
   (let (calc-keep-selection)
     (calc-prepare-selection))
   (let ((found (calc-find-selected-part))
	 (entry calc-selection-cache-entry))
     (calc-change-current-selection
      (if found
	  (let ((sel (nth 2 entry)))
	    (if sel
		(progn
		  (while (not (or (eq sel (car entry))
				  (calc-find-sub-formula sel found)))
		    (setq sel (calc-find-assoc-parent-formula
			       (car entry) sel)))
		  sel)
	      (calc-grow-assoc-formula (car entry) found)))
	(car entry))))))

(defun calc-select-more (num)
  (interactive "P")
  (calc-wrapper
   (calc-prepare-selection)
   (let ((entry calc-selection-cache-entry))
     (if (nth 2 entry)
	 (let ((sel (nth 2 entry)))
	   (while (and (not (eq sel (car entry)))
		       (>= (setq num (1- (prefix-numeric-value num))) 0))
	     (setq sel (calc-find-assoc-parent-formula (car entry) sel)))
	   (calc-change-current-selection sel))
       (calc-select-here num)))))

(defun calc-select-less (num)
  (interactive "p")
  (calc-wrapper
   (calc-prepare-selection)
   (let ((found (calc-find-selected-part))
	 (entry calc-selection-cache-entry))
     (calc-change-current-selection
      (and found
	   (let ((sel (nth 2 entry))
		 old index op)
	     (while (and sel
			 (not (eq sel found))
			 (>= (setq num (1- num)) 0))
	       (setq old sel
		     index (calc-find-sub-formula sel found))
	       (and (setq sel (and index (nth index old)))
		    calc-assoc-selections
		    (setq op (assq (car-safe sel) calc-assoc-ops))
		    (memq (car old) (nth index op))
		    (setq num (1+ num))))
	     sel))))))

(defun calc-select-part (num)
  (interactive "P")
  (or num (setq num (- last-command-char ?0)))
  (calc-wrapper
   (calc-prepare-selection)
   (let ((sel (calc-find-nth-part (or (nth 2 calc-selection-cache-entry)
				      (car calc-selection-cache-entry))
				  num)))
     (if sel
	 (calc-change-current-selection sel)
       (error "%d is not a valid sub-formula index" num)))))

;; The variables calc-fnp-op and calc-fnp-num are local to 
;; calc-find-nth-part (and calc-select-previous) but used by 
;; calc-find-nth-part-rec, which is called by them.
(defvar calc-fnp-op)
(defvar calc-fnp-num)

(defun calc-find-nth-part (expr calc-fnp-num)
  (if (and calc-assoc-selections
	   (assq (car-safe expr) calc-assoc-ops))
      (let (calc-fnp-op)
	(calc-find-nth-part-rec expr))
    (if (eq (car-safe expr) 'intv)
	(and (>= calc-fnp-num 1) (<= calc-fnp-num 2) (nth (1+ calc-fnp-num) expr))
      (and (not (Math-primp expr)) (>= calc-fnp-num 1) (< calc-fnp-num (length expr))
	   (nth calc-fnp-num expr)))))

(defun calc-find-nth-part-rec (expr)   ; uses num, op
  (or (if (and (setq calc-fnp-op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
	       (memq (car expr) (nth 1 calc-fnp-op)))
	  (calc-find-nth-part-rec (nth 1 expr))
	(and (= (setq calc-fnp-num (1- calc-fnp-num)) 0)
	     (nth 1 expr)))
      (if (and (setq calc-fnp-op (assq (car-safe (nth 2 expr)) calc-assoc-ops))
	       (memq (car expr) (nth 2 calc-fnp-op)))
	  (calc-find-nth-part-rec (nth 2 expr))
	(and (= (setq calc-fnp-num (1- calc-fnp-num)) 0)
	     (nth 2 expr)))))

(defun calc-select-next (num)
  (interactive "p")
  (if (< num 0)
      (calc-select-previous (- num))
    (calc-wrapper
     (calc-prepare-selection)
     (let* ((entry calc-selection-cache-entry)
	    (sel (nth 2 entry)))
       (if sel
	   (progn
	     (while (>= (setq num (1- num)) 0)
	       (let* ((parent (calc-find-parent-formula (car entry) sel))
		     (p parent)
		     op)
		 (and (eq p t) (setq p nil))
		 (while (and (setq p (cdr p))
			     (not (eq (car p) sel))))
		 (if (cdr p)
		     (setq sel (or (and calc-assoc-selections
					(setq op (assq (car-safe (nth 1 p))
						       calc-assoc-ops))
					(memq (car parent) (nth 2 op))
					(nth 1 (nth 1 p)))
				   (nth 1 p)))
		   (if (and calc-assoc-selections
			    (setq op (assq (car-safe parent) calc-assoc-ops))
			    (consp (setq p (calc-find-parent-formula
					    (car entry) parent)))
			    (eq (nth 1 p) parent)
			    (memq (car p) (nth 1 op)))
		       (setq sel (nth 2 p))
		     (error "No \"next\" sub-formula")))))
	     (calc-change-current-selection sel))
	 (if (Math-primp (car entry))
	     (calc-change-current-selection (car entry))
	   (calc-select-part num)))))))

(defun calc-select-previous (num)
  (interactive "p")
  (if (< num 0)
      (calc-select-next (- num))
    (calc-wrapper
     (calc-prepare-selection)
     (let* ((entry calc-selection-cache-entry)
	    (sel (nth 2 entry)))
       (if sel
	   (progn
	     (while (>= (setq num (1- num)) 0)
	       (let* ((parent (calc-find-parent-formula (car entry) sel))
		      (p (cdr-safe parent))
		      (prev nil)
		      op)
		 (if (eq (car-safe parent) 'intv) (setq p (cdr p)))
		 (while (and (not (eq (car p) sel))
			     (setq prev (car p)
				   p (cdr p))))
		 (if prev
		     (setq sel (or (and calc-assoc-selections
					(setq op (assq (car-safe prev)
						       calc-assoc-ops))
					(memq (car parent) (nth 1 op))
					(nth 2 prev))
				   prev))
		   (if (and calc-assoc-selections
			    (setq op (assq (car-safe parent) calc-assoc-ops))
			    (consp (setq p (calc-find-parent-formula
					    (car entry) parent)))
			    (eq (nth 2 p) parent)
			    (memq (car p) (nth 2 op)))
		       (setq sel (nth 1 p))
		     (error "No \"previous\" sub-formula")))))
	     (calc-change-current-selection sel))
	 (if (Math-primp (car entry))
	     (calc-change-current-selection (car entry))
	   (let ((len (if (and calc-assoc-selections
			       (assq (car (car entry)) calc-assoc-ops))
			  (let (calc-fnp-op (calc-fnp-num 0))
			    (calc-find-nth-part-rec (car entry))
			    (- 1 calc-fnp-num))
			(length (car entry)))))
	     (calc-select-part (- len num)))))))))

(defun calc-find-parent-formula (expr part)
  (cond ((eq expr part) t)
	((Math-primp expr) nil)
	(t
	 (let ((p expr) res)
	   (while (and (setq p (cdr p))
		       (not (setq res (calc-find-parent-formula
				       (car p) part)))))
	   (and p
		(if (eq res t) expr res))))))


(defun calc-find-assoc-parent-formula (expr part)
  (calc-grow-assoc-formula expr (calc-find-parent-formula expr part)))

(defun calc-grow-assoc-formula (expr part)
  (if calc-assoc-selections
      (let ((op (assq (car-safe part) calc-assoc-ops)))
	(if op
	    (let (new)
	      (while (and (consp (setq new (calc-find-parent-formula
					    expr part)))
			  (memq (car new)
				(nth (calc-find-sub-formula new part) op)))
		(setq part new))))
	part)
    part))

(defun calc-find-sub-formula (expr part)
  (cond ((eq expr part) t)
	((Math-primp expr) nil)
	(t
	 (let ((num 1))
	   (while (and (setq expr (cdr expr))
		       (not (calc-find-sub-formula (car expr) part)))
	     (setq num (1+ num)))
	   (and expr num)))))

(defun calc-unselect (num)
  (interactive "P")
  (calc-wrapper
   (calc-prepare-selection num)
   (calc-change-current-selection nil)))

(defun calc-clear-selections ()
  (interactive)
  (calc-wrapper
   (let ((limit (calc-stack-size))
	 (n 1))
     (while (<= n limit)
       (if (calc-top n 'sel)
	   (progn
	     (calc-prepare-selection n)
	     (calc-change-current-selection nil)))
       (setq n (1+ n))))
   (calc-clear-command-flag 'position-point)))

(defun calc-show-selections (arg)
  (interactive "P")
  (calc-wrapper
   (calc-preserve-point)
   (setq calc-show-selections (if arg
				  (> (prefix-numeric-value arg) 0)
				(not calc-show-selections)))
   (let ((p calc-stack))
     (while (and p
		 (or (null (nth 2 (car p)))
		     (equal (car p) calc-selection-cache-entry)))
       (setq p (cdr p)))
     (or (and p
	      (let ((calc-selection-cache-default-entry
		     calc-selection-cache-entry))
		(calc-do-refresh)))
	 (and calc-selection-cache-entry
	      (let ((sel (nth 2 calc-selection-cache-entry)))
		(setcar (nthcdr 2 calc-selection-cache-entry) nil)
		(calc-change-current-selection sel)))))
   (message (if calc-show-selections
		"Displaying only selected part of formulas"
	      "Displaying all but selected part of formulas"))))

;; The variables calc-final-point-line and calc-final-point-column
;; are declared in calc.el, and are used throughout.
(defvar calc-final-point-line)
(defvar calc-final-point-column)

(defun calc-preserve-point ()
  (or (looking-at "\\.\n+\\'")
      (progn
	(setq calc-final-point-line (+ (count-lines (point-min) (point))
				       (if (bolp) 1 0))
	      calc-final-point-column (current-column))
	(calc-set-command-flag 'position-point))))

(defun calc-enable-selections (arg)
  (interactive "P")
  (calc-wrapper
   (calc-preserve-point)
   (setq calc-use-selections (if arg
				 (> (prefix-numeric-value arg) 0)
			       (not calc-use-selections)))
   (calc-set-command-flag 'renum-stack)
   (message (if calc-use-selections
		"Commands operate only on selected sub-formulas"
	      "Selections of sub-formulas have no effect"))))

(defun calc-break-selections (arg)
  (interactive "P")
  (calc-wrapper
   (calc-preserve-point)
   (setq calc-assoc-selections (if arg
				   (<= (prefix-numeric-value arg) 0)
				 (not calc-assoc-selections)))
   (message (if calc-assoc-selections
		"Selection treats a+b+c as a sum of three terms"
	      "Selection treats a+b+c as (a+b)+c"))))

(defun calc-prepare-selection (&optional num)
  (or num (setq num (calc-locate-cursor-element (point))))
  (setq calc-selection-true-num num
	calc-keep-selection t)
  (or (> num 0) (setq num 1))
  ;; (if (or (< num 1) (> num (calc-stack-size)))
  ;;     (error "Cursor must be positioned on a stack element"))
  (let* ((entry (calc-top num 'entry))
	 ww w)
    (or (equal entry calc-selection-cache-entry)
	(progn
	  (setcar entry (calc-encase-atoms (car entry)))
	  (setq calc-selection-cache-entry entry
		calc-selection-cache-num num
		calc-selection-cache-comp
		(let ((math-comp-tagged t))
		  (math-compose-expr (car entry) 0))
		calc-selection-cache-offset
		(+ (car (math-stack-value-offset calc-selection-cache-comp))
		   (length calc-left-label)
		   (if calc-line-numbering 4 0))))))
  (calc-preserve-point))

;;; The following ensures that no two subformulas will be "eq" to each other!
(defun calc-encase-atoms (x)
  (if (or (not (consp x))
	  (equal x '(float 0 0)))
      (list 'cplx x 0)
    (calc-encase-atoms-rec x)
    x))

(defun calc-encase-atoms-rec (x)
  (or (Math-primp x)
      (progn
	(if (eq (car x) 'intv)
	    (setq x (cdr x)))
	(while (setq x (cdr x))
	  (if (or (not (consp (car x)))
		  (equal (car x) '(float 0 0)))
	      (setcar x (list 'cplx (car x) 0))
	    (calc-encase-atoms-rec (car x)))))))

;; The variable math-comp-sel-tag is local to calc-find-selected-part,
;; but is used by math-comp-sel-flat-term and math-comp-add-string-sel
;; in calccomp.el, which are called (indirectly) by calc-find-selected-part.

(defun calc-find-selected-part ()
  (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
	 toppt
	 (lcount 0)
	 (spaces 0)
	 (math-comp-sel-vpos (save-excursion
			       (beginning-of-line)
			       (let ((line (point)))
				 (calc-cursor-stack-index
				  calc-selection-cache-num)
				 (setq toppt (point))
				 (while (< (point) line)
				   (forward-line 1)
				   (setq spaces (+ spaces
						   (current-indentation))
					 lcount (1+ lcount)))
				 (- lcount (math-comp-ascent
					    calc-selection-cache-comp) -1))))
	 (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset
				spaces lcount))
	 (math-comp-sel-tag nil))
    (and (>= math-comp-sel-hpos 0)
	 (> calc-selection-true-num 0)
	 (math-composition-to-string calc-selection-cache-comp 1000000))
    (nth 1 math-comp-sel-tag)))

(defun calc-change-current-selection (sub-expr)
  (or (eq sub-expr (nth 2 calc-selection-cache-entry))
      (let ((calc-prepared-composition calc-selection-cache-comp)
	    (buffer-read-only nil)
	    top)
	(calc-set-command-flag 'renum-stack)
	(setcar (nthcdr 2 calc-selection-cache-entry) sub-expr)
	(calc-cursor-stack-index calc-selection-cache-num)
	(setq top (point))
	(calc-cursor-stack-index (1- calc-selection-cache-num))
	(delete-region top (point))
	(let ((calc-selection-cache-default-entry calc-selection-cache-entry))
	  (insert (math-format-stack-value calc-selection-cache-entry)
		  "\n")))))

(defun calc-top-selected (&optional n m)
  (and calc-any-selections
       calc-use-selections
       (progn
	 (or n (setq n 1))
	 (or m (setq m 1))
	 (calc-check-stack (+ n m -1))
	 (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack))
	       (sel nil))
	   (while (>= (setq n (1- n)) 0)
	     (if (nth 2 (car top))
		 (setq sel (if sel t (nth 2 (car top)))))
	     (setq top (cdr top)))
	   sel))))

;; The variables calc-rsf-old and calc-rsf-new are local to
;; calc-replace-sub-formula, but used by calc-replace-sub-formula-rec,
;; which is called by calc-replace-sub-formula.
(defvar calc-rsf-old)
(defvar calc-rsf-new)

(defun calc-replace-sub-formula (expr calc-rsf-old calc-rsf-new)
  (setq calc-rsf-new (calc-encase-atoms calc-rsf-new))
  (calc-replace-sub-formula-rec expr))

(defun calc-replace-sub-formula-rec (expr)
  (cond ((eq expr calc-rsf-old) calc-rsf-new)
	((Math-primp expr) expr)
	(t
	 (cons (car expr)
	       (mapcar 'calc-replace-sub-formula-rec (cdr expr))))))

(defun calc-sel-error ()
  (error "Invalid operation on sub-formulas"))

(defun calc-replace-selections (n vals m)
  (if (calc-top-selected n m)
      (let ((num (length vals)))
	(calc-preserve-point)
	(cond
	 ((= n num)
	  (let* ((old (calc-top-list n m 'entry))
		 (new nil)
		 (sel nil)
		 val)
	    (while old
	      (if (nth 2 (car old))
		  (setq val (calc-encase-atoms (car vals))
			new (cons (calc-replace-sub-formula (car (car old))
							    (nth 2 (car old))
							    val)
				  new)
			sel (cons val sel))
		(setq new (cons (car vals) new)
		      sel (cons nil sel)))
	      (setq vals (cdr vals)
		    old (cdr old)))
	    (calc-pop-stack n m t)
	    (calc-push-list (nreverse new)
			    m (and calc-keep-selection (nreverse sel)))))
	 ((= num 1)
	  (let* ((old (calc-top-list n m 'entry))
		 more)
	    (while (and old (not (nth 2 (car old))))
	      (setq old (cdr old)))
	    (setq more old)
	    (while (and (setq more (cdr more)) (not (nth 2 (car more)))))
	    (and more
		 (calc-sel-error))
	    (calc-pop-stack n m t)
	    (if old
		(let ((val (calc-encase-atoms (car vals))))
		  (calc-push-list (list (calc-replace-sub-formula
					 (car (car old))
					 (nth 2 (car old))
					 val))
				  m (and calc-keep-selection (list val))))
	      (calc-push-list vals))))
	 (t (calc-sel-error))))
    (calc-pop-stack n m t)
    (calc-push-list vals m)))

(defun calc-delete-selection (n)
  (let ((entry (calc-top n 'entry)))
    (if (nth 2 entry)
	(if (eq (nth 2 entry) (car entry))
	    (progn
	      (calc-pop-stack 1 n t)
	      (calc-push-list '(0) n))
	  (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry)))
		(repl nil))
	    (calc-preserve-point)
	    (calc-pop-stack 1 n t)
	    (cond ((or (memq (car parent) '(* / %))
		       (and (eq (car parent) '^)
			    (eq (nth 2 parent) (nth 2 entry))))
		   (setq repl 1))
		  ((memq (car parent) '(vec calcFunc-min calcFunc-max)))
		  ((and (assq (car parent) calc-tweak-eqn-table)
			(= (length parent) 3))
		   (setq repl 'del))
		  (t
		   (setq repl 0)))
	    (cond
	     ((eq repl 'del)
	      (calc-push-list (list
			       (calc-normalize
				(calc-replace-sub-formula
				 (car entry)
				 parent
				 (if (eq (nth 2 entry) (nth 1 parent))
				     (nth 2 parent)
				   (nth 1 parent)))))
			      n))
	     (repl
	      (calc-push-list (list
			       (calc-normalize
				(calc-replace-sub-formula (car entry)
							  (nth 2 entry)
							  repl)))
			      n))
	     (t
	      (calc-push-list (list
			       (calc-normalize
				(calc-replace-sub-formula (car entry)
							  parent
							  (delq (nth 2 entry)
								(copy-sequence
								 parent)))))
			      n)))))
      (calc-pop-stack 1 n t))))

(defun calc-roll-down-with-selections (n m)
  (let ((vals (append (calc-top-list m 1)
		      (calc-top-list (- n m) (1+ m))))
	(sels (append (calc-top-list m 1 'sel)
		      (calc-top-list (- n m) (1+ m) 'sel))))
    (calc-pop-push-list n vals 1 sels)))

(defun calc-roll-up-with-selections (n m)
  (let ((vals (append (calc-top-list (- n m) 1)
		      (calc-top-list m (- n m -1))))
	(sels (append (calc-top-list (- n m) 1 'sel)
		      (calc-top-list m (- n m -1) 'sel))))
    (calc-pop-push-list n vals 1 sels)))

;; The variable calc-sel-reselect is local to several functions
;; which call calc-auto-selection.
(defvar calc-sel-reselect)

(defun calc-auto-selection (entry)
  (or (nth 2 entry)
      (progn
	(setq calc-sel-reselect nil)
	(calc-prepare-selection)
	(calc-grow-assoc-formula (car entry) (calc-find-selected-part)))))

(defun calc-copy-selection ()
  (interactive)
  (calc-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (entry (calc-top num 'entry)))
     (calc-push (or (calc-auto-selection entry) (car entry))))))

(defun calc-del-selection ()
  (interactive)
  (calc-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (entry (calc-top num 'entry))
	  (sel (calc-auto-selection entry)))
     (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
     (calc-delete-selection num))))

(defvar calc-selection-history nil
  "History for calc selections.")

(defun calc-enter-selection ()
  (interactive)
  (calc-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (calc-sel-reselect calc-keep-selection)
	  (entry (calc-top num 'entry))
	  (expr (car entry))
	  (sel (or (calc-auto-selection entry) expr))
	  alg)
     (let ((calc-dollar-values (list sel))
	   (calc-dollar-used 0))
       (setq alg (calc-do-alg-entry "" "Replace selection with: " nil 
                                    'calc-selection-history))
       (and alg
	    (progn
	      (setq alg (calc-encase-atoms (car alg)))
	      (calc-pop-push-record-list 1 "repl"
					 (list (calc-replace-sub-formula
						expr sel alg))
					 num
					 (list (and calc-sel-reselect alg))))))
     (calc-handle-whys))))

(defun calc-edit-selection ()
  (interactive)
  (calc-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (calc-sel-reselect calc-keep-selection)
	  (entry (calc-top num 'entry))
	  (expr (car entry))
	  (sel (or (calc-auto-selection entry) expr))
	  alg)
     (let ((str (math-showing-full-precision
		 (math-format-nice-expr sel (frame-width)))))
       (calc-edit-mode (list 'calc-finish-selection-edit
			     num (list 'quote sel) calc-sel-reselect))
       (insert str "\n"))))
  (calc-show-edit-buffer))

(defvar calc-original-buffer)

;; The variable calc-edit-disp-trail is local to calc-edit-finish,
;; in calc-yank.el.
(defvar calc-edit-disp-trail)
(defvar calc-edit-top)

(defun calc-finish-selection-edit (num sel reselect)
  (let ((buf (current-buffer))
	(str (buffer-substring calc-edit-top (point-max)))
	(start (point)))
    (switch-to-buffer calc-original-buffer)
    (let ((val (math-read-expr str)))
      (if (eq (car-safe val) 'error)
	  (progn
	    (switch-to-buffer buf)
	    (goto-char (+ start (nth 1 val)))
	    (error (nth 2 val))))
      (calc-wrapper
       (calc-preserve-point)
       (if calc-edit-disp-trail
	   (calc-trail-display 1 t))
       (setq val (calc-encase-atoms (calc-normalize val)))
       (let ((expr (calc-top num 'full)))
	 (if (calc-find-sub-formula expr sel)
	     (calc-pop-push-record-list 1 "edit"
					(list (calc-replace-sub-formula
					       expr sel val))
					num
					(list (and reselect val)))
	   (calc-push val)
	   (error "Original selection has been lost")))))))

(defun calc-sel-evaluate (arg)
  (interactive "p")
  (calc-slow-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (calc-sel-reselect calc-keep-selection)
	  (entry (calc-top num 'entry))
	  (sel (or (calc-auto-selection entry) (car entry))))
     (calc-with-default-simplification
      (let ((math-simplify-only nil))
	(calc-modify-simplify-mode arg)
	(let ((val (calc-encase-atoms (calc-normalize sel))))
	  (calc-pop-push-record-list 1 "jsmp"
				     (list (calc-replace-sub-formula
					    (car entry) sel val))
				     num
				     (list (and calc-sel-reselect val))))))
     (calc-handle-whys))))

(defun calc-sel-expand-formula (arg)
  (interactive "p")
  (calc-slow-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (calc-sel-reselect calc-keep-selection)
	  (entry (calc-top num 'entry))
	  (sel (or (calc-auto-selection entry) (car entry))))
     (calc-with-default-simplification
      (let ((math-simplify-only nil))
	(calc-modify-simplify-mode arg)
	(let* ((math-expand-formulas (> arg 0))
	       (val (calc-normalize sel))
	       top)
	  (and (<= arg 0)
	       (setq top (math-expand-formula val))
	       (setq val (calc-normalize top)))
	  (setq val (calc-encase-atoms val))
	  (calc-pop-push-record-list 1 "jexf"
				     (list (calc-replace-sub-formula
					    (car entry) sel val))
				     num
				     (list (and calc-sel-reselect val))))))
     (calc-handle-whys))))

(defun calc-sel-mult-both-sides (no-simp &optional divide)
  (interactive "P")
  (calc-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (calc-sel-reselect calc-keep-selection)
	  (entry (calc-top num 'entry))
	  (expr (car entry))
	  (sel (or (calc-auto-selection entry) expr))
	  (func (car-safe sel))
	  alg lhs rhs)
     (setq alg (calc-with-default-simplification
		(car (calc-do-alg-entry ""
					(if divide
					    "Divide both sides by: "
					  "Multiply both sides by: ")
                                        nil 'calc-selection-history))))
     (and alg
	  (progn
	    (if (and (or (eq func '/)
			 (assq func calc-tweak-eqn-table))
		     (= (length sel) 3))
		(progn
		  (or (memq func '(/ calcFunc-eq calcFunc-neq))
		      (if (math-known-nonposp alg)
			  (progn
			    (setq func (nth 1 (assq func
						    calc-tweak-eqn-table)))
			    (or (math-known-negp alg)
				(message "Assuming this factor is nonzero")))
			(or (math-known-posp alg)
			    (if (math-known-nonnegp alg)
				(message "Assuming this factor is nonzero")
			      (message "Assuming this factor is positive")))))
		  (setq lhs (list (if divide '/ '*) (nth 1 sel) alg)
			rhs (list (if divide '/ '*) (nth 2 sel) alg))
		  (or no-simp
		      (progn
			(setq lhs (math-simplify lhs)
			      rhs (math-simplify rhs))
			(and (eq func '/)
			     (or (Math-equal (nth 1 sel) 1)
				 (Math-equal (nth 1 sel) -1)
				 (and (memq (car-safe (nth 2 sel)) '(+ -))
				      (memq (car-safe alg) '(+ -))))
			     (setq rhs (math-expand-term rhs)))))
		  (setq alg (calc-encase-atoms
			     (calc-normalize (list func lhs rhs)))))
	      (setq rhs (list (if divide '* '/) sel alg))
	      (or no-simp
		  (setq rhs (math-simplify rhs)))
	      (setq alg (calc-encase-atoms
			 (calc-normalize (if divide
					     (list '/ rhs alg)
					   (list '* alg rhs))))))
	    (calc-pop-push-record-list 1 (if divide "div" "mult")
				       (list (calc-replace-sub-formula
					      expr sel alg))
				       num
				       (list (and calc-sel-reselect alg)))))
     (calc-handle-whys))))

(defun calc-sel-div-both-sides (no-simp)
  (interactive "P")
  (calc-sel-mult-both-sides no-simp t))

(defun calc-sel-add-both-sides (no-simp &optional subtract)
  (interactive "P")
  (calc-wrapper
   (calc-preserve-point)
   (let* ((num (max 1 (calc-locate-cursor-element (point))))
	  (calc-sel-reselect calc-keep-selection)
	  (entry (calc-top num 'entry))
	  (expr (car entry))
	  (sel (or (calc-auto-selection entry) expr))
	  (func (car-safe sel))
	  alg lhs rhs)
     (setq alg (calc-with-default-simplification
		(car (calc-do-alg-entry ""
					(if subtract
					    "Subtract from both sides: "
					  "Add to both sides: ")
                                        nil 'calc-selection-history))))
     (and alg
	  (progn
	    (if (and (assq func calc-tweak-eqn-table)
		     (= (length sel) 3))
		(progn
		  (setq lhs (list (if subtract '- '+) (nth 1 sel) alg)
			rhs (list (if subtract '- '+) (nth 2 sel) alg))
		  (or no-simp
		      (setq lhs (math-simplify lhs)
			    rhs (math-simplify rhs)))
		  (setq alg (calc-encase-atoms
			     (calc-normalize (list func lhs rhs)))))
	      (setq rhs (list (if subtract '+ '-) sel alg))
	      (or no-simp
		  (setq rhs (math-simplify rhs)))
	      (setq alg (calc-encase-atoms
			 (calc-normalize (list (if subtract '- '+) alg rhs)))))
	    (calc-pop-push-record-list 1 (if subtract "sub" "add")
				       (list (calc-replace-sub-formula
					      expr sel alg))
				       num
				       (list (and calc-sel-reselect alg)))))
     (calc-handle-whys))))

(defun calc-sel-sub-both-sides (no-simp)
  (interactive "P")
  (calc-sel-add-both-sides no-simp t))

(provide 'calc-sel)

;; arch-tag: e5169792-777d-428f-bff5-acca66813fa2
;;; calc-sel.el ends here