lisp/calc/calcsel2.el

   1 ;;; calcsel2.el --- selection functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 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, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  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 ;; The variable calc-keep-selection is declared and set in calc-sel.el.
  36 (defvar calc-keep-selection)
  37
  38 ;; The variable calc-sel-reselect is local to the methods below,
  39 ;; but is used by some functions in calc-sel.el which are called
  40 ;; by the functions below.
  41
  42 (defun calc-commute-left (arg)
  43   (interactive "p")
  44   (if (< arg 0)
  45       (calc-commute-right (- arg))
  46     (calc-wrapper
  47      (calc-preserve-point)
  48      (let ((num (max 1 (calc-locate-cursor-element (point))))
  49            (calc-sel-reselect calc-keep-selection))
  50        (if (= arg 0) (setq arg nil))
  51        (while (or (null arg) (>= (setq arg (1- arg)) 0))
  52          (let* ((entry (calc-top num 'entry))
  53                 (expr (car entry))
  54                 (sel (calc-auto-selection entry))
  55                 parent new)
  56            (or (and sel
  57                     (consp (setq parent (calc-find-assoc-parent-formula
  58                                          expr sel))))
  59                (error "No term is selected"))
  60            (if (and calc-assoc-selections
  61                     (assq (car parent) calc-assoc-ops))
  62                (let ((outer (calc-find-parent-formula parent sel)))
  63                  (if (eq sel (nth 2 outer))
  64                      (setq new (calc-replace-sub-formula
  65                                 parent outer
  66                                 (cond
  67                                  ((memq (car outer)
  68                                         (nth 1 (assq (car-safe (nth 1 outer))
  69                                                      calc-assoc-ops)))
  70                                   (let* ((other (nth 2 (nth 1 outer)))
  71                                          (new (calc-build-assoc-term
  72                                                (car (nth 1 outer))
  73                                                (calc-build-assoc-term
  74                                                 (car outer)
  75                                                 (nth 1 (nth 1 outer))
  76                                                 sel)
  77                                                other)))
  78                                     (setq sel (nth 2 (nth 1 new)))
  79                                     new))
  80                                  ((eq (car outer) '-)
  81                                   (calc-build-assoc-term
  82                                    '+
  83                                    (setq sel (math-neg sel))
  84                                    (nth 1 outer)))
  85                                  ((eq (car outer) '/)
  86                                   (calc-build-assoc-term
  87                                    '*
  88                                    (setq sel (calcFunc-div 1 sel))
  89                                    (nth 1 outer)))
  90                                  (t (calc-build-assoc-term
  91                                      (car outer) sel (nth 1 outer))))))
  92                    (let ((next (calc-find-parent-formula parent outer)))
  93                      (if (not (and (consp next)
  94                                    (eq outer (nth 2 next))
  95                                    (eq (car next) (car outer))))
  96                          (setq new nil)
  97                        (setq new (calc-build-assoc-term
  98                                   (car next)
  99                                   sel
 100                                   (calc-build-assoc-term
 101                                    (car next) (nth 1 next) (nth 2 outer)))
 102                              sel (nth 1 new)
 103                              new (calc-replace-sub-formula
 104                                   parent next new))))))
 105              (if (eq (nth 1 parent) sel)
 106                  (setq new nil)
 107                (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
 108                                 (setq new (copy-sequence parent)))))
 109                  (setcar (cdr p) (car p))
 110                  (setcar p sel))))
 111            (if (null new)
 112                (if arg
 113                    (error "Term is already leftmost")
 114                  (or calc-sel-reselect
 115                      (calc-pop-push-list 1 (list expr) num '(nil)))
 116                  (setq arg 0))
 117              (calc-pop-push-record-list
 118               1 "left"
 119               (list (calc-replace-sub-formula expr parent new))
 120               num
 121               (list (and (or (not (eq arg 0)) calc-sel-reselect)
 122                          sel))))))))))
 123
 124 (defun calc-commute-right (arg)
 125   (interactive "p")
 126   (if (< arg 0)
 127       (calc-commute-left (- arg))
 128     (calc-wrapper
 129      (calc-preserve-point)
 130      (let ((num (max 1 (calc-locate-cursor-element (point))))
 131            (calc-sel-reselect calc-keep-selection))
 132        (if (= arg 0) (setq arg nil))
 133        (while (or (null arg) (>= (setq arg (1- arg)) 0))
 134          (let* ((entry (calc-top num 'entry))
 135                 (expr (car entry))
 136                 (sel (calc-auto-selection entry))
 137                 parent new)
 138            (or (and sel
 139                     (consp (setq parent (calc-find-assoc-parent-formula
 140                                          expr sel))))
 141                (error "No term is selected"))
 142            (if (and calc-assoc-selections
 143                     (assq (car parent) calc-assoc-ops))
 144                (let ((outer (calc-find-parent-formula parent sel)))
 145                  (if (eq sel (nth 1 outer))
 146                      (setq new (calc-replace-sub-formula
 147                                 parent outer
 148                                 (if (memq (car outer)
 149                                           (nth 2 (assq (car-safe (nth 2 outer))
 150                                                        calc-assoc-ops)))
 151                                     (let ((other (nth 1 (nth 2 outer))))
 152                                       (calc-build-assoc-term
 153                                        (car outer)
 154                                        other
 155                                        (calc-build-assoc-term
 156                                         (car (nth 2 outer))
 157                                         sel
 158                                         (nth 2 (nth 2 outer)))))
 159                                   (let ((new (cond
 160                                               ((eq (car outer) '-)
 161                                                (calc-build-assoc-term
 162                                                 '+
 163                                                 (math-neg (nth 2 outer))
 164                                                 sel))
 165                                               ((eq (car outer) '/)
 166                                                (calc-build-assoc-term
 167                                                 '*
 168                                                 (calcFunc-div 1 (nth 2 outer))
 169                                                 sel))
 170                                               (t (calc-build-assoc-term
 171                                                   (car outer)
 172                                                   (nth 2 outer)
 173                                                   sel)))))
 174                                     (setq sel (nth 2 new))
 175                                     new))))
 176                    (let ((next (calc-find-parent-formula parent outer)))
 177                      (if (not (and (consp next)
 178                                    (eq outer (nth 1 next))))
 179                          (setq new nil)
 180                        (setq new (calc-build-assoc-term
 181                                   (car outer)
 182                                   (calc-build-assoc-term
 183                                    (car next) (nth 1 outer) (nth 2 next))
 184                                   sel)
 185                              sel (nth 2 new)
 186                              new (calc-replace-sub-formula
 187                                   parent next new))))))
 188              (if (eq (nth (1- (length parent)) parent) sel)
 189                  (setq new nil)
 190                (let ((p (nthcdr (calc-find-sub-formula parent sel)
 191                                 (setq new (copy-sequence parent)))))
 192                  (setcar p (nth 1 p))
 193                  (setcar (cdr p) sel))))
 194            (if (null new)
 195                (if arg
 196                    (error "Term is already rightmost")
 197                  (or calc-sel-reselect
 198                      (calc-pop-push-list 1 (list expr) num '(nil)))
 199                  (setq arg 0))
 200              (calc-pop-push-record-list
 201               1 "rght"
 202               (list (calc-replace-sub-formula expr parent new))
 203               num
 204               (list (and (or (not (eq arg 0)) calc-sel-reselect)
 205                          sel))))))))))
 206
 207 (defun calc-build-assoc-term (op lhs rhs)
 208   (cond ((and (eq op '+) (or (math-looks-negp rhs)
 209                              (and (eq (car-safe rhs) 'cplx)
 210                                   (math-negp (nth 1 rhs))
 211                                   (eq (nth 2 rhs) 0))))
 212          (list '- lhs (math-neg rhs)))
 213         ((and (eq op '-) (or (math-looks-negp rhs)
 214                              (and (eq (car-safe rhs) 'cplx)
 215                                   (math-negp (nth 1 rhs))
 216                                   (eq (nth 2 rhs) 0))))
 217          (list '+ lhs (math-neg rhs)))
 218         ((and (eq op '*) (and (eq (car-safe rhs) '/)
 219                               (or (math-equal-int (nth 1 rhs) 1)
 220                                   (equal (nth 1 rhs) '(cplx 1 0)))))
 221          (list '/ lhs (nth 2 rhs)))
 222         ((and (eq op '/) (and (eq (car-safe rhs) '/)
 223                               (or (math-equal-int (nth 1 rhs) 1)
 224                                   (equal (nth 1 rhs) '(cplx 1 0)))))
 225          (list '/ lhs (nth 2 rhs)))
 226         (t (list op lhs rhs))))
 227
 228 (defun calc-sel-unpack ()
 229   (interactive)
 230   (calc-wrapper
 231    (calc-preserve-point)
 232    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 233           (calc-sel-reselect calc-keep-selection)
 234           (entry (calc-top num 'entry))
 235           (expr (car entry))
 236           (sel (or (calc-auto-selection entry) expr)))
 237      (or (and (not (math-primp sel))
 238               (= (length sel) 2))
 239          (error "Selection must be a function of one argument"))
 240      (calc-pop-push-record-list 1 "unpk"
 241                                 (list (calc-replace-sub-formula
 242                                        expr sel (nth 1 sel)))
 243                                 num
 244                                 (list (and calc-sel-reselect (nth 1 sel)))))))
 245
 246 (defun calc-sel-isolate ()
 247   (interactive)
 248   (calc-slow-wrapper
 249    (calc-preserve-point)
 250    (let* ((num (max 1 (calc-locate-cursor-element (point))))
 251           (calc-sel-reselect calc-keep-selection)
 252           (entry (calc-top num 'entry))
 253           (expr (car entry))
 254           (sel (or (calc-auto-selection entry) (error "No selection")))
 255           (eqn sel)
 256           soln)
 257      (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
 258                      (error "Selection must be a member of an equation"))
 259                  (not (assq (car eqn) calc-tweak-eqn-table))))
 260      (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
 261      (or soln
 262          (error "No solution found"))
 263      (setq soln (calc-encase-atoms
 264                  (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
 265                          (eq (nth 1 soln) sel))
 266                      soln
 267                    (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
 268                          (nth 2 soln)
 269                          (nth 1 soln)))))
 270      (calc-pop-push-record-list 1 "isol"
 271                                 (list (calc-replace-sub-formula
 272                                        expr eqn soln))
 273                                 num
 274                                 (list (and calc-sel-reselect sel)))
 275      (calc-handle-whys))))
 276
 277 (defun calc-sel-commute (many)
 278   (interactive "P")
 279   (let ((calc-assoc-selections nil))
 280     (calc-rewrite-selection "CommuteRules" many "cmut"))
 281   (calc-set-mode-line))
 282
 283 (defun calc-sel-jump-equals (many)
 284   (interactive "P")
 285   (calc-rewrite-selection "JumpRules" many "jump"))
 286
 287 (defun calc-sel-distribute (many)
 288   (interactive "P")
 289   (calc-rewrite-selection "DistribRules" many "dist"))
 290
 291 (defun calc-sel-merge (many)
 292   (interactive "P")
 293   (calc-rewrite-selection "MergeRules" many "merg"))
 294
 295 (defun calc-sel-negate (many)
 296   (interactive "P")
 297   (calc-rewrite-selection "NegateRules" many "jneg"))
 298
 299 (defun calc-sel-invert (many)
 300   (interactive "P")
 301   (calc-rewrite-selection "InvertRules" many "jinv"))
 302
 303 (provide 'calcsel2)
 304
 305 ;;; arch-tag: 7c5b8d65-b8f0-45d9-820d-9930f8ee114b
 306 ;;; calcsel2.el ends here