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