lisp/calc/calcsel2.el

   1 ;;; calcsel2.el --- selection functions for Calc
   2
   3 ;; Copyright (C) 1990-1993, 2001-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: David Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 ;; This file is autoloaded from calc-ext.el.
  28
  29 (require 'calc-ext)
  30 (require 'calc-macs)
  31
  32 ;; The variable calc-keep-selection is declared and set in calc-sel.el.
  33 (defvar calc-keep-selection)
  34
  35 ;; The variable calc-sel-reselect is local to the methods below,
  36 ;; but is used by some functions in calc-sel.el which are called
  37 ;; by the functions below.
  38
  39 (defun calc-commute-left (arg)
  40   (interactive "p")
  41   (if (< arg 0)
  42       (calc-commute-right (- arg))
  43     (calc-wrapper
  44      (calc-preserve-point)
  45      (let ((num (max 1 (calc-locate-cursor-element (point))))
  46            (calc-sel-reselect calc-keep-selection))
  47        (if (= arg 0) (setq arg nil))
  48        (while (or (null arg) (>= (setq arg (1- arg)) 0))
  49          (let* ((entry (calc-top num 'entry))
  50                 (expr (car entry))
  51                 (sel (calc-auto-selection entry))
  52                 parent new)
  53            (or (and sel
  54                     (consp (setq parent (calc-find-assoc-parent-formula
  55                                          expr sel))))
  56                (error "No term is selected"))
  57            (if (and calc-assoc-selections
  58                     (assq (car parent) calc-assoc-ops))
  59                (let ((outer (calc-find-parent-formula parent sel)))
  60                  (if (eq sel (nth 2 outer))
  61                      (setq new (calc-replace-sub-formula
  62                                 parent outer
  63                                 (cond
  64                                  ((memq (car outer)
  65                                         (nth 1 (assq (car-safe (nth 1 outer))
  66                                                      calc-assoc-ops)))
  67                                   (let* ((other (nth 2 (nth 1 outer)))
  68                                          (new (calc-build-assoc-term
  69                                                (car (nth 1 outer))
  70                                                (calc-build-assoc-term
  71                                                 (car outer)
  72                                                 (nth 1 (nth 1 outer))
  73                                                 sel)
  74                                                other)))
  75                                     (setq sel (nth 2 (nth 1 new)))
  76                                     new))
  77                                  ((eq (car outer) '-)
  78                                   (calc-build-assoc-term
  79                                    '+
  80                                    (setq sel (math-neg sel))
  81                                    (nth 1 outer)))
  82                                  ((eq (car outer) '/)
  83                                   (calc-build-assoc-term
  84                                    '*
  85                                    (setq sel (calcFunc-div 1 sel))
  86                                    (nth 1 outer)))
  87                                  (t (calc-build-assoc-term
  88                                      (car outer) sel (nth 1 outer))))))
  89                    (let ((next (calc-find-parent-formula parent outer)))
  90                      (if (not (and (consp next)
  91                                    (eq outer (nth 2 next))
  92                                    (eq (car next) (car outer))))
  93                          (setq new nil)
  94                        (setq new (calc-build-assoc-term
  95                                   (car next)
  96                                   sel
  97                                   (calc-build-assoc-term
  98                                    (car next) (nth 1 next) (nth 2 outer)))
  99                              sel (nth 1 new)
 100                              new (calc-replace-sub-formula
 101                                   parent next new))))))
 102              (if (eq (nth 1 parent) sel)
 103                  (setq new nil)
 104                (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
 105                                 (setq new (copy-sequence parent)))))
 106                  (setcar (cdr p) (car p))
 107                  (setcar p sel))))
 108            (if (null new)
 109                (if arg
 110                    (error "Term is already leftmost")
 111                  (or calc-sel-reselect
 112                      (calc-pop-push-list 1 (list expr) num '(nil)))
 113                  (setq arg 0))
 114              (calc-pop-push-record-list
 115               1 "left"
 116               (list (calc-replace-sub-formula expr parent new))
 117               num
 118               (list (and (or (not (eq arg 0)) calc-sel-reselect)
 119                          sel))))))))))
 120
 121 (defun calc-commute-right (arg)
 122   (interactive "p")
 123   (if (< arg 0)
 124       (calc-commute-left (- arg))
 125     (calc-wrapper
 126      (calc-preserve-point)
 127      (let ((num (max 1 (calc-locate-cursor-element (point))))
 128            (calc-sel-reselect calc-keep-selection))
 129        (if (= arg 0) (setq arg nil))
 130        (while (or (null arg) (>= (setq arg (1- arg)) 0))
 131          (let* ((entry (calc-top num 'entry))
 132                 (expr (car entry))
 133                 (sel (calc-auto-selection entry))
 134                 parent new)
 135            (or (and sel
 136                     (consp (setq parent (calc-find-assoc-parent-formula
 137                                          expr sel))))
 138                (error "No term is selected"))
 139            (if (and calc-assoc-selections
 140                     (assq (car parent) calc-assoc-ops))
 141                (let ((outer (calc-find-parent-formula parent sel)))
 142                  (if (eq sel (nth 1 outer))
 143                      (setq new (calc-replace-sub-formula
 144                                 parent outer
 145                                 (if (memq (car outer)
 146                                           (nth 2 (assq (car-safe (nth 2 outer))
 147                                                        calc-assoc-ops)))
 148                                     (let ((other (nth 1 (nth 2 outer))))
 149                                       (calc-build-assoc-term
 150                                        (car outer)
 151                                        other
 152                                        (calc-build-assoc-term
 153                                         (car (nth 2 outer))
 154                                         sel
 155                                         (nth 2 (nth 2 outer)))))
 156                                   (let ((new (cond
 157                                               ((eq (car outer) '-)
 158                                                (calc-build-assoc-term
 159                                                 '+
 160                                                 (math-neg (nth 2 outer))
 161                                                 sel))
 162                                               ((eq (car outer) '/)
 163                                                (calc-build-assoc-term
 164                                                 '*
 165                                                 (calcFunc-div 1 (nth 2 outer))
 166                                                 sel))
 167                                               (t (calc-build-assoc-term
 168                                                   (car outer)
 169                                                   (nth 2 outer)
 170                                                   sel)))))
 171                                     (setq sel (nth 2 new))
 172                                     new))))
 173                    (let ((next (calc-find-parent-formula parent outer)))
 174                      (if (not (and (consp next)
 175                                    (eq outer (nth 1 next))))
 176                          (setq new nil)
 177                        (setq new (calc-build-assoc-term
 178                                   (car outer)
 179                                   (calc-build-assoc-term
 180                                    (car next) (nth 1 outer) (nth 2 next))
 181                                   sel)
 182                              sel (nth 2 new)
 183                              new (calc-replace-sub-formula
 184                                   parent next new))))))
 185              (if (eq (nth (1- (length parent)) parent) sel)
 186                  (setq new nil)
 187                (let ((p (nthcdr (calc-find-sub-formula parent sel)
 188                                 (setq new (copy-sequence parent)))))
 189                  (setcar p (nth 1 p))
 190                  (setcar (cdr p) sel))))
 191            (if (null new)
 192                (if arg
 193                    (error "Term is already rightmost")
 194                  (or calc-sel-reselect
 195                      (calc-pop-push-list 1 (list expr) num '(nil)))
 196                  (setq arg 0))
 197              (calc-pop-push-record-list
 198               1 "rght"
 199               (list (calc-replace-sub-formula expr parent new))
 200               num
 201               (list (and (or (not (eq arg 0)) calc-sel-reselect)
 202                          sel))))))))))
 203
 204 (defun calc-build-assoc-term (op lhs rhs)
 205   (cond ((and (eq op '+) (or (math-looks-negp rhs)
 206                              (and (eq (car-safe rhs) 'cplx)
 207                                   (math-negp (nth 1 rhs))
 208                                   (eq (nth 2 rhs) 0))))
 209          (list '- lhs (math-neg rhs)))
 210         ((and (eq op '-) (or (math-looks-negp rhs)
 211                              (and (eq (car-safe rhs) 'cplx)
 212                                   (math-negp (nth 1 rhs))
 213                                   (eq (nth 2 rhs) 0))))
 214          (list '+ lhs (math-neg rhs)))
 215         ((and (eq op '*) (and (eq (car-safe rhs) '/)
 216                               (or (math-equal-int (nth 1 rhs) 1)
 217                                   (equal (nth 1 rhs) '(cplx 1 0)))))
 218          (list '/ lhs (nth 2 rhs)))
 219         ((and (eq op '/) (and (eq (car-safe rhs) '/)
 220                               (or (math-equal-int (nth 1 rhs) 1)
 221                                   (equal (nth 1 rhs) '(cplx 1 0)))))
 222          (list '/ lhs (nth 2 rhs)))
 223         (t (list op lhs rhs))))
 224
 225 (defun calc-sel-unpack ()
 226   (interactive)
 227   (calc-wrapper
 228    (calc-preserve-point)
 229    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 230           (calc-sel-reselect calc-keep-selection)
 231           (entry (calc-top num 'entry))
 232           (expr (car entry))
 233           (sel (or (calc-auto-selection entry) expr)))
 234      (or (and (not (math-primp sel))
 235               (= (length sel) 2))
 236          (error "Selection must be a function of one argument"))
 237      (calc-pop-push-record-list 1 "unpk"
 238                                 (list (calc-replace-sub-formula
 239                                        expr sel (nth 1 sel)))
 240                                 num
 241                                 (list (and calc-sel-reselect (nth 1 sel)))))))
 242
 243 (defun calc-sel-isolate ()
 244   (interactive)
 245   (calc-slow-wrapper
 246    (calc-preserve-point)
 247    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 248           (calc-sel-reselect calc-keep-selection)
 249           (entry (calc-top num 'entry))
 250           (expr (car entry))
 251           (sel (or (calc-auto-selection entry) (error "No selection")))
 252           (eqn sel)
 253           soln)
 254      (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
 255                      (error "Selection must be a member of an equation"))
 256                  (not (assq (car eqn) calc-tweak-eqn-table))))
 257      (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
 258      (or soln
 259          (error "No solution found"))
 260      (setq soln (calc-encase-atoms
 261                  (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
 262                          (eq (nth 1 soln) sel))
 263                      soln
 264                    (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
 265                          (nth 2 soln)
 266                          (nth 1 soln)))))
 267      (calc-pop-push-record-list 1 "isol"
 268                                 (list (calc-replace-sub-formula
 269                                        expr eqn soln))
 270                                 num
 271                                 (list (and calc-sel-reselect sel)))
 272      (calc-handle-whys))))
 273
 274 (defun calc-sel-commute (many)
 275   (interactive "P")
 276   (let ((calc-assoc-selections nil))
 277     (calc-rewrite-selection "CommuteRules" many "cmut"))
 278   (calc-set-mode-line))
 279
 280 (defun calc-sel-jump-equals (many)
 281   (interactive "P")
 282   (calc-rewrite-selection "JumpRules" many "jump"))
 283
 284 (defun calc-sel-distribute (many)
 285   (interactive "P")
 286   (calc-rewrite-selection "DistribRules" many "dist"))
 287
 288 (defun calc-sel-merge (many)
 289   (interactive "P")
 290   (calc-rewrite-selection "MergeRules" many "merg"))
 291
 292 (defun calc-sel-negate (many)
 293   (interactive "P")
 294   (calc-rewrite-selection "NegateRules" many "jneg"))
 295
 296 (defun calc-sel-invert (many)
 297   (interactive "P")
 298   (calc-rewrite-selection "InvertRules" many "jinv"))
 299
 300 (provide 'calcsel2)
 301
 302 ;;; calcsel2.el ends here