daveg@csvax.cs.caltech.edu (David Gillespie) (10/15/90)
Posting-number: Volume 15, Issue 32
Submitted-by: daveg@csvax.cs.caltech.edu (David Gillespie)
Archive-name: calc-1.05/part05
#!/bin/sh
# this is part 5 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.patch continued
#
CurArch=5
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
exit 1; fi
( read Scheck
if test "$Scheck" != $CurArch
then echo "Please unpack part $Scheck next!"
exit 1;
else exit 0; fi
) < s2_seq_.tmp || exit 1
sed 's/^X//' << 'SHAR_EOF' >> calc.patch
X! (calc-set-command-flag 'renum-stack)
X! (message (if calc-use-selections
X! "Commands operate only on selected sub-formulas"
X! "Selections of sub-formulas have no effect")))
X! )
X!
X! (defun calc-break-selections (arg)
X! "Toggle whether selections can break up associative formulas like a+b+c.
X! By default, a+b+c is treated as a single level of the formula with 3 parts.
X! In this mode, a+b+c is treated as its true internal form, (a+b)+c."
X! (interactive "P")
X! (calc-wrapper
X! (calc-preserve-point)
X! (setq calc-assoc-selections (if arg
X! (<= (prefix-numeric-value arg) 0)
X! (not calc-assoc-selections)))
X! (message (if calc-assoc-selections
X! "Selection treats a+b+c as a sum of three terms"
X! "Selection treats a+b+c as (a+b)+c")))
X! )
X!
X! (defun calc-prepare-selection (&optional num)
X! (or num (setq num (calc-locate-cursor-element (point))))
X! (setq calc-selection-true-num num
X! calc-keep-selection t)
X! (or (> num 0) (setq num 1))
X! ;; (if (or (< num 1) (> num (calc-stack-size)))
X! ;; (error "Cursor must be positioned on a stack element"))
X! (let* ((entry (calc-top num 'entry))
X! ww w)
X! (or (equal entry calc-selection-cache-entry)
X! (progn
X! (setcar entry (calc-encase-atoms (car entry)))
X! (setq calc-selection-cache-entry entry
X! calc-selection-cache-num num
X! calc-selection-cache-comp
X! (let ((math-comp-tagged t))
X! (math-compose-expr (car entry) 0))
X! calc-selection-cache-offset
X! (if (and calc-display-just
X! (< (setq ww (math-comp-width
X! calc-selection-cache-comp))
X! (setq w (calc-window-width))))
X! (if (eq calc-display-just 'center)
X! (/ (- w ww) 2)
X! (- w ww))
X! (if calc-line-numbering 4 0))))))
X! (calc-preserve-point)
X! )
X! (setq calc-selection-cache-entry nil)
X!
X! ;;; The following ensures that no two subformulas will be "eq" to each other!
X! (defun calc-encase-atoms (x)
X! (if (or (not (consp x))
X! (equal x '(float 0 0)))
X! (list 'cplx x 0)
X! (calc-encase-atoms-rec x)
X! x)
X! )
X!
X! (defun calc-encase-atoms-rec (x)
X! (or (Math-primp x)
X! (progn
X! (if (eq (car x) 'intv)
X! (setq x (cdr x)))
X! (while (setq x (cdr x))
X! (if (or (not (consp (car x)))
X! (equal (car x) '(float 0 0)))
X! (setcar x (list 'cplx (car x) 0))
X! (calc-encase-atoms-rec (car x))))))
X! )
X!
X! (defun calc-find-selected-part ()
X! (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
X! toppt
X! (lcount 0)
X! (math-comp-sel-vpos (save-excursion
X! (beginning-of-line)
X! (let ((line (point)))
X! (calc-cursor-stack-index
X! calc-selection-cache-num)
X! (setq toppt (point))
X! (while (< (point) line)
X! (forward-line 1)
X! (setq lcount (1+ lcount)))
X! (- lcount (math-comp-ascent
X! calc-selection-cache-comp) -1))))
X! (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset
X! (* lcount
X! (+ calc-selection-cache-offset 2))))
X! (math-comp-sel-tag nil))
X! (and (>= math-comp-sel-hpos 0)
X! (> calc-selection-true-num 0)
X! (math-composition-to-string calc-selection-cache-comp 1000000))
X! (nth 1 math-comp-sel-tag))
X! )
X!
X! (defun calc-change-current-selection (sub-expr)
X! (or (eq sub-expr (nth 2 calc-selection-cache-entry))
X! (let ((calc-prepared-composition calc-selection-cache-comp)
X! (buffer-read-only nil)
X! top)
X! (calc-set-command-flag 'renum-stack)
X! (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr)
X! (calc-cursor-stack-index calc-selection-cache-num)
X! (setq top (point))
X! (calc-cursor-stack-index (1- calc-selection-cache-num))
X! (delete-region top (point))
X! (let ((calc-selection-cache-default-entry calc-selection-cache-entry))
X! (insert (math-format-stack-value calc-selection-cache-entry
X! (calc-window-width)) "\n"))))
X! )
X!
X! (defun calc-top-selected (&optional n m)
X! (and calc-any-selections
X! calc-use-selections
X! (progn
X! (or n (setq n 1))
X! (or m (setq m 1))
X! (calc-check-stack (+ n m -1))
X! (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack))
X! (sel nil))
X! (while (>= (setq n (1- n)) 0)
X! (if (nth 2 (car top))
X! (setq sel (if sel t (nth 2 (car top)))))
X! (setq top (cdr top)))
X! sel)))
X! )
X!
X! (defun calc-replace-sub-formula (expr old new)
X! (setq new (calc-encase-atoms new))
X! (calc-replace-sub-formula-rec expr)
X! )
X!
X! (defun calc-replace-sub-formula-rec (expr)
X! (cond ((eq expr old) new)
X! ((Math-primp expr) expr)
X! (t
X! (cons (car expr)
X! (mapcar 'calc-replace-sub-formula-rec (cdr expr)))))
X! )
X!
X! (defun calc-sel-error ()
X! (error "Illegal operation on sub-formulas")
X! )
X!
X! (defun calc-replace-selections (n vals m)
X! (if (calc-top-selected n m)
X! (let ((num (length vals)))
X! (calc-preserve-point)
X! (cond
X! ((= n num)
X! (let* ((old (calc-top-list n m 'entry))
X! (new nil)
X! (sel nil)
X! val)
X! (while old
X! (if (nth 2 (car old))
X! (setq val (calc-encase-atoms (car vals))
X! new (cons (calc-replace-sub-formula (car (car old))
X! (nth 2 (car old))
X! val)
X! new)
X! sel (cons val sel))
X! (setq new (cons (car vals) new)
X! sel (cons nil sel)))
X! (setq vals (cdr vals)
X! old (cdr old)))
X! (calc-pop-stack n m t)
X! (calc-push-list (nreverse new)
X! m (and calc-keep-selection (nreverse sel)))))
X! ((= num 1)
X! (let* ((old (calc-top-list n m 'entry))
X! more)
X! (while (and old (not (nth 2 (car old))))
X! (setq old (cdr old)))
X! (setq more old)
X! (while (and (setq more (cdr more)) (not (nth 2 (car more)))))
X! (and more
X! (calc-sel-error))
X! (calc-pop-stack n m t)
X! (if old
X! (let ((val (calc-encase-atoms (car vals))))
X! (calc-push-list (list (calc-replace-sub-formula
X! (car (car old))
X! (nth 2 (car old))
X! val))
X! m (and calc-keep-selection (list val))))
X! (calc-push-list vals))))
X! (t (calc-sel-error))))
X! (calc-pop-stack n m t)
X! (calc-push-list vals m))
X! )
X! (setq calc-keep-selection t)
X!
X! (defun calc-delete-selection (n)
X! (let ((entry (calc-top n 'entry)))
X! (if (nth 2 entry)
X! (if (eq (nth 2 entry) (car entry))
X! (progn
X! (calc-pop-stack 1 n t)
X! (calc-push-list '(0) n))
X! (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry)))
X! (repl nil))
X! (calc-preserve-point)
X! (calc-pop-stack 1 n t)
X! (cond ((or (memq (car parent) '(* / %))
X! (and (eq (car parent) '^)
X! (eq (nth 2 parent) (nth 2 entry))))
X! (setq repl 1))
X! ((memq (car parent) '(vec calcFunc-min calcFunc-max)))
X! (t
X! (setq repl 0)))
X! (if repl
X! (calc-push-list (list
X! (calc-normalize
X! (calc-replace-sub-formula (car entry)
X! (nth 2 entry)
X! repl)))
X! n)
X! (calc-push-list (list
X! (calc-normalize
X! (calc-replace-sub-formula (car entry)
X! parent
X! (delq (nth 2 entry)
X! (copy-sequence
X! parent)))))
X! n))))
X! (calc-pop-stack 1 n t)))
X! )
X!
X! (defun calc-roll-down-with-selections (n m)
X! (let ((vals (append (calc-top-list m 1)
X! (calc-top-list (- n m) (1+ m))))
X! (sels (append (calc-top-list m 1 'sel)
X! (calc-top-list (- n m) (1+ m) 'sel))))
X! (calc-pop-push-list n vals 1 sels))
X! )
X!
X! (defun calc-roll-up-with-selections (n m)
X! (let ((vals (append (calc-top-list (- n m) 1)
X! (calc-top-list m (- n m -1))))
X! (sels (append (calc-top-list (- n m) 1 'sel)
X! (calc-top-list m (- n m -1) 'sel))))
X! (calc-pop-push-list n vals 1 sels))
X! )
X!
X! (defun calc-auto-selection (entry)
X! (or (nth 2 entry)
X! (progn
X! (and (boundp 'reselect) (setq reselect nil))
X! (calc-prepare-selection)
X! (calc-grow-assoc-formula (car entry) (calc-find-selected-part))))
X! )
X!
X! (defun calc-copy-selection ()
X! "Push a copy of the selected portion of a formula onto the stack."
X! (interactive)
X! (calc-wrapper
X! (calc-preserve-point)
X! (let* ((num (max 1 (calc-locate-cursor-element (point))))
X! (entry (calc-top num 'entry)))
X! (calc-push (or (calc-auto-selection entry) (car entry)))))
X! )
X!
X! (defun calc-del-selection ()
X! "Delete the selected portion of a formula."
X! (interactive)
X! (calc-wrapper
X! (calc-preserve-point)
X! (let* ((num (max 1 (calc-locate-cursor-element (point))))
X! (entry (calc-top num 'entry))
X! (sel (calc-auto-selection entry)))
X! (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
X! (calc-delete-selection num)))
X! )
X!
X! (defun calc-enter-selection ()
X! "Replace the selected portion of a formula with an algebraic entry."
X! (interactive)
X! (calc-wrapper
X! (calc-preserve-point)
X! (let* ((num (max 1 (calc-locate-cursor-element (point))))
X! (reselect calc-keep-selection)
X! (entry (calc-top num 'entry))
X! (expr (car entry))
X! (sel (or (calc-auto-selection entry) expr))
X! alg)
X! (let ((calc-dollar-values (list sel))
X! (calc-dollar-used 0))
X! (setq alg (calc-do-alg-entry "" "Replace selection with: "))
X! (and alg
X! (progn
X! (setq alg (calc-encase-atoms (car alg)))
X! (calc-pop-push-record-list 1 "repl"
X! (list (calc-replace-sub-formula
X! expr sel alg))
X! num
X! (list (and reselect alg))))))
X! (calc-handle-whys)))
X! )
X!
X! (defun calc-edit-selection ()
X! "Edit the selected portion of a formula with calc-edit."
X! (interactive)
X! (calc-wrapper
X! (calc-preserve-point)
X! (let* ((num (max 1 (calc-locate-cursor-element (point))))
X! (reselect calc-keep-selection)
X! (entry (calc-top num 'entry))
X! (expr (car entry))
X! (sel (or (calc-auto-selection entry) expr))
X! alg)
X! (let ((str (math-format-nice-expr sel (screen-width))))
X! (calc-edit-mode (list 'calc-finish-selection-edit
X! num (list 'quote sel) reselect))
X! (insert str "\n"))))
X! (calc-show-edit-buffer)
X )
X
X+ (defun calc-finish-selection-edit (num sel reselect)
X+ (let ((buf (current-buffer))
X+ (str (buffer-substring (point) (point-max)))
X+ (start (point)))
X+ (switch-to-buffer calc-original-buffer)
X+ (let ((val (math-read-expr str)))
X+ (if (eq (car-safe val) 'error)
X+ (progn
X+ (switch-to-buffer buf)
X+ (goto-char (+ start (nth 1 val)))
X+ (error (nth 2 val))))
X+ (calc-wrapper
X+ (calc-preserve-point)
X+ (if disp-trail
X+ (calc-trail-display 1 t))
X+ (setq val (calc-encase-atoms (calc-normalize val)))
X+ (let ((expr (calc-top num 'full)))
X+ (if (calc-find-sub-formula expr sel)
X+ (calc-pop-push-record-list 1 "edit"
X+ (list (calc-replace-sub-formula
X+ expr sel val))
X+ num
X+ (list (and reselect val)))
X+ (calc-push val)
X+ (error "Original selection has been lost"))))))
X+ )
X+
X+ (defun calc-sel-evaluate (arg)
X+ "Apply normal default simplifications to selected sub-formula.
X+ \(See calc-alg-evaluate.)
X+ With a prefix argument of 2, applies calc-simplify.
X+ With a prefix argument of 3 or more, applies calc-simplify-extended."
X+ (interactive "p")
X+ (calc-slow-wrapper
X+ (calc-preserve-point)
X+ (let* ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection)
X+ (entry (calc-top num 'entry))
X+ (sel (or (calc-auto-selection entry) (car entry))))
X+ (calc-with-default-simplification
X+ (let ((val (calc-encase-atoms (cond ((>= arg 3)
X+ (math-simplify-extended sel))
X+ ((>= arg 2)
X+ (math-simplify sel))
X+ (t (calc-normalize sel))))))
X+ (calc-pop-push-record-list 1 "gsmp"
X+ (list (calc-replace-sub-formula
X+ (car entry) sel val))
X+ num
X+ (list (and reselect val)))))
X+ (calc-handle-whys)))
X+ )
X+
X+ (defun calc-sel-mult-both-sides (no-simp &optional divide)
X+ "Multiply both sides of the selected quotient or equation by a value.
X+ Each side is simplified with calc-simplify. A numeric prefix argument
X+ will suppress this simplification; then only default simplifications
X+ are applied.
X+ If selection is not a quotient or equation, extract a multiplicative factor."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-preserve-point)
X+ (let* ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection)
X+ (entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (or (calc-auto-selection entry) expr))
X+ (func (car-safe sel))
X+ alg lhs rhs)
X+ (setq alg (calc-with-default-simplification
X+ (car (calc-do-alg-entry ""
X+ (if divide
X+ "Divide both sides by: "
X+ "Multiply both sides by: ")))))
X+ (and alg
X+ (progn
X+ (if (and (or (eq func '/)
X+ (assq func calc-tweak-eqn-table))
X+ (= (length sel) 3))
X+ (progn
X+ (or (memq func '(/ calcFunc-eq calcFunc-neq))
X+ (if (or (not (math-scalarp alg)) (math-zerop alg))
X+ (error "Factor must be nonzero real for inequality")
X+ (if (math-negp alg)
X+ (setq func (nth 1 (assq func
X+ calc-tweak-eqn-table))))))
X+ (setq lhs (list (if divide '/ '*) (nth 1 sel) alg)
X+ rhs (list (if divide '/ '*) (nth 2 sel) alg))
X+ (or no-simp
X+ (setq lhs (math-simplify lhs)
X+ rhs (math-simplify rhs)))
X+ (setq alg (calc-encase-atoms
X+ (calc-normalize (list func lhs rhs)))))
X+ (setq rhs (list (if divide '* '/) sel alg))
X+ (or no-simp
X+ (setq rhs (math-simplify rhs)))
X+ (setq alg (calc-encase-atoms
X+ (calc-normalize (list (if divide '/ '*) alg rhs)))))
X+ (calc-pop-push-record-list 1 (if divide "div" "mult")
X+ (list (calc-replace-sub-formula
X+ expr sel alg))
X+ num
X+ (list (and reselect alg)))))
X+ (calc-handle-whys)))
X+ )
X+
X+ (defun calc-sel-div-both-sides (no-simp)
X+ "Divide both sides of the selected quotient or equation by a value."
X+ (interactive "P")
X+ (calc-sel-mult-both-sides no-simp t)
X+ )
X+
X+ (defun calc-sel-add-both-sides (no-simp &optional subtract)
X+ "Add a value to both sides of the selected equation (or inequality).
X+ Each side is simplified with calc-simplify. A numeric prefix argument
X+ will suppress this simplification; then only default simplifications
X+ are applied.
X+ If selection is not an equation, extract an additive factor."
X+ (interactive "P")
X+ (calc-wrapper
X+ (calc-preserve-point)
X+ (let* ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection)
X+ (entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (or (calc-auto-selection entry) expr))
X+ (func (car-safe sel))
X+ alg lhs rhs)
X+ (setq alg (calc-with-default-simplification
X+ (car (calc-do-alg-entry ""
X+ (if subtract
X+ "Subtract from both sides: "
X+ "Add to both sides: ")))))
X+ (and alg
X+ (progn
X+ (if (and (assq func calc-tweak-eqn-table)
X+ (= (length sel) 3))
X+ (progn
X+ (setq lhs (list (if subtract '- '+) (nth 1 sel) alg)
X+ rhs (list (if subtract '- '+) (nth 2 sel) alg))
X+ (or no-simp
X+ (setq lhs (math-simplify lhs)
X+ rhs (math-simplify rhs)))
X+ (setq alg (calc-encase-atoms
X+ (calc-normalize (list func lhs rhs)))))
X+ (setq rhs (list (if subtract '+ '-) sel alg))
X+ (or no-simp
X+ (setq rhs (math-simplify rhs)))
X+ (setq alg (calc-encase-atoms
X+ (calc-normalize (list (if subtract '- '+) alg rhs)))))
X+ (calc-pop-push-record-list 1 (if subtract "sub" "add")
X+ (list (calc-replace-sub-formula
X+ expr sel alg))
X+ num
X+ (list (and reselect alg)))))
X+ (calc-handle-whys)))
X+ )
X+
X+ (defun calc-sel-sub-both-sides (no-simp)
X+ "Subtract a value from both sides of the selected equation."
X+ (interactive "P")
X+ (calc-sel-add-both-sides no-simp t)
X+ )
X+
X+ ;;;; [calc-sel-2.el]
X+
X+ (defun calc-commute-left (arg)
X+ "Swap the currently selected term leftward within enclosing sum.
X+ Also works for products, elements of vectors, function arguments.
X+ With a prefix argument, moves N steps to the left (or -N to the right).
X+ With a prefix argument of zero, moves as far as possible to the left."
X+ (interactive "p")
X+ (if (< arg 0)
X+ (calc-commute-right (- arg))
X+ (calc-wrapper
X+ (calc-preserve-point)
X+ (let ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection))
X+ (if (= arg 0) (setq arg nil))
X+ (while (or (null arg) (>= (setq arg (1- arg)) 0))
X+ (let* ((entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (calc-auto-selection entry))
X+ parent new)
X+ (or (and sel
X+ (consp (setq parent (calc-find-assoc-parent-formula
X+ expr sel))))
X+ (error "No term is selected"))
X+ (if (and calc-assoc-selections
X+ (assq (car parent) calc-assoc-ops))
X+ (let ((outer (calc-find-parent-formula parent sel)))
X+ (if (eq sel (nth 2 outer))
X+ (setq new (calc-replace-sub-formula
X+ parent outer
X+ (cond
X+ ((memq (car outer)
X+ (nth 1 (assq (car-safe (nth 1 outer))
X+ calc-assoc-ops)))
X+ (let* ((other (nth 2 (nth 1 outer)))
X+ (new (calc-build-assoc-term
X+ (car (nth 1 outer))
X+ (calc-build-assoc-term
X+ (car outer)
X+ (nth 1 (nth 1 outer))
X+ sel)
X+ other)))
X+ (setq sel (nth 2 (nth 1 new)))
X+ new))
X+ ((eq (car outer) '-)
X+ (calc-build-assoc-term
X+ '+
X+ (setq sel (math-neg sel))
X+ (nth 1 outer)))
X+ ((eq (car outer) '/)
X+ (calc-build-assoc-term
X+ '*
X+ (setq sel (calcFunc-div 1 sel))
X+ (nth 1 outer)))
X+ (t (calc-build-assoc-term
X+ (car outer) sel (nth 1 outer))))))
X+ (let ((next (calc-find-parent-formula parent outer)))
X+ (if (not (and (consp next)
X+ (eq outer (nth 2 next))
X+ (eq (car next) (car outer))))
X+ (setq new nil)
X+ (setq new (calc-build-assoc-term
X+ (car next)
X+ sel
X+ (calc-build-assoc-term
X+ (car next) (nth 1 next) (nth 2 outer)))
X+ sel (nth 1 new)
X+ new (calc-replace-sub-formula
X+ parent next new))))))
X+ (if (eq (nth 1 parent) sel)
X+ (setq new nil)
X+ (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
X+ (setq new (copy-sequence parent)))))
X+ (setcar (cdr p) (car p))
X+ (setcar p sel))))
X+ (if (null new)
X+ (if arg
X+ (error "Term is already leftmost")
X+ (or reselect
X+ (calc-pop-push-list 1 (list expr) num '(nil)))
X+ (setq arg 0))
X+ (calc-pop-push-record-list
X+ 1 "left"
X+ (list (calc-replace-sub-formula expr parent new))
X+ num
X+ (list (and (or (not (eq arg 0)) reselect)
X+ sel)))))))))
X+ )
X+
X+ (defun calc-commute-right (arg)
X+ "Swap the currently selected term rightward within enclosing sum.
X+ Also works for products, elements of vectors, function arguments.
X+ With a prefix argument, moves N steps to the right (or -N to the left).
X+ With a prefix argument of zero, moves as far as possible to the right."
X+ (interactive "p")
X+ (if (< arg 0)
X+ (calc-commute-left (- arg))
X+ (calc-wrapper
X+ (calc-preserve-point)
X+ (let ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection))
X+ (if (= arg 0) (setq arg nil))
X+ (while (or (null arg) (>= (setq arg (1- arg)) 0))
X+ (let* ((entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (calc-auto-selection entry))
X+ parent new)
X+ (or (and sel
X+ (consp (setq parent (calc-find-assoc-parent-formula
X+ expr sel))))
X+ (error "No term is selected"))
X+ (if (and calc-assoc-selections
X+ (assq (car parent) calc-assoc-ops))
X+ (let ((outer (calc-find-parent-formula parent sel)))
X+ (if (eq sel (nth 1 outer))
X+ (setq new (calc-replace-sub-formula
X+ parent outer
X+ (if (memq (car outer)
X+ (nth 2 (assq (car-safe (nth 2 outer))
X+ calc-assoc-ops)))
X+ (let ((other (nth 1 (nth 2 outer))))
X+ (calc-build-assoc-term
X+ (car outer)
X+ other
X+ (calc-build-assoc-term
X+ (car (nth 2 outer))
X+ sel
X+ (nth 2 (nth 2 outer)))))
X+ (let ((new (cond
X+ ((eq (car outer) '-)
X+ (calc-build-assoc-term
X+ '+
X+ (math-neg (nth 2 outer))
X+ sel))
X+ ((eq (car outer) '/)
X+ (calc-build-assoc-term
X+ '*
X+ (calcFunc-div 1 (nth 2 outer))
X+ sel))
X+ (t (calc-build-assoc-term
X+ (car outer)
X+ (nth 2 outer)
X+ sel)))))
X+ (setq sel (nth 2 new))
X+ new))))
X+ (let ((next (calc-find-parent-formula parent outer)))
X+ (if (not (and (consp next)
X+ (eq outer (nth 1 next))))
X+ (setq new nil)
X+ (setq new (calc-build-assoc-term
X+ (car outer)
X+ (calc-build-assoc-term
X+ (car next) (nth 1 outer) (nth 2 next))
X+ sel)
X+ sel (nth 2 new)
X+ new (calc-replace-sub-formula
X+ parent next new))))))
X+ (if (eq (nth (1- (length parent)) parent) sel)
X+ (setq new nil)
X+ (let ((p (nthcdr (calc-find-sub-formula parent sel)
X+ (setq new (copy-sequence parent)))))
X+ (setcar p (nth 1 p))
X+ (setcar (cdr p) sel))))
X+ (if (null new)
X+ (if arg
X+ (error "Term is already rightmost")
X+ (or reselect
X+ (calc-pop-push-list 1 (list expr) num '(nil)))
X+ (setq arg 0))
X+ (calc-pop-push-record-list
X+ 1 "rght"
X+ (list (calc-replace-sub-formula expr parent new))
X+ num
X+ (list (and (or (not (eq arg 0)) reselect)
X+ sel)))))))))
X+ )
X+
X+ (defun calc-build-assoc-term (op lhs rhs)
X+ (cond ((and (eq op '+) (or (math-looks-negp rhs)
X+ (and (eq (car-safe rhs) 'cplx)
X+ (math-negp (nth 1 rhs))
X+ (eq (nth 2 rhs) 0))))
X+ (list '- lhs (math-neg rhs)))
X+ ((and (eq op '-) (or (math-looks-negp rhs)
X+ (and (eq (car-safe rhs) 'cplx)
X+ (math-negp (nth 1 rhs))
X+ (eq (nth 2 rhs) 0))))
X+ (list '+ lhs (math-neg rhs)))
X+ ((and (eq op '*) (and (eq (car-safe rhs) '/)
X+ (or (math-equal-int (nth 1 rhs) 1)
X+ (equal (nth 1 rhs) '(cplx 1 0)))))
X+ (list '/ lhs (nth 2 rhs)))
X+ ((and (eq op '/) (and (eq (car-safe rhs) '/)
X+ (or (math-equal-int (nth 1 rhs) 1)
X+ (equal (nth 1 rhs) '(cplx 1 0)))))
X+ (list '/ lhs (nth 2 rhs)))
X+ (t (list op lhs rhs)))
X+ )
X+
X+ (defun calc-sel-unpack ()
X+ "Replace the selected function call with its argument."
X+ (interactive)
X+ (calc-wrapper
X+ (calc-preserve-point)
X+ (let* ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection)
X+ (entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (or (calc-auto-selection entry) expr)))
X+ (or (and (not (math-primp sel))
X+ (= (length sel) 2))
X+ (error "Selection must be a function of one argument"))
X+ (calc-pop-push-record-list 1 "unpk"
X+ (list (calc-replace-sub-formula
X+ expr sel (nth 1 sel)))
X+ num
X+ (list (and reselect (nth 1 sel))))))
X+ )
X+
X+ (defun calc-sel-isolate ()
X+ "Isolate the selected term on its side of the surrounding equation.
X+ With Hyperbolic flag, finds a fully general solution (see calc-solve-for)."
X+ (interactive)
X+ (calc-slow-wrapper
X+ (calc-preserve-point)
X+ (let* ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect calc-keep-selection)
X+ (entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (or (calc-auto-selection entry) (error "No selection")))
X+ (eqn sel)
X+ soln)
X+ (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
X+ (error "Selection must be a member of an equation"))
X+ (not (assq (car eqn) calc-tweak-eqn-table))))
X+ (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
X+ (or soln
X+ (error "No solution found"))
X+ (setq soln (calc-encase-atoms
X+ (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
X+ (eq (nth 1 soln) sel))
X+ soln
X+ (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
X+ (nth 2 soln)
X+ (nth 1 soln)))))
X+ (calc-pop-push-record-list 1 "isol"
X+ (list (calc-replace-sub-formula
X+ expr eqn soln))
X+ num
X+ (list (and reselect sel)))
X+ (calc-handle-whys)))
X+ )
X+
X+ (defun calc-sel-commute ()
X+ "Switch the order of the terms of the currently selected sub-formula."
X+ (interactive)
X+ (let ((calc-assoc-selections nil))
X+ (calc-rewrite-selection "CommuteRules" 1 "cmut"))
X+ (calc-set-mode-line)
X+ )
X+
X+ (defun calc-sel-jump-equals ()
X+ "Move the selected term to the other side of the \"=\" sign.
X+ If the term is not next to the \"=\" sign already, you may have to
X+ use calc-commute-left or calc-commute-right first."
X+ (interactive)
X+ (calc-rewrite-selection "JumpRules" 1 "jump")
X+ )
X+
X+ (defun calc-sel-distribute (many)
X+ "Distribute the selected sum or product into the surrounding formula."
X+ (interactive "p")
X+ (calc-rewrite-selection "DistribRules" (math-abs many) "dist")
X+ )
X+
X+ (defun calc-sel-merge ()
X+ "Merge the selected term with its neighbor using the distributive law."
X+ (interactive)
X+ (calc-rewrite-selection "MergeRules" 1 "merg")
X+ )
X+
X+ (defun calc-sel-negate ()
X+ "Negate the selected term, adjusting surroundings accordingly."
X+ (interactive)
X+ (calc-rewrite-selection "NegateRules" 1 "gneg")
X+ )
X+
X+ (defun calc-sel-invert ()
X+ "Invert (as in 1/x) the selected term, adjusting surroundings accordingly."
X+ (interactive)
X+ (calc-rewrite-selection "InvertRules" 1 "ginv")
X+ )
X+
X+ ;;;; [calc-ext.el]
X+
X+ (defconst var-CommuteRules 'calc-CommuteRules)
X+ (defconst var-JumpRules 'calc-JumpRules)
X+ (defconst var-DistribRules 'calc-DistribRules)
X+ (defconst var-MergeRules 'calc-MergeRules)
X+ (defconst var-NegateRules 'calc-NegateRules)
X+ (defconst var-InvertRules 'calc-InvertRules)
X+
X+ ;;;; [calc-rules.el]
X+
X+ (defun calc-compile-rule-set (name rules)
X+ (prog2
X+ (message "Preparing rule set %s..." name)
X+ (math-read-plain-expr rules t)
X+ (message "Preparing rule set %s...done" name))
X+ )
X+
X+ (defun calc-CommuteRules ()
X+ (calc-compile-rule-set
X+ "CommuteRules"
X+ "[
X+ [ select(plain(a + b)), select(plain(b + a)) ],
X+ [ select(plain(a - b)), select(plain((-b) + a)) ],
X+ [ select(plain((1/a) * b)), select(b / a) ],
X+ [ select(plain(a * b)), select(b * a) ],
X+ [ select((1/a) / b), select((1/b) / a) ],
X+ [ select(a / b), select((1/b) * a) ],
X+ [ select((a^b) ^ c), select((a^c) ^ b) ],
X+ [ select(log(a, b)), select(1 / log(b, a)) ],
X+ [ select(plain(a && b)), select(b && a) ],
X+ [ select(plain(a || b)), select(b || a) ],
X+ [ select(plain(a = b)), select(b = a) ],
X+ [ select(plain(a != b)), select(b != a) ],
X+ [ select(a < b), select(b > a) ],
X+ [ select(a > b), select(b < a) ],
X+ [ select(a <= b), select(b >= a) ],
X+ [ select(a >= b), select(b <= a) ]
X+ ]")
X+ )
X+
X+ (defun calc-JumpRules ()
X+ (calc-compile-rule-set
X+ "JumpRules"
X+ "[
X+ [ plain(select(x) = y), 0 = select(-x) + y ],
X+ [ plain(a + select(x) = y), a = select(-x) + y ],
X+ [ plain(a - select(x) = y), a = select(x) + y ],
X+ [ plain(select(x) + a = y), a = select(-x) + y ],
X+ [ plain(a * select(x) = y), a = y / select(x) ],
X+ [ plain(a / select(x) = y), a = select(x) * y ],
X+ [ plain(select(x) / a = y), 1/a = y / select(x) ],
X+ [ plain(a ^ select(2) = y), a = select(sqrt(y)) ],
X+ [ plain(a ^ select(x) = y), a = y ^ select(1/x) ],
X+ [ plain(select(x) ^ a = y), a = log(y, select(x)) ],
X+ [ plain(log(a, select(x)) = y), a = select(x) ^ y ],
X+ [ plain(log(select(x), a) = y), a = select(x) ^ (1/y) ],
X+ [ plain(y = select(x)), y - select(x) = 0 ],
X+ [ plain(y = a + select(x)), y - select(x) = a ],
X+ [ plain(y = a - select(x)), y + select(x) = a ],
X+ [ plain(y = select(x) + a), y - select(x) = a ],
X+ [ plain(y = a * select(x)), y / select(x) = a ],
X+ [ plain(y = a / select(x)), y * select(x) = a ],
X+ [ plain(y = select(x) / a), y / select(x) = 1/a ],
X+ [ plain(y = a ^ select(2)), select(sqrt(y)) = a ],
X+ [ plain(y = a ^ select(x)), y ^ select(1/x) = a ],
X+ [ plain(y = select(x) ^ a), log(y, select(x)) = a ],
X+ [ plain(y = log(a, select(x))), select(x) ^ y = a ],
X+ [ plain(y = log(select(x), a)), select(x) ^ (1/y) = a ]
X+ ]")
X+ )
X+
X+ (defun calc-DistribRules ()
X+ (calc-compile-rule-set
X+ "DistribRules"
X+ "[
X+ [ x * select(a + b), x*select(a) + x*b ],
X+ [ x / select(a + b), 1 / (select(a)/x + b/x) ],
X+ [ select(a + b) / x, select(a)/x + b/x ],
X+ [ x ^ select(a + b), x^select(a) * x^b ],
X+ [ x ^ select(a * b), (x^a)^select(b) ],
X+ [ x ^ select(a / b), (x^a)^select(1/b) ],
X+ [ select(a * b) ^ x, a^x * select(b)^x ],
X+ [ select(a / b) ^ x, select(a)^x / b^x ],
X+ [ plain(-select(a + b)), select(-a) - b ],
X+ [ plain(-select(a * b)), select(-a) * b ],
X+ [ plain(-select(a / b)), select(-a) / b ],
X+ [ sqrt(select(a * b)), sqrt(select(a)) * sqrt(b) ],
X+ [ sqrt(select(a / b)), sqrt(select(a)) / sqrt(b) ],
X+ [ exp(select(a + b)), exp(select(a)) / exp(-b), negative(b) ],
X+ [ exp(select(a + b)), exp(select(a)) * exp(b) ],
X+ [ exp(select(a * b)), exp(select(a)) ^ b ],
X+ [ exp(select(a / b)), exp(select(a)) ^ (1/b) ],
X+ [ ln(select(a * b)), ln(select(a)) + ln(b) ],
X+ [ ln(select(a / b)), ln(select(a)) - ln(b) ],
X+ [ ln(select(a ^ b)), ln(select(a)) * b ],
X+ [ log10(select(a * b)), log10(select(a)) + log10(b) ],
X+ [ log10(select(a / b)), log10(select(a)) - log10(b) ],
X+ [ log10(select(a ^ b)), log10(select(a)) * b ],
X+ [ log(select(a * b), x), log(select(a), x) + log(b,x) ],
X+ [ log(select(a / b), x), log(select(a), x) - log(b,x) ],
X+ [ log(select(a ^ b), x), log(select(a), x) * b ],
X+ [ log(a, select(b)), ln(a) / select(ln(b)) ],
X+ [ sin(select(a + b)), sin(select(a)) cos(b) + cos(a) sin(b) ],
X+ [ sin(select(2 a)), 2 sin(select(a)) cos(a) ],
X+ [ sin(select(n a)), 2 sin((n-1) select(a)) cos(a) - sin((n-2) a),
X+ integer(n) && n > 2 ],
X+ [ cos(select(a + b)), cos(select(a)) cos(b) - sin(a) sin(b) ],
X+ [ cos(select(2 a)), 2 cos(select(a))^2 - 1 ],
X+ [ cos(select(n a)), 2 cos((n-1) select(a)) cos(a) - cos((n-2) a),
X+ integer(n) && n > 2 ],
X+ [ tan(select(a + b)), (tan(select(a)) + tan(b)) /
X+ (1 - tan(a) tan(b)) ],
X+ [ tan(select(2 a)), 2 tan(select(a)) / (1 - tan(a)^2) ],
X+ [ tan(select(n a)), (tan((n-1) select(a)) + tan(a)) /
X+ (1 - tan((n-1) a) tan(a)),
X+ integer(n) && n > 2 ],
X+ [ sinh(select(a + b)), sinh(select(a)) cosh(b) + cosh(a) sinh(b) ],
X+ [ cosh(select(a + b)), cosh(select(a)) cosh(b) + sinh(a) sinh(b) ],
X+ [ tanh(select(a + b)), (tanh(select(a)) + tanh(b)) /
X+ (1 + tanh(a) tanh(b)) ],
X+ [ x && select(a || b), (x && select(a)) || (x && b) ],
X+ [ select(a || b) && x, (select(a) && x) || (b && x) ],
X+ [ ! select(a && b), (!a) || (!b) ],
X+ [ ! select(a || b), (!a) && (!b) ]
X+ ]")
X+ )
X+
X+ (defun calc-MergeRules ()
X+ (calc-compile-rule-set
X+ "MergeRules"
X+ "[
X+ [ (x*opt(a)) + select(x*b), x * (a + select(b)) ],
X+ [ (x*opt(a)) - select(x*b), x * (a - select(b)) ],
X+ [ (a/x) + select(b/x), (a + select(b)) / x ],
X+ [ (a/x) - select(b/x), (a - select(b)) / x ],
X+ [ (a/opt(b)) + select(c/d), ((select(a)*d) + (b*c)) / (b*d) ],
X+ [ (a/opt(b)) - select(c/d), ((select(a)*d) - (b*c)) / (b*d) ],
X+ [ (x^opt(a)) * select(x^b), x ^ (a + select(b)) ],
X+ [ (x^opt(a)) / select(x^b), x ^ (a - select(b)) ],
X+ [ select(x^a) / (x^opt(b)), x ^ (select(a) - b) ],
X+ [ select(x^a) ^ b, x ^ select(a * b) ],
X+ [ (x^a) ^ select(b), x ^ select(a * b) ],
X+ [ select(sqrt(a)) ^ b, select(a ^ (b / 2)) ],
X+ [ sqrt(a) ^ select(b), select(a ^ (b / 2)) ],
X+ [ sqrt(select(a) ^ b), select(a ^ (b / 2)) ],
X+ [ sqrt(a ^ select(b)), select(a ^ (b / 2)) ],
X+ [ sqrt(a) * select(sqrt(b)), select(sqrt(a * b)) ],
X+ [ sqrt(a) / select(sqrt(b)), select(sqrt(a / b)) ],
X+ [ select(sqrt(a)) / sqrt(b), select(sqrt(a / b)) ],
X+ [ exp(a) * select(exp(b)), select(exp(a + b)) ],
X+ [ exp(a) / select(exp(b)), select(exp(a - b)) ],
X+ [ select(exp(a)) / exp(b), select(exp(a - b)) ],
X+ [ select(exp(a)) ^ b, select(exp(a * b)) ],
X+ [ exp(a) ^ select(b), select(exp(a * b)) ],
X+ [ ln(a) + select(ln(b)), select(ln(a * b)) ],
X+ [ ln(a) - select(ln(b)), select(ln(a / b)) ],
X+ [ select(ln(a)) - ln(b), select(ln(a / b)) ],
X+ [ b * select(ln(a)), select(ln(a ^ b)) ],
X+ [ select(b) * ln(a), select(ln(a ^ b)) ],
X+ [ select(ln(a)) / ln(b), select(log(a, b)) ],
X+ [ ln(a) / select(ln(b)), select(log(a, b)) ],
X+ [ select(ln(a)) / b, select(ln(a ^ (1/b))) ],
X+ [ ln(a) / select(b), select(ln(a ^ (1/b))) ],
X+ [ log10(a) + select(log10(b)), select(log10(a * b)) ],
X+ [ log10(a) - select(log10(b)), select(log10(a / b)) ],
X+ [ select(log10(a)) - log10(b), select(log10(a / b)) ],
X+ [ b * select(log10(a)), select(log10(a ^ b)) ],
X+ [ select(b) * log10(a), select(log10(a ^ b)) ],
X+ [ select(log10(a)) / log10(b), select(log(a, b)) ],
X+ [ log10(a) / select(log10(b)), select(log(a, b)) ],
X+ [ select(log10(a)) / b, select(log10(a ^ (1/b))) ],
X+ [ log10(a) / select(b), select(log10(a ^ (1/b))) ],
X+ [ log(a,x) + select(log(b,x)), select(log(a * b,x)) ],
X+ [ log(a,x) - select(log(b,x)), select(log(a / b,x)) ],
X+ [ select(log(a,x)) - log(b,x), select(log(a / b,x)) ],
X+ [ b * select(log(a,x)), select(log(a ^ b,x)) ],
X+ [ select(b) * log(a,x), select(log(a ^ b,x)) ],
X+ [ select(log(a,x)) / log(b,x), select(log(a, b)) ],
X+ [ log(a,x) / select(log(b,x)), select(log(a, b)) ],
X+ [ select(log(a,x)) / b, select(log(a ^ (1/b),x)) ],
X+ [ log(a,x) / select(b), select(log(a ^ (1/b),x)) ],
X+ [ select(x && a) || (x && opt(b)), x && (select(a) || b) ]
X+ ]")
X+ )
X+
X+ (defun calc-NegateRules ()
X+ (calc-compile-rule-set
X+ "NegateRules"
X+ "[
X+ [ a + select(x), a - select(-x) ],
X+ [ a - select(x), a + select(-x) ],
X+ [ a * select(x), -a * select(-x)],
X+ [ a / select(x), -a / select(-x)],
X+ [ select(x) / a, -select(-x) / a],
X+ [ select(x) ^ n, select(-x) ^ a, integer(n) && n % 2 = 0 ],
X+ [ select(x) ^ n, -(select(-x) ^ a), integer(n) && n % 2 = 1 ],
X+ [ select(x) ^ a, (-select(-x)) ^ a ],
X+ [ a ^ select(x), 1 / a^select(-x) ],
X+ [ abs(select(x)), abs(select(-x)) ],
X+ [ i sqrt(select(x)), -sqrt(select(-x)) ],
X+ [ sqrt(select(x)), i sqrt(select(-x)) ],
X+ [ re(select(x)), -re(select(-x)) ],
X+ [ im(select(x)), -im(select(-x)) ],
X+ [ conj(select(x)), -conj(select(-x)) ],
X+ [ trunc(select(x)), -trunc(select(-x)) ],
X+ [ round(select(x)), -round(select(-x)) ],
X+ [ floor(select(x)), -ceil(select(-x)) ],
X+ [ ceil(select(x)), -floor(select(-x)) ],
X+ [ ftrunc(select(x)), -ftrunc(select(-x)) ],
X+ [ fround(select(x)), -fround(select(-x)) ],
X+ [ ffloor(select(x)), -fceil(select(-x)) ],
X+ [ fceil(select(x)), -ffloor(select(-x)) ],
X+ [ exp(select(x)), 1 / exp(select(-x)) ],
X+ [ sin(select(x)), -sin(select(-x)) ],
X+ [ cos(select(x)), cos(select(-x)) ],
X+ [ tan(select(x)), -tan(select(-x)) ],
X+ [ arcsin(select(x)), -arcsin(select(-x)) ],
X+ [ arccos(select(x)), 4 arctan(1) - arccos(select(-x)) ],
X+ [ arctan(select(x)), -arctan(select(-x)) ],
X+ [ sinh(select(x)), -sinh(select(-x)) ],
X+ [ cosh(select(x)), cosh(select(-x)) ],
X+ [ tanh(select(x)), -tanh(select(-x)) ],
X+ [ arcsinh(select(x)), -arcsinh(select(-x)) ],
X+ [ arctanh(select(x)), -arctanh(select(-x)) ],
X+ [ select(x) = a, select(-x) = -a ],
X+ [ select(x) != a, select(-x) != -a ],
X+ [ select(x) < a, select(-x) > -a ],
X+ [ select(x) > a, select(-x) < -a ],
X+ [ select(x) <= a, select(-x) >= -a ],
X+ [ select(x) >= a, select(-x) <= -a ],
X+ [ a < select(x), -a > select(-x) ],
X+ [ a > select(x), -a < select(-x) ],
X+ [ a <= select(x), -a >= select(-x) ],
X+ [ a >= select(x), -a <= select(-x) ],
X+ [ select(x), -select(-x) ]
X+ ]")
X+ )
X+
X+ (defun calc-InvertRules ()
X+ (calc-compile-rule-set
X+ "InvertRules"
X+ "[
X+ [ a * select(x), a / select(1/x) ],
X+ [ a / select(x), a * select(1/x) ],
X+ [ select(x) / a, 1 / (select(1/x) a) ],
X+ [ abs(select(x)), 1 / abs(select(1/x)) ],
X+ [ sqrt(select(x)), 1 / sqrt(select(1/x)) ],
X+ [ ln(select(x)), -ln(select(1/x)) ],
X+ [ log10(select(x)), -log10(select(1/x)) ],
X+ [ log(select(x), a), -log(select(1/x), a) ],
X+ [ log(a, select(x)), -log(a, select(1/x)) ],
X+ [ select(x) = a, select(1/x) = 1/a ],
X+ [ select(x) != a, select(1/x) != 1/a ],
X+ [ select(x) < a, select(1/x) > 1/a ],
X+ [ select(x) > a, select(1/x) < 1/a ],
X+ [ select(x) <= a, select(1/x) >= 1/a ],
X+ [ select(x) >= a, select(1/x) <= 1/a ],
X+ [ a < select(x), 1/a > select(1/x) ],
X+ [ a > select(x), 1/a < select(1/x) ],
X+ [ a <= select(x), 1/a >= select(1/x) ],
X+ [ a >= select(x), 1/a <= select(1/x) ],
X+ [ select(x), 1 / select(1/x) ]
X+ ]")
X+ )
X+
X+ ;;;; [calc-rewr.el]
X+
X+ (defun calc-rewrite-selection (rules &optional many prefix)
X+ "Like calc-rewrite, but applies to a selected subformula.
X+ The rewrite is applied everywhere, but the selected subformula is
X+ surrounded by a \"select\" function call. E.g., if a+b is the
X+ selection in x+(a+b)^2, the formula is changed to x+select(a+b)^2
X+ and then the rewrite is applied. If a select( ) call is present
X+ after the rewrites are done, that portion becomes the new selection.
X+ Otherwise, the resulting formula has no selection.
X+ If there is no selection in the input formula, the cursor position
X+ is used to identify the subformula to use. If the cursor is not in
X+ the formula proper (e.g., it is in the line number area), select( )
X+ calls are ignored by the rewrite mechanism."
X+ (interactive "sRewrite rule(s): \np")
X+ (calc-slow-wrapper
X+ (calc-preserve-point)
X+ (let* ((num (max 1 (calc-locate-cursor-element (point))))
X+ (reselect t)
X+ (pop-rules nil)
X+ (entry (calc-top num 'entry))
X+ (expr (car entry))
X+ (sel (calc-auto-selection entry))
X+ (math-rewrite-selections t))
X+ (if (or (null rules) (equal rules "") (equal rules "$"))
X+ (if (= num 1)
X+ (error "Can't use same stack entry for formula and rules.")
X+ (setq rules (calc-top-n 1 t)
X+ pop-rules t))
X+ (if (interactive-p) (setq calc-previous-alg-entry rules))
X+ (setq rules (if (stringp rules) (math-read-expr rules) rules))
X+ (if (eq (car-safe rules) 'error)
X+ (error "Bad format in expression: %s" (nth 1 rules)))
X+ (if (eq (car-safe rules) 'vec)
X+ (calc-record rules "rule")))
X+ (and (eq many 0) (setq many 25))
X+ (if sel
X+ (setq expr (calc-replace-sub-formula (car entry)
X+ sel
X+ (list 'calcFunc-select sel)))
X+ (setq expr (car entry)
X+ reselect nil
X+ math-rewrite-selections nil))
X+ (setq expr (calc-encase-atoms
X+ (calc-normalize
X+ (math-rewrite
X+ (calc-normalize expr)
X+ rules many)))
X+ sel nil
X+ expr (calc-locate-select-marker expr))
X+ (or (consp sel) (setq sel nil))
X+ (if pop-rules (calc-pop-stack 1))
X+ (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr)
X+ (- num (if pop-rules 1 0))
X+ (list (and reselect sel))))
X+ (calc-handle-whys))
X+ )
X
X+ (defun calc-locate-select-marker (expr) ; changes "sel"
X+ (if (Math-primp expr)
X+ expr
X+ (if (and (eq (car expr) 'calcFunc-select)
X+ (= (length expr) 2))
X+ (progn
X+ (setq sel (if sel t (nth 1 expr)))
X+ (nth 1 expr))
X+ (cons (car expr)
X+ (mapcar 'calc-locate-select-marker (cdr expr)))))
X+ )
X
X
X ;;;; [calc-ext.el]
X
X+ (defconst calc-tweak-eqn-table '( ( calcFunc-eq calcFunc-eq calcFunc-neq )
X+ ( calcFunc-neq calcFunc-neq calcFunc-eq )
X+ ( calcFunc-lt calcFunc-gt calcFunc-geq )
X+ ( calcFunc-gt calcFunc-lt calcFunc-leq )
X+ ( calcFunc-leq calcFunc-geq calcFunc-gt )
X+ ( calcFunc-geq calcFunc-leq calcFunc-lt ) ))
X+
X+
X+
X+
X ;;; Algebra commands.
X
X (defun calc-a-prefix-help ()
X (interactive)
X (calc-do-prefix-help
X! '("Simplify, Extended-simplify, eVal; eXpand, Collect"
X! "Derivative, Integral, Taylor; suBstitute"
X! "Rewrite, Match"
X! "SHIFT + Solve; Root, miN, maX; Integral-limit"
X "relations: =, # (not =), <, >, [ (< or =), ] (> or =)"
X! "logical: & (and), | (or), ! (not); : (if)"
X! "misc: { (in-set)")
X "algebra" ?a)
X )
X
X ;;;; [calc-alg.el]
X
X+ (defun calc-alg-evaluate ()
X+ "Apply normal (default) simplifications to the formula at top of stack.
X+ This works even if default simplifications have been turned off."
X+ (interactive)
X+ (calc-slow-wrapper
X+ (calc-with-default-simplification
X+ (calc-enter-result 1 "dsmp" (calc-top 1))))
X+ )
X+
X (defun calc-simplify ()
X "Simplify the formula on top of the stack."
X (interactive)
X***************
X*** 1838,1850 ****
X (interactive "sCollect terms involving: ")
X (calc-slow-wrapper
X (if (equal var "")
X! (calc-enter-result 2 "clct" (math-collect-terms (calc-top-n 2)
X! (calc-top-n 1)))
X (let ((var (math-read-expr var)))
X (if (eq (car-safe var) 'error)
X (error "Bad format in expression: %s" (nth 1 var)))
X! (calc-enter-result 1 "clct" (math-collect-terms (calc-top-n 1)
X! var)))))
X )
X
X (defun calc-substitute (&optional oldname newname)
X--- 4083,4096 ----
X (interactive "sCollect terms involving: ")
X (calc-slow-wrapper
X (if (equal var "")
X! (calc-enter-result 2 "clct" (cons 'calcFunc-collect
X! (calc-top-list-n 2)))
X (let ((var (math-read-expr var)))
X (if (eq (car-safe var) 'error)
X (error "Bad format in expression: %s" (nth 1 var)))
X! (calc-enter-result 1 "clct" (list 'calcFunc-collect
X! (calc-top-n 1)
X! var)))))
X )
X
X (defun calc-substitute (&optional oldname newname)
X***************
X*** 1882,1887 ****
X--- 4128,4135 ----
X (calc-enter-result num "sbst" (math-expr-subst expr old new))))
X )
X
X+ ;;;; [calc-rewr.el]
X+
X (defun calc-rewrite (rules many)
X "Perform substitutions in an expression using pattern-based rewrite rules.
X This command prompts for the rule(s) to use, which should be either a
X***************
X*** 1905,1944 ****
X (interactive "sRewrite rule(s): \np")
X (calc-slow-wrapper
X (let (n expr)
X! (if (or (null rules) (equal rules ""))
X (setq expr (calc-top-n 2)
X! rules (calc-top-n 1)
X n 2)
X (setq rules (if (stringp rules) (math-read-expr rules) rules))
X (if (eq (car-safe rules) 'error)
X (error "Bad format in expression: %s" (nth 1 rules)))
X (setq expr (calc-top-n 1)
X n 1))
X (and (eq many 0) (setq many 25))
X! (calc-enter-result n "rwrt" (math-rewrite expr rules many))))
X )
X
X ;;;; [calc-alg-2.el]
X
X! (defun calc-derivative (var)
X "Differentiate the formula on top of the stack with respect to a variable.
X If you enter a blank line, top of stack is the variable, next-to-top is expr.
X With Hyperbolic flag, performs a total derivative: all variables are
X considered to be inter-dependent. Otherwise, all variables except VAR
X! are treated as constant."
X! (interactive "sDifferentiate with respect to: ")
X (calc-slow-wrapper
X! (let ((func (if (calc-is-hyperbolic) 'calcFunc-tderiv 'calcFunc-deriv)))
X (if (equal var "")
X! (calc-enter-result 2 "derv" (list func
X! (calc-top-n 2)
X! (calc-top-n 1)))
X! (let ((var (math-read-expr var)))
X! (if (eq (car-safe var) 'error)
X! (error "Bad format in expression: %s" (nth 1 var)))
X! (calc-enter-result 1 "derv" (list func
X! (calc-top-n 1)
X! var))))))
X )
X
X (defun calc-integral (var)
X--- 4153,4227 ----
X (interactive "sRewrite rule(s): \np")
X (calc-slow-wrapper
X (let (n expr)
X! (if (or (null rules) (equal rules "") (equal rules "$"))
X (setq expr (calc-top-n 2)
X! rules (calc-top-n 1 t)
X n 2)
X+ (if (interactive-p) (setq calc-previous-alg-entry rules))
X (setq rules (if (stringp rules) (math-read-expr rules) rules))
X (if (eq (car-safe rules) 'error)
X (error "Bad format in expression: %s" (nth 1 rules)))
X+ (if (eq (car-safe rules) 'vec)
X+ (calc-record rules "rule"))
X (setq expr (calc-top-n 1)
X n 1))
X (and (eq many 0) (setq many 25))
X! (setq expr (calc-normalize (math-rewrite expr rules many)))
X! (let (sel)
X! (setq expr (calc-locate-select-marker sel)))
X! (calc-pop-push-record-list n "rwrt" (list expr)))
X! (calc-handle-whys))
X! )
X!
X! (defun calc-match (pat)
X! "Extract the elements of a vector which match a rewrite pattern."
X! (interactive "sPattern: \n")
X! (calc-slow-wrapper
X! (let (n expr)
X! (if (or (null pat) (equal pat "") (equal pat "$"))
X! (setq expr (calc-top-n 2)
X! pat (calc-top-n 1)
X! n 2)
X! (if (interactive-p) (setq calc-previous-alg-entry pat))
X! (setq pat (if (stringp pat) (math-read-expr pat) pat))
X! (if (eq (car-safe pat) 'error)
X! (error "Bad format in expression: %s" (nth 1 pat)))
X! (if (not (eq (car-safe pat) 'var))
X! (calc-record pat "pat"))
X! (setq expr (calc-top-n 1)
X! n 1))
X! (or (math-vectorp expr) (error "Argument must be a vector"))
X! (if (calc-is-inverse)
X! (calc-enter-result n "mtcn" (math-match-patterns pat expr t))
X! (calc-enter-result n "mtch" (math-match-patterns pat expr nil)))))
X )
X
X ;;;; [calc-alg-2.el]
X
X! (defun calc-derivative (var num)
X "Differentiate the formula on top of the stack with respect to a variable.
X If you enter a blank line, top of stack is the variable, next-to-top is expr.
X With Hyperbolic flag, performs a total derivative: all variables are
X considered to be inter-dependent. Otherwise, all variables except VAR
X! are treated as constant.
X! With a numeric prefix argument, computes the Nth derivative."
X! (interactive "sDifferentiate with respect to: \np")
X (calc-slow-wrapper
X! (and (< num 0) (error "Order of derivative must be positive"))
X! (let ((func (if (calc-is-hyperbolic) 'calcFunc-tderiv 'calcFunc-deriv))
X! n expr)
X (if (equal var "")
X! (setq n 2
X! expr (calc-top-n 2)
X! var (calc-top-n 1))
X! (setq var (math-read-expr var))
X! (if (eq (car-safe var) 'error)
X! (error "Bad format in expression: %s" (nth 1 var)))
X! (setq n 1
X! expr (calc-top-n 1)))
X! (while (>= (setq num (1- num)) 0)
X! (setq expr (list func expr var)))
X! (calc-enter-result n "derv" expr)))
X )
X
X (defun calc-integral (var)
X***************
X*** 1964,1970 ****
X (interactive "P")
X (calc-wrapper
X (if (consp n)
X! (calc-pop-push-record 0 "prec" calc-integral-limit)
X (if (and (integerp n) (> n 0))
X (progn
X (setq calc-integral-limit (prefix-numeric-value n))
X--- 4247,4253 ----
X (interactive "P")
X (calc-wrapper
X (if (consp n)
X! (calc-pop-push-record 0 "ilim" calc-integral-limit)
X (if (and (integerp n) (> n 0))
X (progn
X (setq calc-integral-limit (prefix-numeric-value n))
X***************
X*** 2011,2016 ****
X--- 4294,4375 ----
X nterms))))
X )
X
X+ (defun calc-find-root (var)
X+ "Find a root of a formula (a point at which the formula is zero).
X+ Given an equation, find a solution to the equation.
X+ You are prompted for the variable for which you wish to solve;
X+ all other variables that appear in the formula must have assigned values.
X+ An initial guess is on top-of-stack; the formula is second to top.
X+ The initial guess can be either a number near the desired root, or
X+ an interval enclosing the desired root. A single number is allowed
X+ only if the function is differentiable.
X+ If you enter a blank line, the variable is taken from top-of-stack,
X+ the guess from level 2, and the equation from level 3.
X+ With Hyperbolic flag, interval may not enclose root; widen if necessary."
X+ (interactive "sVariable(s) to solve for: ")
X+ (calc-slow-wrapper
X+ (let ((func (if (calc-is-hyperbolic) 'calcFunc-wroot 'calcFunc-root)))
X+ (if (equal var "")
X+ (calc-enter-result 2 "root" (list func
X+ (calc-top-n 3)
X+ (calc-top-n 1)
X+ (calc-top-n 2)))
X+ (let ((var (if (and (string-match ",\\|[^ ] [^ ]" var)
X+ (not (string-match "\\[" var)))
X+ (math-read-expr (concat "[" var "]"))
X+ (math-read-expr var))))
X+ (if (eq (car-safe var) 'error)
X+ (error "Bad format in expression: %s" (nth 1 var)))
X+ (calc-enter-result 1 "root" (list func
X+ (calc-top-n 2)
X+ var
X+ (calc-top-n 1)))))))
X+ )
X+
X+ (defun calc-find-minimum (var)
X+ "Find a minimum of a formula numerically.
X+ Given an equation, find a minimum of the righthand side of the equation.
X+ You are prompted for the variable for which you wish to solve;
X+ all other variables that appear in the formula must have assigned values.
X+ An initial guess is on top-of-stack; the formula is second to top.
X+ The initial guess can be either a number near the desired minimum, or
X+ an interval enclosing the desired minimum.
X+ If you enter a blank line, the variable is taken from top-of-stack,
X+ the guess from level 2, and the equation from level 3.
X+ With Hyperbolic flag, interval may not enclose root; widen if necessary.
X+ With Inverse flag, find a maximum instead of a minimum."
X+ (interactive "sVariable(s) to minimize over: ")
X+ (calc-slow-wrapper
X+ (let ((func (if (calc-is-inverse)
X+ (if (calc-is-hyperbolic)
X+ 'calcFunc-wmaximize 'calcFunc-maximize)
X+ (if (calc-is-hyperbolic)
X+ 'calcFunc-wminimize 'calcFunc-minimize)))
X+ (tag (if (calc-is-inverse) "max" "min")))
X+ (if (equal var "")
X+ (calc-enter-result 2 tag (list func
X+ (calc-top-n 3)
X+ (calc-top-n 1)
X+ (calc-top-n 2)))
X+ (let ((var (if (and (string-match ",\\|[^ ] [^ ]" var)
X+ (not (string-match "\\[" var)))
X+ (math-read-expr (concat "[" var "]"))
X+ (math-read-expr var))))
X+ (if (eq (car-safe var) 'error)
X+ (error "Bad format in expression: %s" (nth 1 var)))
X+ (calc-enter-result 1 tag (list func
X+ (calc-top-n 2)
X+ var
X+ (calc-top-n 1)))))))
X+ )
X+
X+ (defun calc-find-maximum (var)
X+ "Find a maximum of a formula numerically. See calc-find-minimum."
X+ (interactive "sVariable to maximize over: ")
X+ (calc-invert-func)
X+ (calc-find-minimum var)
X+ )
X+
X
X ;;;; [calc-prog.el]
X
X***************
X*** 2085,2090 ****
X--- 4444,4456 ----
X (calc-unary-op "lnot" 'calcFunc-lnot arg))
X )
X
X+ (defun calc-logical-if ()
X+ "Compute a ? b : c, i.e., b if a is nonzero, c if a is zero."
X+ (interactive)
X+ (calc-wrapper
X+ (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3))))
X+ )
X+
X
X
X
X***************
X*** 2260,2270 ****
X (defun calc-c-prefix-help ()
X (interactive)
X (calc-do-prefix-help
X! '("Deg, Rad, HMS; Float; Polar; Clean, 1, 2, 3"
X "SHIFT + Fraction")
X "convert" ?c)
X )
X
X (defun calc-clean (n)
X "Clean up the number at the top of the Calculator stack.
X Re-round to current precision, or to that specified by a prefix argument.
X--- 4626,4638 ----
X (defun calc-c-prefix-help ()
X (interactive)
X (calc-do-prefix-help
X! '("Deg, Rad, HMS; Float; Polar/rect; Clean, 1-9"
X "SHIFT + Fraction")
X "convert" ?c)
X )
X
X+ ;;;; [calc-stuff.el]
X+
X (defun calc-clean (n)
X "Clean up the number at the top of the Calculator stack.
X Re-round to current precision, or to that specified by a prefix argument.
X***************
X*** 2283,2306 ****
X (list 'calcFunc-clean (calc-top-n 1))))))
X )
X
X! (defun calc-clean-1 ()
X! "Clean up the number on the top of the stack by rounding off one digit."
X! (interactive)
X! (calc-clean -1)
X! )
X!
X! (defun calc-clean-2 ()
X! "Clean up the number on the top of the stack by rounding off two digits."
X! (interactive)
X! (calc-clean -2)
X! )
X!
X! (defun calc-clean-3 ()
X! "Clean up the number on the top of the stack by rounding off three digits."
X! (interactive)
X! (calc-clean -3)
X )
X
X (defun calc-float (arg)
X "Convert the top element of the Calculator stack to floating-point form."
X (interactive "P")
X--- 4651,4669 ----
X (list 'calcFunc-clean (calc-top-n 1))))))
X )
X
X! (defun calc-clean-num (num)
X! "Clean up the number on the top of the stack by rounding off N digits."
X! (interactive "P")
X! (calc-clean (- (if num
X! (prefix-numeric-value num)
X! (if (and (>= last-command-char ?1)
X! (<= last-command-char ?9))
X! (- last-command-char ?0)
X! (error "Number required")))))
X )
X
X+ ;;;; [calc-ext.el]
X+
X (defun calc-float (arg)
X "Convert the top element of the Calculator stack to floating-point form."
X (interactive "P")
X***************
X*** 2395,2401 ****
X '("Group, \",\"; Normal, Fix, Sci, Eng, \".\""
X "Radix, Zeros, 2, 8, 0, 6; Over; Hms; Complex, I, J"
X "Why; Line-nums, line-Breaks; <, =, > (justify)"
X! "Truncate, [, ]; ` (align); ~ (refresh)"
X "SHIFT + language: Normal, One-line, Big, Unformatted"
X "SHIFT + language: C, Pascal, Fortran, TeX, Mathematica")
X "display" ?d)
X--- 4758,4764 ----
X '("Group, \",\"; Normal, Fix, Sci, Eng, \".\""
X "Radix, Zeros, 2, 8, 0, 6; Over; Hms; Complex, I, J"
X "Why; Line-nums, line-Breaks; <, =, > (justify)"
X! "\" (strings); Truncate, [, ]; ` (align); ~ (refresh)"
X "SHIFT + language: Normal, One-line, Big, Unformatted"
X "SHIFT + language: C, Pascal, Fortran, TeX, Mathematica")
X "display" ?d)
X***************
X*** 2472,2480 ****
X (setq calc-line-breaking (if n
X (> (prefix-numeric-value n) 0)
X (not calc-line-breaking)))
X! (calc-refresh))
X )
X
X (defun calc-display-strings (n)
X "Toggle display of vectors of byte-sized integers as strings.
X With positive numeric prefix, turn mode on.
X--- 4835,4848 ----
X (setq calc-line-breaking (if n
X (> (prefix-numeric-value n) 0)
X (not calc-line-breaking)))
X! (calc-refresh)
X! (message (if calc-line-breaking
X! "Breaking long lines in Stack display."
SHAR_EOF
echo "End of part 5, continue with part 6"
echo "6" > s2_seq_.tmp
exit 0