1;;; calcsel2.el --- selection functions for Calc 2 3;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 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 2, 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 307