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