code.delx.au - gnu-emacs/blob - lisp/calc/calc-sel.el

   1 ;; Calculator for GNU Emacs, part II [calc-sel.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-sel () nil)
  30
  31
  32 ;;; Selection commands.
  33
  34 (defun calc-select-here (num &optional once keep)
  35   (interactive "P")
  36   (calc-wrapper
  37    (calc-prepare-selection)
  38    (let ((found (calc-find-selected-part))
  39          (entry calc-selection-cache-entry))
  40      (or (and keep (nth 2 entry))
  41          (progn
  42            (if once (progn
  43                       (setq calc-keep-selection nil)
  44                       (message "(Selection will apply to next command only)")))
  45            (calc-change-current-selection
  46             (if found
  47                 (if (and num (> (setq num (prefix-numeric-value num)) 0))
  48                     (progn
  49                       (while (and (>= (setq num (1- num)) 0)
  50                                   (not (eq found (car entry))))
  51                         (setq found (calc-find-assoc-parent-formula
  52                                      (car entry) found)))
  53                       found)
  54                   (calc-grow-assoc-formula (car entry) found))
  55               (car entry)))))))
  56 )
  57
  58 (defun calc-select-once (num)
  59   (interactive "P")
  60   (calc-select-here num t)
  61 )
  62
  63 (defun calc-select-here-maybe (num)
  64   (interactive "P")
  65   (calc-select-here num nil t)
  66 )
  67
  68 (defun calc-select-once-maybe (num)
  69   (interactive "P")
  70   (calc-select-here num t t)
  71 )
  72
  73 (defun calc-select-additional ()
  74   (interactive)
  75   (calc-wrapper
  76    (let (calc-keep-selection)
  77      (calc-prepare-selection))
  78    (let ((found (calc-find-selected-part))
  79          (entry calc-selection-cache-entry))
  80      (calc-change-current-selection
  81       (if found
  82           (let ((sel (nth 2 entry)))
  83             (if sel
  84                 (progn
  85                   (while (not (or (eq sel (car entry))
  86                                   (calc-find-sub-formula sel found)))
  87                     (setq sel (calc-find-assoc-parent-formula
  88                                (car entry) sel)))
  89                   sel)
  90               (calc-grow-assoc-formula (car entry) found)))
  91         (car entry)))))
  92 )
  93
  94 (defun calc-select-more (num)
  95   (interactive "P")
  96   (calc-wrapper
  97    (calc-prepare-selection)
  98    (let ((entry calc-selection-cache-entry))
  99      (if (nth 2 entry)
 100          (let ((sel (nth 2 entry)))
 101            (while (and (not (eq sel (car entry)))
 102                        (>= (setq num (1- (prefix-numeric-value num))) 0))
 103              (setq sel (calc-find-assoc-parent-formula (car entry) sel)))
 104            (calc-change-current-selection sel))
 105        (calc-select-here num))))
 106 )
 107
 108 (defun calc-select-less (num)
 109   (interactive "p")
 110   (calc-wrapper
 111    (calc-prepare-selection)
 112    (let ((found (calc-find-selected-part))
 113          (entry calc-selection-cache-entry))
 114      (calc-change-current-selection
 115       (and found
 116            (let ((sel (nth 2 entry))
 117                  old index op)
 118              (while (and sel
 119                          (not (eq sel found))
 120                          (>= (setq num (1- num)) 0))
 121                (setq old sel
 122                      index (calc-find-sub-formula sel found))
 123                (and (setq sel (and index (nth index old)))
 124                     calc-assoc-selections
 125                     (setq op (assq (car-safe sel) calc-assoc-ops))
 126                     (memq (car old) (nth index op))
 127                     (setq num (1+ num))))
 128              sel)))))
 129 )
 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
 144 (defun calc-find-nth-part (expr num)
 145   (if (and calc-assoc-selections
 146            (assq (car-safe expr) calc-assoc-ops))
 147       (let (op)
 148         (calc-find-nth-part-rec expr))
 149     (if (eq (car-safe expr) 'intv)
 150         (and (>= num 1) (<= num 2) (nth (1+ num) expr))
 151       (and (not (Math-primp expr)) (>= num 1) (< num (length expr))
 152            (nth num expr))))
 153 )
 154
 155 (defun calc-find-nth-part-rec (expr)   ; uses num, op
 156   (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
 157                (memq (car expr) (nth 1 op)))
 158           (calc-find-nth-part-rec (nth 1 expr))
 159         (and (= (setq num (1- num)) 0)
 160              (nth 1 expr)))
 161       (if (and (setq op (assq (car-safe (nth 2 expr)) calc-assoc-ops))
 162                (memq (car expr) (nth 2 op)))
 163           (calc-find-nth-part-rec (nth 2 expr))
 164         (and (= (setq num (1- num)) 0)
 165              (nth 2 expr))))
 166 )
 167
 168 (defun calc-select-next (num)
 169   (interactive "p")
 170   (if (< num 0)
 171       (calc-select-previous (- num))
 172     (calc-wrapper
 173      (calc-prepare-selection)
 174      (let* ((entry calc-selection-cache-entry)
 175             (sel (nth 2 entry)))
 176        (if sel
 177            (progn
 178              (while (>= (setq num (1- num)) 0)
 179                (let* ((parent (calc-find-parent-formula (car entry) sel))
 180                      (p parent)
 181                      op)
 182                  (and (eq p t) (setq p nil))
 183                  (while (and (setq p (cdr p))
 184                              (not (eq (car p) sel))))
 185                  (if (cdr p)
 186                      (setq sel (or (and calc-assoc-selections
 187                                         (setq op (assq (car-safe (nth 1 p))
 188                                                        calc-assoc-ops))
 189                                         (memq (car parent) (nth 2 op))
 190                                         (nth 1 (nth 1 p)))
 191                                    (nth 1 p)))
 192                    (if (and calc-assoc-selections
 193                             (setq op (assq (car-safe parent) calc-assoc-ops))
 194                             (consp (setq p (calc-find-parent-formula
 195                                             (car entry) parent)))
 196                             (eq (nth 1 p) parent)
 197                             (memq (car p) (nth 1 op)))
 198                        (setq sel (nth 2 p))
 199                      (error "No \"next\" sub-formula")))))
 200              (calc-change-current-selection sel))
 201          (if (Math-primp (car entry))
 202              (calc-change-current-selection (car entry))
 203            (calc-select-part num))))))
 204 )
 205
 206 (defun calc-select-previous (num)
 207   (interactive "p")
 208   (if (< num 0)
 209       (calc-select-next (- num))
 210     (calc-wrapper
 211      (calc-prepare-selection)
 212      (let* ((entry calc-selection-cache-entry)
 213             (sel (nth 2 entry)))
 214        (if sel
 215            (progn
 216              (while (>= (setq num (1- num)) 0)
 217                (let* ((parent (calc-find-parent-formula (car entry) sel))
 218                       (p (cdr-safe parent))
 219                       (prev nil)
 220                       op)
 221                  (if (eq (car-safe parent) 'intv) (setq p (cdr p)))
 222                  (while (and (not (eq (car p) sel))
 223                              (setq prev (car p)
 224                                    p (cdr p))))
 225                  (if prev
 226                      (setq sel (or (and calc-assoc-selections
 227                                         (setq op (assq (car-safe prev)
 228                                                        calc-assoc-ops))
 229                                         (memq (car parent) (nth 1 op))
 230                                         (nth 2 prev))
 231                                    prev))
 232                    (if (and calc-assoc-selections
 233                             (setq op (assq (car-safe parent) calc-assoc-ops))
 234                             (consp (setq p (calc-find-parent-formula
 235                                             (car entry) parent)))
 236                             (eq (nth 2 p) parent)
 237                             (memq (car p) (nth 2 op)))
 238                        (setq sel (nth 1 p))
 239                      (error "No \"previous\" sub-formula")))))
 240              (calc-change-current-selection sel))
 241          (if (Math-primp (car entry))
 242              (calc-change-current-selection (car entry))
 243            (let ((len (if (and calc-assoc-selections
 244                                (assq (car (car entry)) calc-assoc-ops))
 245                           (let (op (num 0))
 246                             (calc-find-nth-part-rec (car entry))
 247                             (- 1 num))
 248                         (length (car entry)))))
 249              (calc-select-part (- len num))))))))
 250 )
 251
 252 (defun calc-find-parent-formula (expr part)
 253   (cond ((eq expr part) t)
 254         ((Math-primp expr) nil)
 255         (t
 256          (let ((p expr) res)
 257            (while (and (setq p (cdr p))
 258                        (not (setq res (calc-find-parent-formula
 259                                        (car p) part)))))
 260            (and p
 261                 (if (eq res t) expr res)))))
 262 )
 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
 269 (defun calc-grow-assoc-formula (expr part)
 270   (if calc-assoc-selections
 271       (let ((op (assq (car-safe part) calc-assoc-ops)))
 272         (if op
 273             (let (new)
 274               (while (and (consp (setq new (calc-find-parent-formula
 275                                             expr part)))
 276                           (memq (car new)
 277                                 (nth (calc-find-sub-formula new part) op)))
 278                 (setq part new))))
 279         part)
 280     part)
 281 )
 282
 283 (defun calc-find-sub-formula (expr part)
 284   (cond ((eq expr part) t)
 285         ((Math-primp expr) nil)
 286         (t
 287          (let ((num 1))
 288            (while (and (setq expr (cdr expr))
 289                        (not (calc-find-sub-formula (car expr) part)))
 290              (setq num (1+ num)))
 291            (and expr num))))
 292 )
 293
 294 (defun calc-unselect (num)
 295   (interactive "P")
 296   (calc-wrapper
 297    (calc-prepare-selection num)
 298    (calc-change-current-selection nil))
 299 )
 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
 315 (defun calc-show-selections (arg)
 316   (interactive "P")
 317   (calc-wrapper
 318    (calc-preserve-point)
 319    (setq calc-show-selections (if arg
 320                                   (> (prefix-numeric-value arg) 0)
 321                                 (not calc-show-selections)))
 322    (let ((p calc-stack))
 323      (while (and p
 324                  (or (null (nth 2 (car p)))
 325                      (equal (car p) calc-selection-cache-entry)))
 326        (setq p (cdr p)))
 327      (or (and p
 328               (let ((calc-selection-cache-default-entry
 329                      calc-selection-cache-entry))
 330                 (calc-do-refresh)))
 331          (and calc-selection-cache-entry
 332               (let ((sel (nth 2 calc-selection-cache-entry)))
 333                 (setcar (nthcdr 2 calc-selection-cache-entry) nil)
 334                 (calc-change-current-selection sel)))))
 335    (message (if calc-show-selections
 336                 "Displaying only selected part of formulas"
 337               "Displaying all but selected part of formulas")))
 338 )
 339
 340 (defun calc-preserve-point ()
 341   (or (looking-at "\\.\n+\\'")
 342       (progn
 343         (setq calc-final-point-line (+ (count-lines (point-min) (point))
 344                                        (if (bolp) 1 0))
 345               calc-final-point-column (current-column))
 346         (calc-set-command-flag 'position-point)))
 347 )
 348
 349 (defun calc-enable-selections (arg)
 350   (interactive "P")
 351   (calc-wrapper
 352    (calc-preserve-point)
 353    (setq calc-use-selections (if arg
 354                                  (> (prefix-numeric-value arg) 0)
 355                                (not calc-use-selections)))
 356    (calc-set-command-flag 'renum-stack)
 357    (message (if calc-use-selections
 358                 "Commands operate only on selected sub-formulas"
 359               "Selections of sub-formulas have no effect")))
 360 )
 361
 362 (defun calc-break-selections (arg)
 363   (interactive "P")
 364   (calc-wrapper
 365    (calc-preserve-point)
 366    (setq calc-assoc-selections (if arg
 367                                    (<= (prefix-numeric-value arg) 0)
 368                                  (not calc-assoc-selections)))
 369    (message (if calc-assoc-selections
 370                 "Selection treats a+b+c as a sum of three terms"
 371               "Selection treats a+b+c as (a+b)+c")))
 372 )
 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 (setq calc-selection-cache-entry nil)
 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
 408 (defun calc-encase-atoms-rec (x)
 409   (or (Math-primp x)
 410       (progn
 411         (if (eq (car x) 'intv)
 412             (setq x (cdr x)))
 413         (while (setq x (cdr x))
 414           (if (or (not (consp (car x)))
 415                   (equal (car x) '(float 0 0)))
 416               (setcar x (list 'cplx (car x) 0))
 417             (calc-encase-atoms-rec (car x))))))
 418 )
 419
 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
 447 (defun calc-change-current-selection (sub-expr)
 448   (or (eq sub-expr (nth 2 calc-selection-cache-entry))
 449       (let ((calc-prepared-composition calc-selection-cache-comp)
 450             (buffer-read-only nil)
 451             top)
 452         (calc-set-command-flag 'renum-stack)
 453         (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr)
 454         (calc-cursor-stack-index calc-selection-cache-num)
 455         (setq top (point))
 456         (calc-cursor-stack-index (1- calc-selection-cache-num))
 457         (delete-region top (point))
 458         (let ((calc-selection-cache-default-entry calc-selection-cache-entry))
 459           (insert (math-format-stack-value calc-selection-cache-entry)
 460                   "\n"))))
 461 )
 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
 479 (defun calc-replace-sub-formula (expr old new)
 480   (setq new (calc-encase-atoms new))
 481   (calc-replace-sub-formula-rec expr)
 482 )
 483
 484 (defun calc-replace-sub-formula-rec (expr)
 485   (cond ((eq expr old) new)
 486         ((Math-primp expr) expr)
 487         (t
 488          (cons (car expr)
 489                (mapcar 'calc-replace-sub-formula-rec (cdr expr)))))
 490 )
 491
 492 (defun calc-sel-error ()
 493   (error "Illegal operation on sub-formulas")
 494 )
 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 (setq calc-keep-selection t)
 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
 596 (defun calc-roll-down-with-selections (n m)
 597   (let ((vals (append (calc-top-list m 1)
 598                       (calc-top-list (- n m) (1+ m))))
 599         (sels (append (calc-top-list m 1 'sel)
 600                       (calc-top-list (- n m) (1+ m) 'sel))))
 601     (calc-pop-push-list n vals 1 sels))
 602 )
 603
 604 (defun calc-roll-up-with-selections (n m)
 605   (let ((vals (append (calc-top-list (- n m) 1)
 606                       (calc-top-list m (- n m -1))))
 607         (sels (append (calc-top-list (- n m) 1 'sel)
 608                       (calc-top-list m (- n m -1) 'sel))))
 609     (calc-pop-push-list n vals 1 sels))
 610 )
 611
 612 (defun calc-auto-selection (entry)
 613   (or (nth 2 entry)
 614       (progn
 615         (and (boundp 'reselect) (setq reselect nil))
 616         (calc-prepare-selection)
 617         (calc-grow-assoc-formula (car entry) (calc-find-selected-part))))
 618 )
 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
 629 (defun calc-del-selection ()
 630   (interactive)
 631   (calc-wrapper
 632    (calc-preserve-point)
 633    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 634           (entry (calc-top num 'entry))
 635           (sel (calc-auto-selection entry)))
 636      (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
 637      (calc-delete-selection num)))
 638 )
 639
 640 (defun calc-enter-selection ()
 641   (interactive)
 642   (calc-wrapper
 643    (calc-preserve-point)
 644    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 645           (reselect calc-keep-selection)
 646           (entry (calc-top num 'entry))
 647           (expr (car entry))
 648           (sel (or (calc-auto-selection entry) expr))
 649           alg)
 650      (let ((calc-dollar-values (list sel))
 651            (calc-dollar-used 0))
 652        (setq alg (calc-do-alg-entry "" "Replace selection with: "))
 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 reselect alg))))))
 661      (calc-handle-whys)))
 662 )
 663
 664 (defun calc-edit-selection ()
 665   (interactive)
 666   (calc-wrapper
 667    (calc-preserve-point)
 668    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 669           (reselect calc-keep-selection)
 670           (entry (calc-top num 'entry))
 671           (expr (car entry))
 672           (sel (or (calc-auto-selection entry) expr))
 673           alg)
 674      (let ((str (math-showing-full-precision
 675                  (math-format-nice-expr sel (frame-width)))))
 676        (calc-edit-mode (list 'calc-finish-selection-edit
 677                              num (list 'quote sel) reselect))
 678        (insert str "\n"))))
 679   (calc-show-edit-buffer)
 680 )
 681
 682 (defun calc-finish-selection-edit (num sel reselect)
 683   (let ((buf (current-buffer))
 684         (str (buffer-substring (point) (point-max)))
 685         (start (point)))
 686     (switch-to-buffer calc-original-buffer)
 687     (let ((val (math-read-expr str)))
 688       (if (eq (car-safe val) 'error)
 689           (progn
 690             (switch-to-buffer buf)
 691             (goto-char (+ start (nth 1 val)))
 692             (error (nth 2 val))))
 693       (calc-wrapper
 694        (calc-preserve-point)
 695        (if disp-trail
 696            (calc-trail-display 1 t))
 697        (setq val (calc-encase-atoms (calc-normalize val)))
 698        (let ((expr (calc-top num 'full)))
 699          (if (calc-find-sub-formula expr sel)
 700              (calc-pop-push-record-list 1 "edit"
 701                                         (list (calc-replace-sub-formula
 702                                                expr sel val))
 703                                         num
 704                                         (list (and reselect val)))
 705            (calc-push val)
 706            (error "Original selection has been lost"))))))
 707 )
 708
 709 (defun calc-sel-evaluate (arg)
 710   (interactive "p")
 711   (calc-slow-wrapper
 712    (calc-preserve-point)
 713    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 714           (reselect calc-keep-selection)
 715           (entry (calc-top num 'entry))
 716           (sel (or (calc-auto-selection entry) (car entry))))
 717      (calc-with-default-simplification
 718       (let ((math-simplify-only nil))
 719         (calc-modify-simplify-mode arg)
 720         (let ((val (calc-encase-atoms (calc-normalize sel))))
 721           (calc-pop-push-record-list 1 "jsmp"
 722                                      (list (calc-replace-sub-formula
 723                                             (car entry) sel val))
 724                                      num
 725                                      (list (and reselect val))))))
 726      (calc-handle-whys)))
 727 )
 728
 729 (defun calc-sel-expand-formula (arg)
 730   (interactive "p")
 731   (calc-slow-wrapper
 732    (calc-preserve-point)
 733    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 734           (reselect calc-keep-selection)
 735           (entry (calc-top num 'entry))
 736           (sel (or (calc-auto-selection entry) (car entry))))
 737      (calc-with-default-simplification
 738       (let ((math-simplify-only nil))
 739         (calc-modify-simplify-mode arg)
 740         (let* ((math-expand-formulas (> arg 0))
 741                (val (calc-normalize sel))
 742                top)
 743           (and (<= arg 0)
 744                (setq top (math-expand-formula val))
 745                (setq val (calc-normalize top)))
 746           (setq val (calc-encase-atoms val))
 747           (calc-pop-push-record-list 1 "jexf"
 748                                      (list (calc-replace-sub-formula
 749                                             (car entry) sel val))
 750                                      num
 751                                      (list (and reselect val))))))
 752      (calc-handle-whys)))
 753 )
 754
 755 (defun calc-sel-mult-both-sides (no-simp &optional divide)
 756   (interactive "P")
 757   (calc-wrapper
 758    (calc-preserve-point)
 759    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 760           (reselect calc-keep-selection)
 761           (entry (calc-top num 'entry))
 762           (expr (car entry))
 763           (sel (or (calc-auto-selection entry) expr))
 764           (func (car-safe sel))
 765           alg lhs rhs)
 766      (setq alg (calc-with-default-simplification
 767                 (car (calc-do-alg-entry ""
 768                                         (if divide
 769                                             "Divide both sides by: "
 770                                           "Multiply both sides by: ")))))
 771      (and alg
 772           (progn
 773             (if (and (or (eq func '/)
 774                          (assq func calc-tweak-eqn-table))
 775                      (= (length sel) 3))
 776                 (progn
 777                   (or (memq func '(/ calcFunc-eq calcFunc-neq))
 778                       (if (math-known-nonposp alg)
 779                           (progn
 780                             (setq func (nth 1 (assq func
 781                                                     calc-tweak-eqn-table)))
 782                             (or (math-known-negp alg)
 783                                 (message "Assuming this factor is nonzero")))
 784                         (or (math-known-posp alg)
 785                             (if (math-known-nonnegp alg)
 786                                 (message "Assuming this factor is nonzero")
 787                               (message "Assuming this factor is positive")))))
 788                   (setq lhs (list (if divide '/ '*) (nth 1 sel) alg)
 789                         rhs (list (if divide '/ '*) (nth 2 sel) alg))
 790                   (or no-simp
 791                       (progn
 792                         (setq lhs (math-simplify lhs)
 793                               rhs (math-simplify rhs))
 794                         (and (eq func '/)
 795                              (or (Math-equal (nth 1 sel) 1)
 796                                  (Math-equal (nth 1 sel) -1)
 797                                  (and (memq (car-safe (nth 2 sel)) '(+ -))
 798                                       (memq (car-safe alg) '(+ -))))
 799                              (setq rhs (math-expand-term rhs)))))
 800                   (setq alg (calc-encase-atoms
 801                              (calc-normalize (list func lhs rhs)))))
 802               (setq rhs (list (if divide '* '/) sel alg))
 803               (or no-simp
 804                   (setq rhs (math-simplify rhs)))
 805               (setq alg (calc-encase-atoms
 806                          (calc-normalize (if divide
 807                                              (list '/ rhs alg)
 808                                            (list '* alg rhs))))))
 809             (calc-pop-push-record-list 1 (if divide "div" "mult")
 810                                        (list (calc-replace-sub-formula
 811                                               expr sel alg))
 812                                        num
 813                                        (list (and reselect alg)))))
 814      (calc-handle-whys)))
 815 )
 816
 817 (defun calc-sel-div-both-sides (no-simp)
 818   (interactive "P")
 819   (calc-sel-mult-both-sides no-simp t)
 820 )
 821
 822 (defun calc-sel-add-both-sides (no-simp &optional subtract)
 823   (interactive "P")
 824   (calc-wrapper
 825    (calc-preserve-point)
 826    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 827           (reselect calc-keep-selection)
 828           (entry (calc-top num 'entry))
 829           (expr (car entry))
 830           (sel (or (calc-auto-selection entry) expr))
 831           (func (car-safe sel))
 832           alg lhs rhs)
 833      (setq alg (calc-with-default-simplification
 834                 (car (calc-do-alg-entry ""
 835                                         (if subtract
 836                                             "Subtract from both sides: "
 837                                           "Add to both sides: ")))))
 838      (and alg
 839           (progn
 840             (if (and (assq func calc-tweak-eqn-table)
 841                      (= (length sel) 3))
 842                 (progn
 843                   (setq lhs (list (if subtract '- '+) (nth 1 sel) alg)
 844                         rhs (list (if subtract '- '+) (nth 2 sel) alg))
 845                   (or no-simp
 846                       (setq lhs (math-simplify lhs)
 847                             rhs (math-simplify rhs)))
 848                   (setq alg (calc-encase-atoms
 849                              (calc-normalize (list func lhs rhs)))))
 850               (setq rhs (list (if subtract '+ '-) sel alg))
 851               (or no-simp
 852                   (setq rhs (math-simplify rhs)))
 853               (setq alg (calc-encase-atoms
 854                          (calc-normalize (list (if subtract '- '+) alg rhs)))))
 855             (calc-pop-push-record-list 1 (if subtract "sub" "add")
 856                                        (list (calc-replace-sub-formula
 857                                               expr sel alg))
 858                                        num
 859                                        (list (and reselect alg)))))
 860      (calc-handle-whys)))
 861 )
 862
 863 (defun calc-sel-sub-both-sides (no-simp)
 864   (interactive "P")
 865   (calc-sel-add-both-sides no-simp t)
 866 )
 867