lisp/calc/calc-sel.el

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