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