lisp/calc/calc-sel.el

   1 ;;; calc-sel.el --- data selection functions for Calc
   2
   3 ;; Copyright (C) 1990-1993, 2001-2018 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 <https://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-event ?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   ;; (if (or (< num 1) (> num (calc-stack-size)))
 382   ;;     (error "Cursor must be positioned on a stack element"))
 383   (let* ((entry (calc-top num 'entry))
 384          ww w)
 385     (or (equal entry calc-selection-cache-entry)
 386         (progn
 387           (setcar entry (calc-encase-atoms (car entry)))
 388           (setq calc-selection-cache-entry entry
 389                 calc-selection-cache-num num
 390                 calc-selection-cache-comp
 391                 (let ((math-comp-tagged t))
 392                   (math-compose-expr (car entry) 0))
 393                 calc-selection-cache-offset
 394                 (+ (car (math-stack-value-offset calc-selection-cache-comp))
 395                    (length calc-left-label)
 396                    (if calc-line-numbering 4 0))))))
 397   (calc-preserve-point))
 398
 399 ;;; The following ensures that no two subformulas will be "eq" to each other!
 400 (defun calc-encase-atoms (x)
 401   (if (or (not (consp x))
 402           (equal x '(float 0 0)))
 403       (list 'cplx x 0)
 404     (calc-encase-atoms-rec x)
 405     x))
 406
 407 (defun calc-encase-atoms-rec (x)
 408   (or (Math-primp x)
 409       (progn
 410         (if (eq (car x) 'intv)
 411             (setq x (cdr x)))
 412         (while (setq x (cdr x))
 413           (if (or (not (consp (car x)))
 414                   (equal (car x) '(float 0 0)))
 415               (setcar x (list 'cplx (car x) 0))
 416             (calc-encase-atoms-rec (car x)))))))
 417
 418 ;; The variable math-comp-sel-tag is local to calc-find-selected-part,
 419 ;; but is used by math-comp-sel-flat-term and math-comp-add-string-sel
 420 ;; in calccomp.el, which are called (indirectly) by calc-find-selected-part.
 421
 422 (defun calc-find-selected-part ()
 423   (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
 424          toppt
 425          (lcount 0)
 426          (spaces 0)
 427          (math-comp-sel-vpos (save-excursion
 428                                (beginning-of-line)
 429                                (let ((line (point)))
 430                                  (calc-cursor-stack-index
 431                                   calc-selection-cache-num)
 432                                  (setq toppt (point))
 433                                  (while (< (point) line)
 434                                    (forward-line 1)
 435                                    (setq spaces (+ spaces
 436                                                    (current-indentation))
 437                                          lcount (1+ lcount)))
 438                                  (- lcount (math-comp-ascent
 439                                             calc-selection-cache-comp) -1))))
 440          (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset
 441                                 spaces lcount))
 442          (math-comp-sel-tag nil))
 443     (and (>= math-comp-sel-hpos 0)
 444          (> calc-selection-true-num 0)
 445          (math-composition-to-string calc-selection-cache-comp 1000000))
 446     (nth 1 math-comp-sel-tag)))
 447
 448 (defun calc-change-current-selection (sub-expr)
 449   (or (eq sub-expr (nth 2 calc-selection-cache-entry))
 450       (let ((calc-prepared-composition calc-selection-cache-comp)
 451             (buffer-read-only nil)
 452             top)
 453         (calc-set-command-flag 'renum-stack)
 454         (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr)
 455         (calc-cursor-stack-index calc-selection-cache-num)
 456         (setq top (point))
 457         (calc-cursor-stack-index (1- calc-selection-cache-num))
 458         (delete-region top (point))
 459         (let ((calc-selection-cache-default-entry calc-selection-cache-entry))
 460           (insert (math-format-stack-value calc-selection-cache-entry)
 461                   "\n")))))
 462
 463 (defun calc-top-selected (&optional n m)
 464   (and calc-any-selections
 465        calc-use-selections
 466        (progn
 467          (or n (setq n 1))
 468          (or m (setq m 1))
 469          (calc-check-stack (+ n m -1))
 470          (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack))
 471                (sel nil))
 472            (while (>= (setq n (1- n)) 0)
 473              (if (nth 2 (car top))
 474                  (setq sel (if sel t (nth 2 (car top)))))
 475              (setq top (cdr top)))
 476            sel))))
 477
 478 ;; The variables calc-rsf-old and calc-rsf-new are local to
 479 ;; calc-replace-sub-formula, but used by calc-replace-sub-formula-rec,
 480 ;; which is called by calc-replace-sub-formula.
 481 (defvar calc-rsf-old)
 482 (defvar calc-rsf-new)
 483
 484 (defun calc-replace-sub-formula (expr calc-rsf-old calc-rsf-new)
 485   (setq calc-rsf-new (calc-encase-atoms calc-rsf-new))
 486   (calc-replace-sub-formula-rec expr))
 487
 488 (defun calc-replace-sub-formula-rec (expr)
 489   (cond ((eq expr calc-rsf-old) calc-rsf-new)
 490         ((Math-primp expr) expr)
 491         (t
 492          (cons (car expr)
 493                (mapcar 'calc-replace-sub-formula-rec (cdr expr))))))
 494
 495 (defun calc-sel-error ()
 496   (error "Invalid operation on sub-formulas"))
 497
 498 (defun calc-replace-selections (n vals m)
 499   (if (calc-top-selected n m)
 500       (let ((num (length vals)))
 501         (calc-preserve-point)
 502         (cond
 503          ((= n num)
 504           (let* ((old (calc-top-list n m 'entry))
 505                  (new nil)
 506                  (sel nil)
 507                  val)
 508             (while old
 509               (if (nth 2 (car old))
 510                   (setq val (calc-encase-atoms (car vals))
 511                         new (cons (calc-replace-sub-formula (car (car old))
 512                                                             (nth 2 (car old))
 513                                                             val)
 514                                   new)
 515                         sel (cons val sel))
 516                 (setq new (cons (car vals) new)
 517                       sel (cons nil sel)))
 518               (setq vals (cdr vals)
 519                     old (cdr old)))
 520             (calc-pop-stack n m t)
 521             (calc-push-list (nreverse new)
 522                             m (and calc-keep-selection (nreverse sel)))))
 523          ((= num 1)
 524           (let* ((old (calc-top-list n m 'entry))
 525                  more)
 526             (while (and old (not (nth 2 (car old))))
 527               (setq old (cdr old)))
 528             (setq more old)
 529             (while (and (setq more (cdr more)) (not (nth 2 (car more)))))
 530             (and more
 531                  (calc-sel-error))
 532             (calc-pop-stack n m t)
 533             (if old
 534                 (let ((val (calc-encase-atoms (car vals))))
 535                   (calc-push-list (list (calc-replace-sub-formula
 536                                          (car (car old))
 537                                          (nth 2 (car old))
 538                                          val))
 539                                   m (and calc-keep-selection (list val))))
 540               (calc-push-list vals))))
 541          (t (calc-sel-error))))
 542     (calc-pop-stack n m t)
 543     (calc-push-list vals m)))
 544
 545 (defun calc-delete-selection (n)
 546   (let ((entry (calc-top n 'entry)))
 547     (if (nth 2 entry)
 548         (if (eq (nth 2 entry) (car entry))
 549             (progn
 550               (calc-pop-stack 1 n t)
 551               (calc-push-list '(0) n))
 552           (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry)))
 553                 (repl nil))
 554             (calc-preserve-point)
 555             (calc-pop-stack 1 n t)
 556             (cond ((or (memq (car parent) '(* / %))
 557                        (and (eq (car parent) '^)
 558                             (eq (nth 2 parent) (nth 2 entry))))
 559                    (setq repl 1))
 560                   ((memq (car parent) '(vec calcFunc-min calcFunc-max)))
 561                   ((and (assq (car parent) calc-tweak-eqn-table)
 562                         (= (length parent) 3))
 563                    (setq repl 'del))
 564                   (t
 565                    (setq repl 0)))
 566             (cond
 567              ((eq repl 'del)
 568               (calc-push-list (list
 569                                (calc-normalize
 570                                 (calc-replace-sub-formula
 571                                  (car entry)
 572                                  parent
 573                                  (if (eq (nth 2 entry) (nth 1 parent))
 574                                      (nth 2 parent)
 575                                    (nth 1 parent)))))
 576                               n))
 577              (repl
 578               (calc-push-list (list
 579                                (calc-normalize
 580                                 (calc-replace-sub-formula (car entry)
 581                                                           (nth 2 entry)
 582                                                           repl)))
 583                               n))
 584              (t
 585               (calc-push-list (list
 586                                (calc-normalize
 587                                 (calc-replace-sub-formula (car entry)
 588                                                           parent
 589                                                           (delq (nth 2 entry)
 590                                                                 (copy-sequence
 591                                                                  parent)))))
 592                               n)))))
 593       (calc-pop-stack 1 n t))))
 594
 595 (defun calc-roll-down-with-selections (n m)
 596   (let ((vals (append (calc-top-list m 1)
 597                       (calc-top-list (- n m) (1+ m))))
 598         (sels (append (calc-top-list m 1 'sel)
 599                       (calc-top-list (- n m) (1+ m) 'sel))))
 600     (calc-pop-push-list n vals 1 sels)))
 601
 602 (defun calc-roll-up-with-selections (n m)
 603   (let ((vals (append (calc-top-list (- n m) 1)
 604                       (calc-top-list m (- n m -1))))
 605         (sels (append (calc-top-list (- n m) 1 'sel)
 606                       (calc-top-list m (- n m -1) 'sel))))
 607     (calc-pop-push-list n vals 1 sels)))
 608
 609 ;; The variable calc-sel-reselect is local to several functions
 610 ;; which call calc-auto-selection.
 611 (defvar calc-sel-reselect)
 612
 613 (defun calc-auto-selection (entry)
 614   (or (nth 2 entry)
 615       (progn
 616         (setq calc-sel-reselect nil)
 617         (calc-prepare-selection)
 618         (calc-grow-assoc-formula (car entry) (calc-find-selected-part)))))
 619
 620 (defun calc-copy-selection ()
 621   (interactive)
 622   (calc-wrapper
 623    (calc-preserve-point)
 624    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 625           (entry (calc-top num 'entry)))
 626      (calc-push (or (calc-auto-selection entry) (car entry))))))
 627
 628 (defun calc-del-selection ()
 629   (interactive)
 630   (calc-wrapper
 631    (calc-preserve-point)
 632    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 633           (entry (calc-top num 'entry))
 634           (sel (calc-auto-selection entry)))
 635      (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
 636      (calc-delete-selection num))))
 637
 638 (defvar calc-selection-history nil
 639   "History for calc selections.")
 640
 641 (defun calc-enter-selection ()
 642   (interactive)
 643   (calc-wrapper
 644    (calc-preserve-point)
 645    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 646           (calc-sel-reselect calc-keep-selection)
 647           (entry (calc-top num 'entry))
 648           (expr (car entry))
 649           (sel (or (calc-auto-selection entry) expr))
 650           alg)
 651      (let ((calc-dollar-values (list sel))
 652            (calc-dollar-used 0))
 653        (setq alg (calc-do-alg-entry "" "Replace selection with: " nil
 654                                     'calc-selection-history))
 655        (and alg
 656             (progn
 657               (setq alg (calc-encase-atoms (car alg)))
 658               (calc-pop-push-record-list 1 "repl"
 659                                          (list (calc-replace-sub-formula
 660                                                 expr sel alg))
 661                                          num
 662                                          (list (and calc-sel-reselect alg))))))
 663      (calc-handle-whys))))
 664
 665 (defun calc-edit-selection ()
 666   (interactive)
 667   (calc-wrapper
 668    (calc-preserve-point)
 669    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 670           (calc-sel-reselect calc-keep-selection)
 671           (entry (calc-top num 'entry))
 672           (expr (car entry))
 673           (sel (or (calc-auto-selection entry) expr))
 674           alg)
 675      (let ((str (math-showing-full-precision
 676                  (math-format-nice-expr sel (frame-width)))))
 677        (calc-edit-mode (list 'calc-finish-selection-edit
 678                              num (list 'quote sel) calc-sel-reselect))
 679        (insert str "\n"))))
 680   (calc-show-edit-buffer))
 681
 682 (defvar calc-original-buffer)
 683
 684 ;; The variable calc-edit-disp-trail is local to calc-edit-finish,
 685 ;; in calc-yank.el.
 686 (defvar calc-edit-disp-trail)
 687 (defvar calc-edit-top)
 688
 689 (defun calc-finish-selection-edit (num sel reselect)
 690   (let ((buf (current-buffer))
 691         (str (buffer-substring calc-edit-top (point-max)))
 692         (start (point)))
 693     (switch-to-buffer calc-original-buffer)
 694     (let ((val (math-read-expr str)))
 695       (if (eq (car-safe val) 'error)
 696           (progn
 697             (switch-to-buffer buf)
 698             (goto-char (+ start (nth 1 val)))
 699             (error (nth 2 val))))
 700       (calc-wrapper
 701        (calc-preserve-point)
 702        (if calc-edit-disp-trail
 703            (calc-trail-display 1 t))
 704        (setq val (calc-encase-atoms (calc-normalize val)))
 705        (let ((expr (calc-top num 'full)))
 706          (if (calc-find-sub-formula expr sel)
 707              (calc-pop-push-record-list 1 "edit"
 708                                         (list (calc-replace-sub-formula
 709                                                expr sel val))
 710                                         num
 711                                         (list (and reselect val)))
 712            (calc-push val)
 713            (error "Original selection has been lost")))))))
 714
 715 (defun calc-sel-evaluate (arg)
 716   (interactive "p")
 717   (calc-slow-wrapper
 718    (calc-preserve-point)
 719    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 720           (calc-sel-reselect calc-keep-selection)
 721           (entry (calc-top num 'entry))
 722           (sel (or (calc-auto-selection entry) (car entry))))
 723      (calc-with-default-simplification
 724       (let ((math-simplify-only nil))
 725         (calc-modify-simplify-mode arg)
 726         (let ((val (calc-encase-atoms (calc-normalize sel))))
 727           (calc-pop-push-record-list 1 "jsmp"
 728                                      (list (calc-replace-sub-formula
 729                                             (car entry) sel val))
 730                                      num
 731                                      (list (and calc-sel-reselect val))))))
 732      (calc-handle-whys))))
 733
 734 (defun calc-sel-expand-formula (arg)
 735   (interactive "p")
 736   (calc-slow-wrapper
 737    (calc-preserve-point)
 738    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 739           (calc-sel-reselect calc-keep-selection)
 740           (entry (calc-top num 'entry))
 741           (sel (or (calc-auto-selection entry) (car entry))))
 742      (calc-with-default-simplification
 743       (let ((math-simplify-only nil))
 744         (calc-modify-simplify-mode arg)
 745         (let* ((math-expand-formulas (> arg 0))
 746                (val (calc-normalize sel))
 747                top)
 748           (and (<= arg 0)
 749                (setq top (math-expand-formula val))
 750                (setq val (calc-normalize top)))
 751           (setq val (calc-encase-atoms val))
 752           (calc-pop-push-record-list 1 "jexf"
 753                                      (list (calc-replace-sub-formula
 754                                             (car entry) sel val))
 755                                      num
 756                                      (list (and calc-sel-reselect val))))))
 757      (calc-handle-whys))))
 758
 759 (defun calc-sel-mult-both-sides (arg &optional divide)
 760   (interactive "P")
 761   (calc-wrapper
 762    (calc-preserve-point)
 763    (let* ((no-simp (consp arg))
 764           (num (max 1 (calc-locate-cursor-element (point))))
 765           (calc-sel-reselect calc-keep-selection)
 766           (entry (calc-top num 'entry))
 767           (expr (car entry))
 768           (sel (or (calc-auto-selection entry) expr))
 769           (func (car-safe sel))
 770           alg lhs rhs)
 771      (setq alg (calc-with-default-simplification
 772                 (car (calc-do-alg-entry ""
 773                                         (if divide
 774                                             "Divide both sides by: "
 775                                           "Multiply both sides by: ")
 776                                         nil 'calc-selection-history))))
 777      (and alg
 778           (progn
 779             (if (and (or (eq func '/)
 780                          (assq func calc-tweak-eqn-table))
 781                      (= (length sel) 3))
 782                 (progn
 783                   (or (memq func '(/ calcFunc-eq calcFunc-neq))
 784                       (if (math-known-nonposp alg)
 785                           (progn
 786                             (setq func (nth 1 (assq func
 787                                                     calc-tweak-eqn-table)))
 788                             (or (math-known-negp alg)
 789                                 (message "Assuming this factor is nonzero")))
 790                         (or (math-known-posp alg)
 791                             (if (math-known-nonnegp alg)
 792                                 (message "Assuming this factor is nonzero")
 793                               (message "Assuming this factor is positive")))))
 794                   (setq lhs (list (if divide '/ '*) (nth 1 sel) alg)
 795                         rhs (list (if divide '/ '*) (nth 2 sel) alg))
 796                   (or no-simp
 797                       (progn
 798                         (setq lhs (math-simplify lhs)
 799                               rhs (math-simplify rhs))
 800                         (and (eq func '/)
 801                              (or (Math-equal (nth 1 sel) 1)
 802                                  (Math-equal (nth 1 sel) -1))
 803 ;                                (and (memq (car-safe (nth 2 sel)) '(+ -))
 804 ;                                     (memq (car-safe alg) '(+ -))))
 805                              (unless arg
 806                                (setq rhs (math-expand-term rhs))))))
 807                   (if (and arg (not no-simp))
 808                       (setq rhs (math-simplify
 809                                  (calcFunc-expand rhs (unless (= arg 0) arg)))))
 810                   (setq alg (calc-encase-atoms
 811                              (calc-normalize (list func lhs rhs)))))
 812               (setq rhs (list (if divide '* '/) sel alg))
 813               (or no-simp
 814                   (setq rhs (math-simplify rhs)))
 815               (setq alg (calc-encase-atoms
 816                          (calc-normalize (if divide
 817                                              (list '/ rhs alg)
 818                                            (list '* alg rhs))))))
 819             (calc-pop-push-record-list 1 (if divide "div" "mult")
 820                                        (list (calc-replace-sub-formula
 821                                               expr sel alg))
 822                                        num
 823                                        (list (and calc-sel-reselect alg)))))
 824      (calc-handle-whys))))
 825
 826 (defun calc-sel-div-both-sides (no-simp)
 827   (interactive "P")
 828   (calc-sel-mult-both-sides no-simp t))
 829
 830 (defun calc-sel-add-both-sides (no-simp &optional subtract)
 831   (interactive "P")
 832   (calc-wrapper
 833    (calc-preserve-point)
 834    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 835           (calc-sel-reselect calc-keep-selection)
 836           (entry (calc-top num 'entry))
 837           (expr (car entry))
 838           (sel (or (calc-auto-selection entry) expr))
 839           (func (car-safe sel))
 840           alg lhs rhs)
 841      (setq alg (calc-with-default-simplification
 842                 (car (calc-do-alg-entry ""
 843                                         (if subtract
 844                                             "Subtract from both sides: "
 845                                           "Add to both sides: ")
 846                                         nil 'calc-selection-history))))
 847      (and alg
 848           (progn
 849             (if (and (assq func calc-tweak-eqn-table)
 850                      (= (length sel) 3))
 851                 (progn
 852                   (setq lhs (list (if subtract '- '+) (nth 1 sel) alg)
 853                         rhs (list (if subtract '- '+) (nth 2 sel) alg))
 854                   (or no-simp
 855                       (setq lhs (math-simplify lhs)
 856                             rhs (math-simplify rhs)))
 857                   (setq alg (calc-encase-atoms
 858                              (calc-normalize (list func lhs rhs)))))
 859               (setq rhs (list (if subtract '+ '-) sel alg))
 860               (or no-simp
 861                   (setq rhs (math-simplify rhs)))
 862               (setq alg (calc-encase-atoms
 863                          (calc-normalize (list (if subtract '- '+) alg rhs)))))
 864             (calc-pop-push-record-list 1 (if subtract "sub" "add")
 865                                        (list (calc-replace-sub-formula
 866                                               expr sel alg))
 867                                        num
 868                                        (list (and calc-sel-reselect alg)))))
 869      (calc-handle-whys))))
 870
 871 (defun calc-sel-sub-both-sides (no-simp)
 872   (interactive "P")
 873   (calc-sel-add-both-sides no-simp t))
 874
 875 (provide 'calc-sel)
 876
 877 ;;; calc-sel.el ends here