Mercurial > emacs
diff lisp/calc/calcsel2.el @ 40785:2fb9d407ae73
Initial import of Calc 2.02f.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Tue, 06 Nov 2001 18:59:06 +0000 |
parents | |
children | 73f364fd8aaa |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/calc/calcsel2.el Tue Nov 06 18:59:06 2001 +0000 @@ -0,0 +1,303 @@ +;; Calculator for GNU Emacs, part II [calc-sel-2.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, daveg@synaptics.com. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-sel-2 () nil) + + +(defun calc-commute-left (arg) + (interactive "p") + (if (< arg 0) + (calc-commute-right (- arg)) + (calc-wrapper + (calc-preserve-point) + (let ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection)) + (if (= arg 0) (setq arg nil)) + (while (or (null arg) (>= (setq arg (1- arg)) 0)) + (let* ((entry (calc-top num 'entry)) + (expr (car entry)) + (sel (calc-auto-selection entry)) + parent new) + (or (and sel + (consp (setq parent (calc-find-assoc-parent-formula + expr sel)))) + (error "No term is selected")) + (if (and calc-assoc-selections + (assq (car parent) calc-assoc-ops)) + (let ((outer (calc-find-parent-formula parent sel))) + (if (eq sel (nth 2 outer)) + (setq new (calc-replace-sub-formula + parent outer + (cond + ((memq (car outer) + (nth 1 (assq (car-safe (nth 1 outer)) + calc-assoc-ops))) + (let* ((other (nth 2 (nth 1 outer))) + (new (calc-build-assoc-term + (car (nth 1 outer)) + (calc-build-assoc-term + (car outer) + (nth 1 (nth 1 outer)) + sel) + other))) + (setq sel (nth 2 (nth 1 new))) + new)) + ((eq (car outer) '-) + (calc-build-assoc-term + '+ + (setq sel (math-neg sel)) + (nth 1 outer))) + ((eq (car outer) '/) + (calc-build-assoc-term + '* + (setq sel (calcFunc-div 1 sel)) + (nth 1 outer))) + (t (calc-build-assoc-term + (car outer) sel (nth 1 outer)))))) + (let ((next (calc-find-parent-formula parent outer))) + (if (not (and (consp next) + (eq outer (nth 2 next)) + (eq (car next) (car outer)))) + (setq new nil) + (setq new (calc-build-assoc-term + (car next) + sel + (calc-build-assoc-term + (car next) (nth 1 next) (nth 2 outer))) + sel (nth 1 new) + new (calc-replace-sub-formula + parent next new)))))) + (if (eq (nth 1 parent) sel) + (setq new nil) + (let ((p (nthcdr (1- (calc-find-sub-formula parent sel)) + (setq new (copy-sequence parent))))) + (setcar (cdr p) (car p)) + (setcar p sel)))) + (if (null new) + (if arg + (error "Term is already leftmost") + (or reselect + (calc-pop-push-list 1 (list expr) num '(nil))) + (setq arg 0)) + (calc-pop-push-record-list + 1 "left" + (list (calc-replace-sub-formula expr parent new)) + num + (list (and (or (not (eq arg 0)) reselect) + sel))))))))) +) + +(defun calc-commute-right (arg) + (interactive "p") + (if (< arg 0) + (calc-commute-left (- arg)) + (calc-wrapper + (calc-preserve-point) + (let ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection)) + (if (= arg 0) (setq arg nil)) + (while (or (null arg) (>= (setq arg (1- arg)) 0)) + (let* ((entry (calc-top num 'entry)) + (expr (car entry)) + (sel (calc-auto-selection entry)) + parent new) + (or (and sel + (consp (setq parent (calc-find-assoc-parent-formula + expr sel)))) + (error "No term is selected")) + (if (and calc-assoc-selections + (assq (car parent) calc-assoc-ops)) + (let ((outer (calc-find-parent-formula parent sel))) + (if (eq sel (nth 1 outer)) + (setq new (calc-replace-sub-formula + parent outer + (if (memq (car outer) + (nth 2 (assq (car-safe (nth 2 outer)) + calc-assoc-ops))) + (let ((other (nth 1 (nth 2 outer)))) + (calc-build-assoc-term + (car outer) + other + (calc-build-assoc-term + (car (nth 2 outer)) + sel + (nth 2 (nth 2 outer))))) + (let ((new (cond + ((eq (car outer) '-) + (calc-build-assoc-term + '+ + (math-neg (nth 2 outer)) + sel)) + ((eq (car outer) '/) + (calc-build-assoc-term + '* + (calcFunc-div 1 (nth 2 outer)) + sel)) + (t (calc-build-assoc-term + (car outer) + (nth 2 outer) + sel))))) + (setq sel (nth 2 new)) + new)))) + (let ((next (calc-find-parent-formula parent outer))) + (if (not (and (consp next) + (eq outer (nth 1 next)))) + (setq new nil) + (setq new (calc-build-assoc-term + (car outer) + (calc-build-assoc-term + (car next) (nth 1 outer) (nth 2 next)) + sel) + sel (nth 2 new) + new (calc-replace-sub-formula + parent next new)))))) + (if (eq (nth (1- (length parent)) parent) sel) + (setq new nil) + (let ((p (nthcdr (calc-find-sub-formula parent sel) + (setq new (copy-sequence parent))))) + (setcar p (nth 1 p)) + (setcar (cdr p) sel)))) + (if (null new) + (if arg + (error "Term is already rightmost") + (or reselect + (calc-pop-push-list 1 (list expr) num '(nil))) + (setq arg 0)) + (calc-pop-push-record-list + 1 "rght" + (list (calc-replace-sub-formula expr parent new)) + num + (list (and (or (not (eq arg 0)) reselect) + sel))))))))) +) + +(defun calc-build-assoc-term (op lhs rhs) + (cond ((and (eq op '+) (or (math-looks-negp rhs) + (and (eq (car-safe rhs) 'cplx) + (math-negp (nth 1 rhs)) + (eq (nth 2 rhs) 0)))) + (list '- lhs (math-neg rhs))) + ((and (eq op '-) (or (math-looks-negp rhs) + (and (eq (car-safe rhs) 'cplx) + (math-negp (nth 1 rhs)) + (eq (nth 2 rhs) 0)))) + (list '+ lhs (math-neg rhs))) + ((and (eq op '*) (and (eq (car-safe rhs) '/) + (or (math-equal-int (nth 1 rhs) 1) + (equal (nth 1 rhs) '(cplx 1 0))))) + (list '/ lhs (nth 2 rhs))) + ((and (eq op '/) (and (eq (car-safe rhs) '/) + (or (math-equal-int (nth 1 rhs) 1) + (equal (nth 1 rhs) '(cplx 1 0))))) + (list '/ lhs (nth 2 rhs))) + (t (list op lhs rhs))) +) + +(defun calc-sel-unpack () + (interactive) + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) expr))) + (or (and (not (math-primp sel)) + (= (length sel) 2)) + (error "Selection must be a function of one argument")) + (calc-pop-push-record-list 1 "unpk" + (list (calc-replace-sub-formula + expr sel (nth 1 sel))) + num + (list (and reselect (nth 1 sel)))))) +) + +(defun calc-sel-isolate () + (interactive) + (calc-slow-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) (error "No selection"))) + (eqn sel) + soln) + (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn))) + (error "Selection must be a member of an equation")) + (not (assq (car eqn) calc-tweak-eqn-table)))) + (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag)) + (or soln + (error "No solution found")) + (setq soln (calc-encase-atoms + (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel)) + (eq (nth 1 soln) sel)) + soln + (list (nth 1 (assq (car soln) calc-tweak-eqn-table)) + (nth 2 soln) + (nth 1 soln))))) + (calc-pop-push-record-list 1 "isol" + (list (calc-replace-sub-formula + expr eqn soln)) + num + (list (and reselect sel))) + (calc-handle-whys))) +) + +(defun calc-sel-commute (many) + (interactive "P") + (let ((calc-assoc-selections nil)) + (calc-rewrite-selection "CommuteRules" many "cmut")) + (calc-set-mode-line) +) + +(defun calc-sel-jump-equals (many) + (interactive "P") + (calc-rewrite-selection "JumpRules" many "jump") +) + +(defun calc-sel-distribute (many) + (interactive "P") + (calc-rewrite-selection "DistribRules" many "dist") +) + +(defun calc-sel-merge (many) + (interactive "P") + (calc-rewrite-selection "MergeRules" many "merg") +) + +(defun calc-sel-negate (many) + (interactive "P") + (calc-rewrite-selection "NegateRules" many "jneg") +) + +(defun calc-sel-invert (many) + (interactive "P") + (calc-rewrite-selection "InvertRules" many "jinv") +) +