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