lisp/calc/calc-sel.el

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