lisp/calc/calc-sel.el

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