lisp/calc/calc-sel.el

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