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