| 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 |