lisp/calc/calc-sel.el

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