lisp/calc/calc-sel.el

   1 ;;; calc-sel.el --- data selection functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: David Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: Colin Walters <walters@debian.org>
   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
  25 ;;; Commentary:
  26
  27 ;;; Code:
  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
  39 (defvar calc-keep-selection t)
  40
  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))
  62               (car entry))))))))
  63
  64 (defun calc-select-once (num)
  65   (interactive "P")
  66   (calc-select-here num t))
  67
  68 (defun calc-select-here-maybe (num)
  69   (interactive "P")
  70   (calc-select-here num nil t))
  71
  72 (defun calc-select-once-maybe (num)
  73   (interactive "P")
  74   (calc-select-here num t t))
  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)))
  94         (car entry))))))
  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))
 107        (calc-select-here num)))))
 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))))
 129              sel))))))
 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)
 141        (error "%d is not a valid sub-formula index" num)))))
 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))
 151            (nth num expr)))))
 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)
 163              (nth 2 expr)))))
 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))
 200            (calc-select-part num)))))))
 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)))))
 245              (calc-select-part (- len num)))))))))
 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
 256                 (if (eq res t) expr res))))))
 257
 258
 259 (defun calc-find-assoc-parent-formula (expr part)
 260   (calc-grow-assoc-formula expr (calc-find-parent-formula expr part)))
 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)
 273     part))
 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)))
 283            (and expr num)))))
 284
 285 (defun calc-unselect (num)
 286   (interactive "P")
 287   (calc-wrapper
 288    (calc-prepare-selection num)
 289    (calc-change-current-selection nil)))
 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))))
 302    (calc-clear-command-flag 'position-point)))
 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"
 326               "Displaying all but selected part of formulas"))))
 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))
 334         (calc-set-command-flag 'position-point))))
 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"
 346               "Selections of sub-formulas have no effect"))))
 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"
 357               "Selection treats a+b+c as (a+b)+c"))))
 358
 359 (defvar calc-selection-cache-entry nil)
 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))))))
 381   (calc-preserve-point))
 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)
 389     x))
 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))
 400             (calc-encase-atoms-rec (car x)))))))
 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))
 426     (nth 1 math-comp-sel-tag)))
 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)
 441                   "\n")))))
 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)))
 456            sel))))
 457
 458 (defun calc-replace-sub-formula (expr old new)
 459   (setq new (calc-encase-atoms new))
 460   (calc-replace-sub-formula-rec expr))
 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)
 467                (mapcar 'calc-replace-sub-formula-rec (cdr expr))))))
 468
 469 (defun calc-sel-error ()
 470   (error "Illegal operation on sub-formulas"))
 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)
 517     (calc-push-list vals m)))
 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)))))
 567       (calc-pop-stack 1 n t))))
 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))))
 574     (calc-pop-push-list n vals 1 sels)))
 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))))
 581     (calc-pop-push-list n vals 1 sels)))
 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)
 588         (calc-grow-assoc-formula (car entry) (calc-find-selected-part)))))
 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)))
 596      (calc-push (or (calc-auto-selection entry) (car entry))))))
 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))
 606      (calc-delete-selection num))))
 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))))))
 629      (calc-handle-whys))))
 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
 642                  (math-format-nice-expr sel (frame-width)))))
 643        (calc-edit-mode (list 'calc-finish-selection-edit
 644                              num (list 'quote sel) reselect))
 645        (insert str "\n"))))
 646   (calc-show-edit-buffer))
 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)
 672            (error "Original selection has been lost")))))))
 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))))))
 691      (calc-handle-whys))))
 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))))))
 716      (calc-handle-whys))))
 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)))))
 777      (calc-handle-whys))))
 778
 779 (defun calc-sel-div-both-sides (no-simp)
 780   (interactive "P")
 781   (calc-sel-mult-both-sides no-simp t))
 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)))))
 821      (calc-handle-whys))))
 822
 823 (defun calc-sel-sub-both-sides (no-simp)
 824   (interactive "P")
 825   (calc-sel-add-both-sides no-simp t))
 826
 827 ;;; calc-sel.el ends here