v15i037: Patch for GNU Emacs Calc, version 1.04 -> 1.05, part 10/20
David Gillespie
daveg at csvax.cs.caltech.edu
Mon Oct 15 11:18:11 AEST 1990
Posting-number: Volume 15, Issue 37
Submitted-by: daveg at csvax.cs.caltech.edu (David Gillespie)
Archive-name: calc-1.05/part10
#!/bin/sh
# this is part 10 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc.patch continued
#
CurArch=10
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! (= (length expr) 2)
X! (setq expr (nth 1 expr))))
X! (let ((reg (math-rwcomp-reg)))
X! (setcar (nthcdr 3 (car math-regs)) expr)
X! (math-rwcomp-same-instr part reg nil)))
X! ((eq (car expr) 'var)
X! (let ((entry (assq (nth 2 expr) math-regs)))
X! (if entry
X! (math-rwcomp-same-instr part (nth 1 entry) nil)
X! (setcar (math-rwcomp-reg-entry part) (nth 2 expr))
X! (let ((cond math-conds))
X! (while cond
X! (if (math-rwcomp-all-regs-done (car cond))
X! (progn
X! (math-rwcomp-cond-instr (car cond))
X! (setq math-conds (delq (car cond) math-conds))))
X! (setq cond (cdr cond)))))))
X! ((and (eq (car expr) 'calcFunc-select)
X! (= (length expr) 2))
X! (let ((reg (math-rwcomp-reg)))
X! (math-rwcomp-instr 'select part reg)
X! (math-rwcomp-pattern (nth 1 expr) reg)))
X! ((and (eq (car expr) 'calcFunc-opt)
X! (memq (length expr) '(2 3)))
X! (error "opt( ) occurs in context where it is not allowed"))
X! ((eq (car expr) 'neg)
X! (if (eq (car (nth 1 expr)) 'var)
X! (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
X! (if entry
X! (math-rwcomp-same-instr part (nth 1 entry) t)
X! (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
X! (math-rwcomp-pattern (nth 1 expr) part)))
X! (if (math-rwcomp-is-algebraic (nth 1 expr))
X! (math-rwcomp-cond-instr (list 'calcFunc-eq
X! (math-rwcomp-register-expr part)
X! expr))
X! (let ((reg (math-rwcomp-reg)))
X! (math-rwcomp-instr 'func part 'neg reg)
X! (math-rwcomp-pattern (nth 1 expr) reg)))))
X! ((and (eq (car expr) 'calcFunc-apply)
X! (= (length expr) 3))
X! (let ((reg1 (math-rwcomp-reg))
X! (reg2 (math-rwcomp-reg)))
X! (math-rwcomp-instr 'apply part reg1 reg2)
X! (math-rwcomp-pattern (nth 1 expr) reg1)
X! (math-rwcomp-pattern (nth 2 expr) reg2)))
X! ((and (eq (car expr) 'calcFunc-cons)
X! (= (length expr) 3))
X! (let ((reg1 (math-rwcomp-reg))
X! (reg2 (math-rwcomp-reg)))
X! (math-rwcomp-instr 'cons part reg1 reg2)
X! (math-rwcomp-pattern (nth 1 expr) reg1)
X! (math-rwcomp-pattern (nth 2 expr) reg2)))
X! ((and (eq (car expr) 'calcFunc-condition)
X! (>= (length expr) 3))
X! (math-rwcomp-pattern (nth 1 expr) part)
X! (setq expr (cdr expr))
X! (while (setq expr (cdr expr))
X! (let ((cond (car expr)))
X! (if (and (eq (car-safe cond) 'calcFunc-quote)
X! (= (length cond) 2))
X! (setq cond (nth 1 cond)))
X! (while (eq (car-safe cond) 'calcFunc-land)
X! (if (math-rwcomp-all-regs-done (nth 2 cond))
X! (math-rwcomp-cond-instr (nth 2 cond))
X! (setq math-conds (cons (nth 2 cond) math-conds)))
X! (setq cond (nth 1 cond)))
X! (if (math-rwcomp-all-regs-done cond)
X! (math-rwcomp-cond-instr cond)
X! (setq math-conds (cons cond math-conds))))))
X! (t (let ((props (get (car expr) 'math-rewrite-props)))
X! (if (and (eq (car expr) 'calcFunc-plain)
X! (= (length expr) 2)
X! (not (math-primp (nth 1 expr))))
X! (setq expr (nth 1 expr))) ; but "props" is still nil
X! (if (and (memq 'algebraic props)
X! (math-rwcomp-is-algebraic expr))
X! (math-rwcomp-cond-instr (list 'calcFunc-eq
X! (math-rwcomp-register-expr part)
X! expr))
X! (if (and (memq 'commut props)
X! (= (length expr) 3))
X! (let ((arg1 (cons (nth 1 expr) (math-rwcomp-reg)))
X! (arg2 (cons (nth 2 expr) (math-rwcomp-reg)))
X! try1 def code head)
X! (if (eq (car expr) '-)
X! (setcar arg2 (math-rwcomp-neg (car arg2))))
X! (or (math-rwcomp-order arg1 arg2)
X! (setq def arg1 arg1 arg2 arg2 def))
X! (if (math-rwcomp-optional-arg (car expr) arg1)
X! (error "Too many opt( ) arguments in this context"))
X! (setq def (math-rwcomp-optional-arg (car expr) arg2)
X! head (if (memq (car expr) '(+ -))
X! '(+ -) (list (car expr)))
X! code (if (math-rwcomp-is-constrained
X! (car arg1) (nth 2 try1))
X! (if (math-rwcomp-is-constrained
X! (car arg2) (nth 2 try1))
X! 0 1)
X! 2))
X! (math-rwcomp-multi-instr (and def (list def))
X! 'try part head
X! (vector nil nil nil code)
X! (cdr arg1))
X! (setq try1 (car math-prog))
X! (math-rwcomp-pattern (car arg1) (cdr arg1))
X! (math-rwcomp-instr 'try2 try1 (cdr arg2))
X! (if (and (= part 0) (not def) (not math-rewrite-whole)
X! (setq def (get (car expr)
X! 'math-rewrite-default)))
X! (let ((reg1 (math-rwcomp-reg))
X! (reg2 (math-rwcomp-reg)))
X! (if (= (aref (nth 3 try1) 3) 0)
X! (aset (nth 3 try1) 3 1))
X! (math-rwcomp-instr 'try (cdr arg2) head
X! (vector nil nil nil
X! (if (= code 0)
X! 1 2))
X! reg1 def)
X! (setq try1 (car math-prog))
X! (math-rwcomp-pattern (car arg2) reg1)
X! (math-rwcomp-instr 'try2 try1 reg2)
X! (setq math-rhs (list (if (eq (car expr) '-)
X! '+ (car expr))
X! math-rhs
X! (list 'calcFunc-register
X! reg2))))
X! (math-rwcomp-pattern (car arg2) (cdr arg2))))
X! (let* ((args (mapcar (function
X! (lambda (x) (cons x (math-rwcomp-reg))))
X! (cdr expr)))
X! (args2 (copy-sequence args))
X! (argp (reverse args2))
X! (defs nil)
X! (num 1))
X! (while argp
X! (let ((def (math-rwcomp-optional-arg (car expr)
X! (car argp))))
X! (if def
X! (progn
X! (setq args2 (delq (car argp) args2)
X! defs (cons (cons def (cdr (car argp)))
X! defs))
X! (math-rwcomp-multi-instr
X! (mapcar 'cdr args2)
X! (if (or (and (memq 'unary1 props)
X! (= (length args2) 1)
X! (eq (car args2) (car args)))
X! (and (memq 'unary2 props)
X! (= (length args) 2)
X! (eq (car args2) (nth 1 args))))
X! 'func-opt
X! 'func-def)
X! part (car expr)
X! defs))))
X! (setq argp (cdr argp)))
X! (math-rwcomp-multi-instr (mapcar 'cdr args)
X! 'func part (car expr))
X! (setq args (sort args 'math-rwcomp-order))
X! (while args
X! (math-rwcomp-pattern (car (car args)) (cdr (car args)))
X! (setq num (1+ num)
X! args (cdr args)))))))))
X! )
X!
X! (defun math-rwcomp-all-regs-done (expr)
X! (if (Math-primp expr)
X! (or (not (eq (car-safe expr) 'var))
X! (assq (nth 2 expr) math-regs))
X! (while (and (setq expr (cdr expr))
X! (math-rwcomp-all-regs-done (car expr))))
X! (null expr))
X! )
X!
X! (defun math-rwcomp-no-vars (expr)
X! (if (Math-primp expr)
X! (or (not (eq (car-safe expr) 'var))
X! (math-const-var expr))
X! (while (and (setq expr (cdr expr))
X! (math-rwcomp-no-vars (car expr))))
X! (null expr))
X! )
X!
X! (defun math-rwcomp-is-algebraic (expr)
X! (if (Math-primp expr)
X! (or (not (eq (car-safe expr) 'var))
X! (math-const-var expr)
X! (assq (nth 2 expr) math-regs))
X! (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
X! (progn
X! (while (and (setq expr (cdr expr))
X! (math-rwcomp-is-algebraic (car expr))))
X! (null expr))))
X! )
X!
X! (defun math-rwcomp-is-constrained (expr not-these)
X! (if (Math-primp expr)
X! (not (eq (car-safe expr) 'var))
X! (if (eq (car expr) 'calcFunc-plain)
X! (math-rwcomp-is-constrained (nth 1 expr) not-these)
X! (not (or (memq (car expr) '(neg calcFunc-select))
X! (memq (car expr) not-these)
X! (and (memq 'commut (get (car expr) 'math-rewrite-props))
X! (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
X! (eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
X! )
X!
X! (defun math-rwcomp-optional-arg (head argp)
X! (let ((arg (car argp)))
X! (if (eq (car-safe arg) 'calcFunc-opt)
X! (and (memq (length arg) '(2 3))
X! (progn
X! (or (eq (car-safe (nth 1 arg)) 'var)
X! (error "First argument of opt( ) must be a variable"))
X! (setcar argp (nth 1 arg))
X! (if (= (length arg) 2)
X! (or (get head 'math-rewrite-default)
X! (error "opt( ) must include a default in this context"))
X! (nth 2 arg))))
X! (and (eq (car-safe arg) 'neg)
X! (let* ((part (list (nth 1 arg)))
X! (partp (math-rwcomp-optional-arg head part)))
X! (and partp
X! (setcar argp (math-rwcomp-neg (car part)))
X! (math-neg partp))))))
X )
X
X+ (defun math-rwcomp-neg (expr)
X+ (if (memq (car-safe expr) '(* /))
X+ (if (eq (car-safe (nth 1 expr)) 'var)
X+ (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
X+ (if (eq (car-safe (nth 2 expr)) 'var)
X+ (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
X+ (math-neg expr)))
X+ (math-neg expr))
X+ )
X+
X+ (defun math-rwcomp-assoc-args (expr)
X+ (if (and (eq (car-safe (nth 1 expr)) (car expr))
X+ (= (length (nth 1 expr)) 3))
X+ (math-rwcomp-assoc-args (nth 1 expr))
X+ (setq math-args (cons (nth 1 expr) math-args)))
X+ (if (and (eq (car-safe (nth 2 expr)) (car expr))
X+ (= (length (nth 2 expr)) 3))
X+ (math-rwcomp-assoc-args (nth 2 expr))
X+ (setq math-args (cons (nth 2 expr) math-args)))
X+ )
X+
X+ (defun math-rwcomp-addsub-args (expr)
X+ (if (memq (car-safe (nth 1 expr)) '(+ -))
X+ (math-rwcomp-addsub-args (nth 1 expr))
X+ (setq math-args (cons (nth 1 expr) math-args)))
X+ (if (eq (car expr) '-)
X+ (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
X+ (if (eq (car-safe (nth 2 expr)) '+)
X+ (math-rwcomp-addsub-args (nth 2 expr))
X+ (setq math-args (cons (nth 2 expr) math-args))))
X+ )
X+
X+ (defun math-rwcomp-order (a b)
X+ (< (math-rwcomp-priority (car a))
X+ (math-rwcomp-priority (car b)))
X+ )
X+
X+ ;;; Order of priority: 0 Constants and other exact matches (first)
X+ ;;; 10 Functions (except below)
X+ ;;; 20 Meta-variables which occur more than once
X+ ;;; 30 Algebraic functions
X+ ;;; 40 Commutative/associative functions
X+ ;;; 50 Meta-variables which occur only once
X+ ;;; 100 Optional arguments (last)
X+
X+ (defun math-rwcomp-priority (expr)
X+ (cond ((eq (car-safe expr) 'calcFunc-opt)
X+ 100)
X+ ((math-rwcomp-no-vars expr)
X+ 0)
X+ ((eq (car expr) 'calcFunc-quote)
X+ 0)
X+ ((eq (car expr) 'var)
X+ (if (assq (nth 2 expr) math-regs)
X+ 0
X+ (if (= (math-expr-contains math-pattern expr) 1)
X+ 50
X+ 20)))
X+ (t (let ((props (get (car expr) 'math-rewrite-props)))
X+ (if (or (memq 'commut props)
X+ (memq 'assoc props))
X+ 40
X+ (if (memq 'algebraic props)
X+ 30
X+ 10)))))
X+ )
X+
X+ ;;; In the current implementation, all associative functions must
X+ ;;; also be commutative.
X+
X+ (put '+ 'math-rewrite-props '(algebraic assoc commut))
X+ (put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
X+ (put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below
X+ (put '/ 'math-rewrite-props '(algebraic unary1))
X+ (put '^ 'math-rewrite-props '(algebraic unary1))
X+ (put '% 'math-rewrite-props '(algebraic))
X+ (put 'neg 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-idiv 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-abs 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-sign 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-round 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-ceil 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-re 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-im 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-conj 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-arg 'math-rewrite-props '(algebraic))
X+ (put 'calcFunc-and 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-or 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-xor 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-eq 'math-rewrite-props '(commut))
X+ (put 'calcFunc-neq 'math-rewrite-props '(commut))
X+ (put 'calcFunc-land 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-lor 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-beta 'math-rewrite-props '(commut))
X+ (put 'calcFunc-gcd 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
X+ (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
X+ (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
X+
X+ ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
X+ ;;; Also, "-" is not commutative but the code tweaks things so that it is.
X+
X+ (put '+ 'math-rewrite-default 0)
X+ (put '- 'math-rewrite-default 0)
X+ (put '* 'math-rewrite-default 1)
X+ (put '/ 'math-rewrite-default 1)
X+ (put '^ 'math-rewrite-default 1)
X+ (put 'calcFunc-land 'math-rewrite-default 1)
X+ (put 'calcFunc-lor 'math-rewrite-default 0)
X+
X+ (defmacro math-rwfail (&optional back)
X+ (list 'setq 'pc
X+ (list 'and
X+ (if back
X+ '(setq btrack (cdr btrack))
X+ 'btrack)
X+ ''((backtrack))))
X+ )
X+
X+ (defun math-apply-rewrites (expr rules &optional heads)
X+ (and
X+ (setq rules (cdr (or (assq (car-safe expr) rules)
X+ (assq nil rules))))
X+ (let ((result nil)
X+ op regs inst part pc mark btrack
X+ (tracing math-rwcomp-tracing))
X+ (while rules
X+ (or
X+ (and (setq part (nth 2 (car rules)))
X+ heads
X+ (not (memq part heads)))
X+ (progn
X+ (setq regs (car (car rules))
X+ pc (nth 1 (car rules))
X+ btrack nil)
X+ (aset regs 0 expr)
X+ (while pc
X+
X+ (and tracing
X+ (progn (terpri) (princ (car pc))
X+ (if (and (natnump (nth 1 (car pc)))
X+ (< (nth 1 (car pc)) (length regs)))
X+ (princ (format "\n part = %s"
X+ (aref regs (nth 1 (car pc))))))))
X+
X+ (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
X+ (if (and (consp (setq part (aref regs (car (cdr inst)))))
X+ (eq (car part)
X+ (car (setq inst (cdr (cdr inst)))))
X+ (progn
X+ (while (and (setq inst (cdr inst)
X+ part (cdr part))
X+ inst)
X+ (aset regs (car inst) (car part)))
X+ (not (or inst part))))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'same)
X+ (if (math-equal (aref regs (nth 1 inst))
X+ (aref regs (nth 2 inst)))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'try)
X+ (if (and (consp (setq part (aref regs (car (cdr inst)))))
X+ (memq (car part) (nth 2 inst))
X+ (= (length part) 3))
X+ (progn
X+ (setq op nil
X+ mark (car (cdr (setq inst (cdr (cdr inst))))))
X+ (and
X+ (memq 'assoc (get (car part)
X+ 'math-rewrite-props))
X+ (not (= (aref mark 3) 0))
X+ (while (if (and (consp (nth 1 part))
X+ (memq (car (nth 1 part))
X+ (car inst)))
X+ (setq op (cons (if (eq (car part) '-)
X+ (math-rwapply-neg
X+ (nth 2 part))
X+ (nth 2 part))
X+ op)
X+ part (nth 1 part))
X+ (if (and (consp (nth 2 part))
X+ (memq (car (nth 2 part))
X+ (car inst))
X+ (not (eq (car (nth 2 part)) '-)))
X+ (setq op (cons (nth 1 part) op)
X+ part (nth 2 part))))))
X+ (setq op (cons (nth 1 part)
X+ (cons (if (eq (car part) '-)
X+ (math-rwapply-neg
X+ (nth 2 part))
X+ (nth 2 part))
X+ op))
X+ btrack (cons pc btrack)
X+ pc (cdr pc))
X+ (aset regs (nth 2 inst) (car op))
X+ (aset mark 0 op)
X+ (aset mark 1 op)
X+ (aset mark 2 (if (cdr (cdr op)) 1 0)))
X+ (if (nth 5 inst)
X+ (if (and (consp part)
X+ (eq (car part) 'neg)
X+ (eq (car (nth 2 inst)) '*)
X+ (eq (nth 5 inst) 1))
X+ (progn
X+ (setq mark (nth 3 inst)
X+ pc (cdr pc))
X+ (aset regs (nth 4 inst) (nth 1 part))
X+ (aset mark 1 -1)
X+ (aset mark 2 4))
X+ (setq mark (nth 3 inst)
X+ pc (cdr pc))
X+ (aset regs (nth 4 inst) part)
X+ (aset mark 2 3))
X+ (math-rwfail))))
X+
X+ ((eq op 'try2)
X+ (setq part (nth 1 inst) ; try instr
X+ mark (nth 3 part)
X+ op (aref mark 2)
X+ pc (cdr pc))
X+ (aset regs (nth 2 inst)
X+ (cond
X+ ((eq op 0)
X+ (if (eq (aref mark 0) (aref mark 1))
X+ (nth 1 (aref mark 0))
X+ (car (aref mark 0))))
X+ ((eq op 1)
X+ (setq mark (delq (car (aref mark 1))
X+ (copy-sequence (aref mark 0)))
X+ op (car (nth 2 part)))
X+ (if (eq op '*)
X+ (progn
X+ (setq mark (nreverse mark)
X+ part (list '* (nth 1 mark) (car mark))
X+ mark (cdr mark))
X+ (while (setq mark (cdr mark))
X+ (setq part (list '* (car mark) part))))
X+ (setq part (car mark)
X+ mark (cdr mark)
X+ part (if (and (eq op '+)
X+ (consp (car mark))
X+ (eq (car (car mark)) 'neg))
X+ (list '- part
X+ (nth 1 (car mark)))
X+ (list op part (car mark))))
X+ (while (setq mark (cdr mark))
X+ (setq part (if (and (eq op '+)
X+ (consp (car mark))
X+ (eq (car (car mark)) 'neg))
X+ (list '- part
X+ (nth 1 (car mark)))
X+ (list op part (car mark))))))
X+ part)
X+ ((eq op 2)
X+ (car (aref mark 1)))
X+ ((eq op 3) (nth 5 part))
X+ (t (aref mark 1)))))
X+
X+ ((eq op 'select)
X+ (setq pc (cdr pc))
X+ (if (and (consp (setq part (aref regs (nth 1 inst))))
X+ (eq (car part) 'calcFunc-select))
X+ (aset regs (nth 2 inst) (nth 1 part))
X+ (if math-rewrite-selections
X+ (math-rwfail)
X+ (aset regs (nth 2 inst) part))))
X+
X+ ((eq op 'cond)
X+ (if (math-is-true
X+ (math-simplify
X+ (math-rwapply-replace-regs (nth 1 inst))))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'same-neg)
X+ (if (math-equal (aref regs (nth 1 inst))
X+ (math-neg (aref regs (nth 2 inst))))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'backtrack)
X+ (setq inst (car (car btrack)) ; try instr
X+ pc (cdr (car btrack))
X+ mark (nth 3 inst)
X+ op (aref mark 2))
X+ (cond ((eq op 0)
X+ (if (setq op (cdr (aref mark 1)))
X+ (aset regs (nth 4 inst) (car (aset mark 1 op)))
X+ (if (nth 5 inst)
X+ (progn
X+ (aset mark 2 3)
X+ (aset regs (nth 4 inst)
X+ (aref regs (nth 1 inst))))
X+ (math-rwfail t))))
X+ ((eq op 1)
X+ (if (setq op (cdr (aref mark 1)))
X+ (aset regs (nth 4 inst) (car (aset mark 1 op)))
X+ (if (= (aref mark 3) 1)
X+ (if (nth 5 inst)
X+ (progn
X+ (aset mark 2 3)
X+ (aset regs (nth 4 inst)
X+ (aref regs (nth 1 inst))))
X+ (math-rwfail t))
X+ (aset mark 2 2)
X+ (aset mark 1 (cons nil (aref mark 0)))
X+ (math-rwfail))))
X+ ((eq op 2)
X+ (if (setq op (cdr (aref mark 1)))
X+ (progn
X+ (setq mark (delq (car (aset mark 1 op))
X+ (copy-sequence
X+ (aref mark 0)))
X+ op (car (nth 2 inst)))
X+ (if (eq op '*)
X+ (progn
X+ (setq mark (nreverse mark)
X+ part (list '* (nth 1 mark)
X+ (car mark))
X+ mark (cdr mark))
X+ (while (setq mark (cdr mark))
X+ (setq part (list '* (car mark)
X+ part))))
X+ (setq part (car mark)
X+ mark (cdr mark)
X+ part (if (and (eq op '+)
X+ (consp (car mark))
X+ (eq (car (car mark))
X+ 'neg))
X+ (list '- part
X+ (nth 1 (car mark)))
X+ (list op part (car mark))))
X+ (while (setq mark (cdr mark))
X+ (setq part (if (and (eq op '+)
X+ (consp (car mark))
X+ (eq (car (car mark))
X+ 'neg))
X+ (list '- part
X+ (nth 1 (car mark)))
X+ (list op part (car mark))))))
X+ (aset regs (nth 4 inst) part))
X+ (if (nth 5 inst)
X+ (progn
X+ (aset mark 2 3)
X+ (aset regs (nth 4 inst)
X+ (aref regs (nth 1 inst))))
X+ (math-rwfail t))))
X+ (t (math-rwfail t))))
X+
X+ ((eq op 'integer)
X+ (if (Math-integerp (aref regs (nth 1 inst)))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'real)
X+ (if (Math-realp (aref regs (nth 1 inst)))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'constant)
X+ (if (math-constp (aref regs (nth 1 inst)))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'negative)
X+ (if (math-looks-negp (aref regs (nth 1 inst)))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'rel)
X+ (setq part (math-compare (aref regs (nth 1 inst))
X+ (aref regs (nth 3 inst)))
X+ op (nth 2 inst))
X+ (if (cond ((eq op 'calcFunc-eq)
X+ (= part 0))
X+ ((eq op 'calcFunc-neq)
X+ (memq part '(-1 1)))
X+ ((eq op 'calcFunc-lt)
X+ (= part -1))
X+ ((eq op 'calcFunc-leq)
X+ (memq part '(0 1)))
X+ ((eq op 'calcFunc-gt)
X+ (= part 1))
X+ ((eq op 'calcFunc-geq)
X+ (memq part '(-1 0))))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'func-def)
X+ (if (and (consp (setq part (aref regs (car (cdr inst)))))
X+ (eq (car part)
X+ (car (setq inst (cdr (cdr inst))))))
X+ (progn
X+ (setq inst (cdr inst)
X+ mark (car inst))
X+ (while (and (setq inst (cdr inst)
X+ part (cdr part))
X+ inst)
X+ (aset regs (car inst) (car part)))
X+ (if (or inst part)
X+ (setq pc (cdr pc))
X+ (while (eq (car (car (setq pc (cdr pc))))
X+ 'func-def))
X+ (setq pc (cdr pc)) ; skip over "func"
X+ (while mark
X+ (aset regs (cdr (car mark)) (car (car mark)))
X+ (setq mark (cdr mark)))))
X+ (math-rwfail)))
X+
X+ ((eq op 'func-opt)
X+ (if (or (not (and (consp
X+ (setq part (aref regs (car (cdr inst)))))
X+ (eq (car part) (nth 2 inst))))
X+ (and (= (length part) 2)
X+ (setq part (nth 1 part))))
X+ (progn
X+ (setq mark (nth 3 inst))
X+ (aset regs (nth 4 inst) part)
X+ (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
X+ (setq pc (cdr pc)) ; skip over "func"
X+ (while mark
X+ (aset regs (cdr (car mark)) (car (car mark)))
X+ (setq mark (cdr mark))))
X+ (setq pc (cdr pc))))
X+
X+ ((eq op 'mod)
X+ (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
X+ (Math-zerop (nth 3 inst))
X+ (and (Math-anglep part)
X+ (Math-anglep (nth 2 inst))
X+ (not (Math-zerop (nth 2 inst)))
X+ (math-equal (math-mod part (nth 2 inst))
X+ (nth 3 inst))))
X+ (setq pc (cdr pc))
X+ (math-rwfail)))
X+
X+ ((eq op 'apply)
X+ (if (and (consp (setq part (aref regs (car (cdr inst)))))
X+ (not (Math-objvecp part)))
X+ (progn
X+ (aset regs (nth 2 inst)
X+ (math-calcFunc-to-var (car part)))
X+ (aset regs (nth 3 inst)
X+ (cons 'vec (cdr part)))
X+ (setq pc (cdr pc)))
X+ (math-rwfail)))
X+
X+ ((eq op 'cons)
X+ (if (and (consp (setq part (aref regs (car (cdr inst)))))
X+ (eq (car part) 'vec)
X+ (cdr part))
X+ (progn
X+ (aset regs (nth 2 inst) (nth 1 part))
X+ (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
X+ (setq pc (cdr pc)))
X+ (math-rwfail)))
X+
X+ ((eq op 'done)
X+ (setq result (math-rwapply-replace-regs (nth 1 inst)))
X+ (if (or (and (eq (car-safe result) '+)
X+ (eq (nth 2 result) 0))
X+ (and (eq (car-safe result) '*)
X+ (eq (nth 2 result) 1)))
X+ (setq result (nth 1 result)))
X+ (if (equal (setq result (math-normalize result)) expr)
X+ (setq result nil)
X+ (setq rules nil))
X+ (setq pc nil))
X+
X+ (t (error "%s is not a valid rewrite opcode" op))))))
X+ (setq rules (cdr rules)))
X+ result))
X+ )
X+
X+ (defun math-rwapply-neg (expr)
X+ (if (and (consp expr)
X+ (memq (car expr) '(* /)))
X+ (list (car expr) (list '* -1 (nth 1 expr)) (nth 2 expr))
X+ (math-neg expr))
X+ )
X+
X+ (defun math-rwapply-replace-regs (expr)
X+ (cond ((Math-primp expr)
X+ expr)
X+ ((eq (car expr) 'calcFunc-register)
X+ (setq expr (aref regs (nth 1 expr)))
X+ (if (eq (car-safe expr) '*)
X+ (if (eq (nth 1 expr) -1)
X+ (math-neg (nth 2 expr))
X+ (if (eq (nth 1 expr) 1)
X+ (nth 2 expr)
X+ expr))
X+ expr))
X+ ((and (eq (car expr) 'calcFunc-eval)
X+ (= (length expr) 2))
X+ (calc-with-default-simplification
X+ (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
X+ ((and (eq (car expr) 'calcFunc-evalsimp)
X+ (= (length expr) 2))
X+ (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
X+ ((and (eq (car expr) 'calcFunc-apply)
X+ (= (length expr) 3))
X+ (let ((func (math-rwapply-replace-regs (nth 1 expr)))
X+ (args (math-rwapply-replace-regs (nth 2 expr)))
X+ call)
X+ (if (and (math-vectorp args)
X+ (not (eq (car-safe (setq call (math-build-call
X+ (math-var-to-calcFunc func)
X+ (cdr args))))
X+ 'calcFunc-call)))
X+ call
X+ (list 'calcFunc-apply func args))))
X+ ((and (eq (car expr) 'calcFunc-cons)
X+ (= (length expr) 3))
X+ (let ((head (math-rwapply-replace-regs (nth 1 expr)))
X+ (tail (math-rwapply-replace-regs (nth 2 expr))))
X+ (if (math-vectorp tail)
X+ (cons 'vec (cons head (cdr tail)))
X+ (list 'calcFunc-cons head tail))))
X+ ((and (eq (car expr) 'neg)
X+ (math-rwapply-reg-looks-negp (nth 1 expr)))
X+ (math-rwapply-reg-neg (nth 1 expr)))
X+ ((and (eq (car expr) 'neg)
X+ (eq (car-safe (nth 1 expr)) 'calcFunc-register)
X+ (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
X+ (math-neg (math-rwapply-replace-regs (nth 1 expr))))
X+ ((and (eq (car expr) '+)
X+ (math-rwapply-reg-looks-negp (nth 1 expr)))
X+ (list '- (math-rwapply-replace-regs (nth 2 expr))
X+ (math-rwapply-reg-neg (nth 1 expr))))
X+ ((and (eq (car expr) '+)
X+ (math-rwapply-reg-looks-negp (nth 2 expr)))
X+ (list '- (math-rwapply-replace-regs (nth 1 expr))
X+ (math-rwapply-reg-neg (nth 2 expr))))
X+ ((and (eq (car expr) '-)
X+ (math-rwapply-reg-looks-negp (nth 2 expr)))
X+ (list '+ (math-rwapply-replace-regs (nth 1 expr))
X+ (math-rwapply-reg-neg (nth 2 expr))))
X+ ((and (eq (car expr) '*)
X+ (eq (nth 1 expr) -1))
X+ (if (math-rwapply-reg-looks-negp (nth 2 expr))
X+ (math-rwapply-reg-neg (nth 2 expr))
X+ (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
X+ ((and (eq (car expr) '*)
X+ (eq (nth 1 expr) 1))
X+ (math-rwapply-replace-regs (nth 2 expr)))
X+ ((and (eq (car expr) '*)
X+ (eq (nth 2 expr) -1))
X+ (if (math-rwapply-reg-looks-negp (nth 1 expr))
X+ (math-rwapply-reg-neg (nth 1 expr))
X+ (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
X+ ((and (eq (car expr) '*)
X+ (eq (nth 2 expr) 1))
X+ (math-rwapply-replace-regs (nth 1 expr)))
X+ ((and (eq (car expr) 'calcFunc-plain)
X+ (= (length expr) 2))
X+ (if (Math-primp (nth 1 expr))
X+ (nth 1 expr)
X+ (if (eq (car (nth 1 expr)) 'calcFunc-register)
X+ (aref regs (nth 1 (nth 1 expr)))
X+ (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
X+ (cdr (nth 1 expr)))))))
X+ (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
X+ )
X+
X+ (defun math-rwapply-reg-looks-negp (expr)
X+ (if (eq (car-safe expr) 'calcFunc-register)
X+ (math-looks-negp (aref regs (nth 1 expr)))
X+ (if (memq (car-safe expr) '(* /))
X+ (or (math-rwapply-reg-looks-negp (nth 1 expr))
X+ (math-rwapply-reg-looks-negp (nth 2 expr)))))
X+ )
X+
X+ (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
X+ (if (eq (car expr) 'calcFunc-register)
X+ (math-neg (math-rwapply-replace-regs expr))
X+ (if (math-rwapply-reg-looks-negp (nth 1 expr))
X+ (math-rwapply-replace-regs (cons (car expr)
X+ (math-rwapply-reg-neg (nth 1 expr))
X+ (nth 2 expr)))
X+ (math-rwapply-replace-regs (cons (car expr)
X+ (nth 1 expr)
X+ (math-rwapply-reg-neg (nth 2 expr))))))
X+ )
X+
X+
X+
X+
X ;;;; [calc-ext.el]
X
X+ (setq math-rewrite-selections nil)
X+
X (defun math-is-true (expr)
X (and (Math-realp expr)
X (not (Math-zerop expr)))
X )
X
X+ (defun math-const-var (expr)
X+ (and (consp expr)
X+ (eq (car expr) 'var)
X+ (boundp (nth 2 expr))
X+ (eq (car-safe (symbol-value (nth 2 expr))) 'special-const))
X+ )
X
X
X
X***************
X*** 11720,11726 ****
X ((or (Math-scalarp expr)
X (eq (car expr) 'sdev)
X (and (eq (car expr) 'var)
X! (not deriv-total)))
X 0)
X ((eq (car expr) '+)
X (math-add (math-derivative (nth 1 expr))
X--- 18640,18647 ----
X ((or (Math-scalarp expr)
X (eq (car expr) 'sdev)
X (and (eq (car expr) 'var)
X! (or (not deriv-total)
X! (math-const-var expr))))
X 0)
X ((eq (car expr) '+)
X (math-add (math-derivative (nth 1 expr))
X***************
X*** 11760,11808 ****
X (math-derivative (nth 1 expr))) ; a reasonable definition
X ((eq (car expr) 'vec)
X (math-map-vec 'math-derivative expr))
X! ((and (eq (car expr) 'calcFunc-log)
X! (= (length expr) 3)
X! (not (Math-zerop (nth 2 expr))))
X! (let ((lnv (math-normalize (list 'calcFunc-ln (nth 2 expr)))))
X! (math-sub (math-div (math-derivative (nth 1 expr))
X! (math-mul lnv (nth 1 expr)))
X! (math-div (math-derivative (nth 2 expr))
X! (math-mul (math-sqr lnv)
X! (nth 2 expr))))))
X! (t (or (and (= (length expr) 2)
X! (symbolp (car expr))
X! (let ((handler (get (car expr) 'math-derivative)))
X! (and handler
X! (let ((deriv (math-derivative (nth 1 expr))))
X! (if (Math-zerop deriv)
X! deriv
X! (math-mul (funcall handler (nth 1 expr))
X! deriv))))))
X! (if deriv-symb
X! (throw 'math-deriv nil)
X! (if (or (Math-objvecp expr)
X! (not (symbolp (car expr))))
X (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv)
X expr
X! deriv-var)
X! (let ((accum 0)
X! (arg expr)
X! (n 1)
X! derv)
X! (while (setq arg (cdr arg))
X! (or (Math-zerop (setq derv (math-derivative (car arg))))
X! (let ((func (intern (concat (symbol-name (car expr))
X! "'"
X! (if (> n 1)
X! (int-to-string n)
X! "")))))
X! (setq accum (math-add
X! accum
X! (math-mul derv
X! (cons func
X! (cdr expr)))))))
X! (setq n (1+ n)))
X! accum))))))
X )
X
X (defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
X--- 18681,18736 ----
X (math-derivative (nth 1 expr))) ; a reasonable definition
X ((eq (car expr) 'vec)
X (math-map-vec 'math-derivative expr))
X! (t (or (and (symbolp (car expr))
X! (if (= (length expr) 2)
X! (let ((handler (get (car expr) 'math-derivative)))
X! (and handler
X! (let ((deriv (math-derivative (nth 1 expr))))
X! (if (Math-zerop deriv)
X! deriv
X! (math-mul (funcall handler (nth 1 expr))
X! deriv)))))
X! (let ((handler (get (car expr) 'math-derivative-n)))
X! (and handler
X! (funcall handler expr)))))
X! (if (or (Math-objvecp expr)
X! (eq (car expr) 'var)
X! (not (symbolp (car expr))))
X! (if deriv-symb
X! (throw 'math-deriv nil)
X (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv)
X expr
X! deriv-var))
X! (let ((accum 0)
X! (arg expr)
X! (n 1)
X! derv)
X! (while (setq arg (cdr arg))
X! (or (Math-zerop (setq derv (math-derivative (car arg))))
X! (let ((func (intern (concat (symbol-name (car expr))
X! "'"
X! (if (> n 1)
X! (int-to-string n)
X! ""))))
X! (prop (cond ((= (length expr) 2)
X! 'math-derivative-1)
X! ((= (length expr) 3)
X! 'math-derivative-2)
X! ((= (length expr) 4)
X! 'math-derivative-3))))
X! (setq accum
X! (math-add
X! accum
X! (math-mul
X! derv
X! (let ((handler (get func prop)))
X! (or (and prop handler
X! (apply handler (cdr expr)))
X! (if deriv-symb
X! (throw 'math-deriv nil)
X! (cons func (cdr expr))))))))))
X! (setq n (1+ n)))
X! accum)))))
X )
X
X (defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
X***************
X*** 11829,11882 ****
X res)))
X )
X
X! (put 'calcFunc-inv 'math-derivative
X (function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
X
X! (put 'calcFunc-sqrt 'math-derivative
X (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
X
X! (put 'calcFunc-conj 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-conj u)))))
X
X! (put 'calcFunc-deg 'math-derivative
X (function (lambda (u) (math-div (math-pi-over-180) u))))
X
X! (put 'calcFunc-rad 'math-derivative
X (function (lambda (u) (math-mul (math-pi-over-180) u))))
X
X! (put 'calcFunc-ln 'math-derivative
X (function (lambda (u) (math-div 1 u))))
X
X! (put 'calcFunc-log10 'math-derivative
X (function (lambda (u)
X (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
X u))))
X
X! (put 'calcFunc-lnp1 'math-derivative
X (function (lambda (u) (math-div 1 (math-add u 1)))))
X
X! (put 'calcFunc-exp 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-exp u)))))
X
X! (put 'calcFunc-expm1 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))))
X
X! (put 'calcFunc-sin 'math-derivative
X (function (lambda (u) (math-to-radians-2 (math-normalize
X (list 'calcFunc-cos u))))))
X
X! (put 'calcFunc-cos 'math-derivative
X (function (lambda (u) (math-neg (math-to-radians-2
X (math-normalize
X (list 'calcFunc-sin u)))))))
X
X! (put 'calcFunc-tan 'math-derivative
X (function (lambda (u) (math-to-radians-2
X (math-div 1 (math-sqr
X (math-normalize
X (list 'calcFunc-cos u))))))))
X
X! (put 'calcFunc-arcsin 'math-derivative
X (function (lambda (u)
X (math-from-radians-2
X (math-div 1 (math-normalize
X--- 18757,18823 ----
X res)))
X )
X
X! (put 'calcFunc-inv\' 'math-derivative-1
X (function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
X
X! (put 'calcFunc-sqrt\' 'math-derivative-1
X (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
X
X! (put 'calcFunc-conj\' 'math-derivative-1
X (function (lambda (u) (math-normalize (list 'calcFunc-conj u)))))
X
X! (put 'calcFunc-deg\' 'math-derivative-1
X (function (lambda (u) (math-div (math-pi-over-180) u))))
X
X! (put 'calcFunc-rad\' 'math-derivative-1
X (function (lambda (u) (math-mul (math-pi-over-180) u))))
X
X! (put 'calcFunc-ln\' 'math-derivative-1
X (function (lambda (u) (math-div 1 u))))
X
X! (put 'calcFunc-log10\' 'math-derivative-1
X (function (lambda (u)
X (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
X u))))
X
X! (put 'calcFunc-lnp1\' 'math-derivative-1
X (function (lambda (u) (math-div 1 (math-add u 1)))))
X
X! (put 'calcFunc-log\' 'math-derivative-2
X! (function (lambda (x b)
X! (and (not (Math-zerop b))
X! (let ((lnv (math-normalize
X! (list 'calcFunc-ln b))))
X! (math-div 1 (math-mul lnv x)))))))
X!
X! (put 'calcFunc-log\'2 'math-derivative-2
X! (function (lambda (x b)
X! (let ((lnv (list 'calcFunc-ln b)))
X! (math-neg (math-div (list 'calcFunc-log x b)
X! (math-mul lnv b)))))))
X!
X! (put 'calcFunc-exp\' 'math-derivative-1
X (function (lambda (u) (math-normalize (list 'calcFunc-exp u)))))
X
X! (put 'calcFunc-expm1\' 'math-derivative-1
X (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))))
X
X! (put 'calcFunc-sin\' 'math-derivative-1
X (function (lambda (u) (math-to-radians-2 (math-normalize
X (list 'calcFunc-cos u))))))
X
X! (put 'calcFunc-cos\' 'math-derivative-1
X (function (lambda (u) (math-neg (math-to-radians-2
X (math-normalize
X (list 'calcFunc-sin u)))))))
X
X! (put 'calcFunc-tan\' 'math-derivative-1
X (function (lambda (u) (math-to-radians-2
X (math-div 1 (math-sqr
X (math-normalize
X (list 'calcFunc-cos u))))))))
X
X! (put 'calcFunc-arcsin\' 'math-derivative-1
X (function (lambda (u)
X (math-from-radians-2
X (math-div 1 (math-normalize
X***************
X*** 11883,11889 ****
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr u)))))))))
X
X! (put 'calcFunc-arccos 'math-derivative
X (function (lambda (u)
X (math-from-radians-2
X (math-div -1 (math-normalize
X--- 18824,18830 ----
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr u)))))))))
X
X! (put 'calcFunc-arccos\' 'math-derivative-1
X (function (lambda (u)
X (math-from-radians-2
X (math-div -1 (math-normalize
X***************
X*** 11890,11927 ****
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr u)))))))))
X
X! (put 'calcFunc-arctan 'math-derivative
X (function (lambda (u) (math-from-radians-2
X (math-div 1 (math-add 1 (math-sqr u)))))))
X
X! (put 'calcFunc-sinh 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-cosh u)))))
X
X! (put 'calcFunc-cosh 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-sinh u)))))
X
X! (put 'calcFunc-tanh 'math-derivative
X (function (lambda (u) (math-div 1 (math-sqr
X (math-normalize
X (list 'calcFunc-cosh u)))))))
X
X! (put 'calcFunc-arcsinh 'math-derivative
X (function (lambda (u)
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr u) 1)))))))
X
X! (put 'calcFunc-arccosh 'math-derivative
X (function (lambda (u)
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr u) -1)))))))
X
X! (put 'calcFunc-arctanh 'math-derivative
X (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))))
X
X
X
X (setq math-integ-var '(var X ---))
X (setq math-integ-var-2 '(var Y ---))
X (setq math-integ-vars (list 'f math-integ-var math-integ-var-2))
X--- 18831,18953 ----
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr u)))))))))
X
X! (put 'calcFunc-arctan\' 'math-derivative-1
X (function (lambda (u) (math-from-radians-2
X (math-div 1 (math-add 1 (math-sqr u)))))))
X
X! (put 'calcFunc-sinh\' 'math-derivative-1
X (function (lambda (u) (math-normalize (list 'calcFunc-cosh u)))))
X
X! (put 'calcFunc-cosh\' 'math-derivative-1
X (function (lambda (u) (math-normalize (list 'calcFunc-sinh u)))))
X
X! (put 'calcFunc-tanh\' 'math-derivative-1
X (function (lambda (u) (math-div 1 (math-sqr
X (math-normalize
X (list 'calcFunc-cosh u)))))))
X
X! (put 'calcFunc-arcsinh\' 'math-derivative-1
X (function (lambda (u)
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr u) 1)))))))
X
X! (put 'calcFunc-arccosh\' 'math-derivative-1
X (function (lambda (u)
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr u) -1)))))))
X
X! (put 'calcFunc-arctanh\' 'math-derivative-1
X (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))))
X
X+ (put 'calcFunc-bern\'2 'math-derivative-2
X+ (function (lambda (n x)
X+ (math-mul n (list 'calcFunc-bern (math-add n -1) x)))))
X
X+ (put 'calcFunc-euler\'2 'math-derivative-2
X+ (function (lambda (n x)
X+ (math-mul n (list 'calcFunc-euler (math-add n -1) x)))))
X+
X+ (put 'calcFunc-gammag\'2 'math-derivative-2
X+ (function (lambda (a x) (math-deriv-gamma a x 1))))
X+
X+ (put 'calcFunc-gammaG\'2 'math-derivative-2
X+ (function (lambda (a x) (math-deriv-gamma a x -1))))
X+
X+ (put 'calcFunc-gammaP\'2 'math-derivative-2
X+ (function (lambda (a x) (math-deriv-gamma a x
X+ (math-div
X+ 1 (math-normalize
X+ (list 'calcFunc-gamma
X+ a)))))))
X+
X+ (put 'calcFunc-gammaQ\'2 'math-derivative-2
X+ (function (lambda (a x) (math-deriv-gamma a x
X+ (math-div
X+ -1 (math-normalize
X+ (list 'calcFunc-gamma
X+ a)))))))
X+
X+ (defun math-deriv-gamma (a x scale)
X+ (math-mul scale
X+ (math-mul (math-pow x (math-add a -1))
X+ (list 'calcFunc-exp (math-neg x))))
X+ )
X+
X+ (put 'calcFunc-betaB\' 'math-derivative-3
X+ (function (lambda (x a b) (math-deriv-beta x a b 1))))
X+
X+ (put 'calcFunc-betaI\' 'math-derivative-3
X+ (function (lambda (x a b) (math-deriv-beta x a b
X+ (math-div
X+ 1 (list 'calcFunc-beta
X+ a b))))))
X+
X+ (defun math-deriv-beta (x a b scale)
X+ (math-mul (math-mul (math-pow x (math-add a -1))
X+ (math-pow (math-sub 1 x) (math-add b -1)))
X+ scale)
X+ )
X+
X+ (put 'calcFunc-erf\' 'math-derivative-1
X+ (function (lambda (x) (math-div 2
X+ (math-mul (list 'calcFunc-exp
X+ (math-sqr x))
X+ (if calc-symbolic-mode
X+ '(calcFunc-sqrt
X+ (var pi var-pi))
X+ (math-sqrt-pi)))))))
X+
X+ (put 'calcFunc-erfc\' 'math-derivative-1
X+ (function (lambda (x) (math-div -2
X+ (math-mul (list 'calcFunc-exp
X+ (math-sqr x))
X+ (if calc-symbolic-mode
X+ '(calcFunc-sqrt
X+ (var pi var-pi))
X+ (math-sqrt-pi)))))))
X+
X+ (put 'calcFunc-besJ\'2 'math-derivative-2
X+ (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ
X+ (math-add v -1)
X+ z)
X+ (list 'calcFunc-besJ
X+ (math-add v 1)
X+ z))
X+ 2))))
X+
X+ (put 'calcFunc-besY\'2 'math-derivative-2
X+ (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besY
X+ (math-add v -1)
X+ z)
X+ (list 'calcFunc-besY
X+ (math-add v 1)
X+ z))
X+ 2))))
X
X+
X+
X (setq math-integ-var '(var X ---))
X (setq math-integ-var-2 '(var Y ---))
X (setq math-integ-vars (list 'f math-integ-var math-integ-var-2))
X***************
X*** 12593,12601 ****
X
X ;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
X ;;; in lhs but not in rhs or rhs'; return rhs'.
X! (defun math-try-solve-for (lhs rhs) ; uses global values: solve-*.
X (let (t1 t2 t3)
X (cond ((equal lhs solve-var)
X rhs)
X ((Math-primp lhs)
X nil)
X--- 19619,19629 ----
X
X ;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
X ;;; in lhs but not in rhs or rhs'; return rhs'.
X! ;;; Uses global values: solve-*.
X! (defun math-try-solve-for (lhs rhs &optional sign)
X (let (t1 t2 t3)
X (cond ((equal lhs solve-var)
X+ (setq math-solve-sign sign)
X rhs)
X ((Math-primp lhs)
X nil)
X***************
X*** 12635,12671 ****
X (and (cdr t1)
X (math-try-solve-for t2
X (math-div (math-sub rhs (car t1))
X! (nth 1 t1))))))
X ((eq (car lhs) '+)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-sub rhs (nth 1 lhs))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-sub rhs (nth 2 lhs))))))
X ((memq (car lhs) '(- calcFunc-eq))
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-sub (nth 1 lhs) rhs)))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-add rhs (nth 2 lhs))))))
X ((eq (car lhs) 'neg)
X! (math-try-solve-for (nth 1 lhs) (math-neg rhs)))
X ((eq (car lhs) '*)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-div rhs (nth 1 lhs))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-div rhs (nth 2 lhs))))))
X ((eq (car lhs) '/)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-div (nth 1 lhs) rhs)))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-mul rhs (nth 2 lhs))))
X ((and (setq t1 (math-is-polynomial (nth 1 lhs) solve-var 2))
X (setq t2 (math-is-polynomial (nth 2 lhs) solve-var 2)))
X (math-try-solve-for (math-build-polynomial-expr
X--- 19663,19709 ----
X (and (cdr t1)
X (math-try-solve-for t2
X (math-div (math-sub rhs (car t1))
X! (nth 1 t1))
X! (math-solve-sign sign (nth 1 t1))))))
X ((eq (car lhs) '+)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-sub rhs (nth 1 lhs))
X! sign))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-sub rhs (nth 2 lhs))
X! sign))))
X ((memq (car lhs) '(- calcFunc-eq))
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-sub (nth 1 lhs) rhs)
X! (and sign (- sign))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-add rhs (nth 2 lhs))
X! sign))))
X ((eq (car lhs) 'neg)
X! (math-try-solve-for (nth 1 lhs) (math-neg rhs)
X! (and sign (- sign))))
X ((eq (car lhs) '*)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-div rhs (nth 1 lhs))
X! (math-solve-sign sign (nth 1 lhs))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-div rhs (nth 2 lhs))
X! (math-solve-sign sign (nth 2 lhs))))))
X ((eq (car lhs) '/)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X! (math-div (nth 1 lhs) rhs)
X! (math-solve-sign sign (nth 1 lhs))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X! (math-mul rhs (nth 2 lhs))
X! (math-solve-sign sign (nth 2 lhs))))
X ((and (setq t1 (math-is-polynomial (nth 1 lhs) solve-var 2))
X (setq t2 (math-is-polynomial (nth 2 lhs) solve-var 2)))
X (math-try-solve-for (math-build-polynomial-expr
X***************
X*** 12724,12740 ****
X (math-normalize
X (list '^
X rhs
X! (math-div 1 (nth 2 lhs)))))))))))
X ((and (eq (car lhs) '%)
X (not (math-expr-depends (nth 2 lhs) solve-var)))
X (math-try-solve-for (nth 1 lhs) (math-add rhs
X (math-solve-get-int
X (nth 2 lhs)))))
X ((and (= (length lhs) 2)
X (symbolp (car lhs))
X (setq t1 (get (car lhs) 'math-inverse))
X (setq t2 (funcall t1 rhs)))
X! (math-try-solve-for (nth 1 lhs) (math-normalize t2)))
X (t
X (calc-record-why "No inverse known" lhs)
X nil)))
X--- 19762,19793 ----
X (math-normalize
X (list '^
X rhs
X! (math-div 1 (nth 2 lhs)))))
X! (and sign
X! (math-oddp (nth 2 lhs))
X! (math-solve-sign sign (nth 2 lhs)))))))))
X ((and (eq (car lhs) '%)
X (not (math-expr-depends (nth 2 lhs) solve-var)))
X (math-try-solve-for (nth 1 lhs) (math-add rhs
X (math-solve-get-int
X (nth 2 lhs)))))
X+ ((eq (car lhs) 'calcFunc-log)
X+ (cond ((not (math-expr-depends (nth 2 lhs) solve-var))
X+ (math-try-solve-for (nth 1 lhs) (math-pow (nth 2 lhs) rhs)))
X+ ((not (math-expr-depends (nth 1 lhs) solve-var))
X+ (math-try-solve-for (nth 2 lhs) (math-pow
X+ (nth 1 lhs)
X+ (math-div 1 rhs))))))
X ((and (= (length lhs) 2)
X (symbolp (car lhs))
X (setq t1 (get (car lhs) 'math-inverse))
X (setq t2 (funcall t1 rhs)))
X! (setq t1 (get (car lhs) 'math-inverse-sign))
X! (math-try-solve-for (nth 1 lhs) (math-normalize t2)
X! (and sign t1
X! (if (integerp t1)
X! (* t1 sign)
X! (funcall t1 lhs sign)))))
X (t
X (calc-record-why "No inverse known" lhs)
X nil)))
X***************
X*** 12767,12772 ****
X--- 19820,19833 ----
X 0)
X )
X
X+ (defun math-solve-sign (sign expr)
X+ (and sign
X+ (if (math-posp expr)
X+ sign
X+ (if (math-negp expr)
X+ (- sign))))
X+ )
X+
X (defun math-looks-evenp (expr)
X (if (Math-integerp expr)
X (math-evenp expr)
X***************
X*** 12774,12798 ****
X (math-looks-evenp (nth 1 expr))))
X )
X
X! (defun math-solve-for (lhs rhs solve-var solve-full)
X (if (math-expr-contains rhs solve-var)
X (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full)
X (and (math-expr-contains lhs solve-var)
X! (math-try-solve-for lhs rhs)))
X )
X
X (defun calcFunc-solve (expr var)
X! (let ((res (math-solve-for expr 0 var nil)))
X! (if res
X! (list 'calcFunc-eq var res)
X! (list 'calcFunc-solve expr var)))
X )
X
X (defun calcFunc-fsolve (expr var)
X! (let ((res (math-solve-for expr 0 var t)))
X! (if res
X! (list 'calcFunc-eq var res)
X! (list 'calcFunc-fsolve expr var)))
X )
X
X (defun calcFunc-finv (expr var)
X--- 19835,19876 ----
X (math-looks-evenp (nth 1 expr))))
X )
X
X! (defun math-solve-for (lhs rhs solve-var solve-full &optional sign)
X (if (math-expr-contains rhs solve-var)
X (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full)
X (and (math-expr-contains lhs solve-var)
X! (math-try-solve-for lhs rhs sign)))
X! )
X!
X! (defun math-solve-eqn (expr var full)
X! (if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt
X! calcFunc-leq calcFunc-geq))
X! (let ((res (math-solve-for (cons '- (cdr expr))
X! 0 var full
X! (if (eq (car expr) 'calcFunc-neq) nil 1))))
X! (and res
X! (if (eq math-solve-sign 1)
X! (list (car expr) var res)
X! (if (eq math-solve-sign -1)
X! (list (car expr) res var)
X! (or (eq (car expr) 'calcFunc-neq)
X! (calc-record-why "Can't determine direction of inequality"))
X! (and (memq (car expr) '(calcFunc-neq calcFunc-lt
X! calcFunc-gt))
X! (list 'calcFunc-neq var res))))))
X! (let ((res (math-solve-for expr 0 var full)))
X! (and res
X! (list 'calcFunc-eq var res))))
X )
X
X (defun calcFunc-solve (expr var)
X! (or (math-solve-eqn expr var nil)
X! (list 'calcFunc-solve expr var))
X )
X
X (defun calcFunc-fsolve (expr var)
X! (or (math-solve-eqn expr var t)
X! (list 'calcFunc-fsolve expr var))
X )
X
X (defun calcFunc-finv (expr var)
X***************
X*** 12812,12817 ****
X--- 19890,19896 ----
X
X (put 'calcFunc-inv 'math-inverse
X (function (lambda (x) (math-div 1 x))))
X+ (put 'calcFunc-inv 'math-inverse-sign -1)
X
X (put 'calcFunc-sqrt 'math-inverse
X (function (lambda (x) (math-sqr x))))
X***************
X*** 12824,12841 ****
X--- 19903,19925 ----
X
X (put 'calcFunc-deg 'math-inverse
X (function (lambda (x) (list 'calcFunc-rad x))))
X+ (put 'calcFunc-deg 'math-inverse-sign 1)
X
X (put 'calcFunc-rad 'math-inverse
X (function (lambda (x) (list 'calcFunc-deg x))))
X+ (put 'calcFunc-rad 'math-inverse-sign 1)
X
X (put 'calcFunc-ln 'math-inverse
X (function (lambda (x) (list 'calcFunc-exp x))))
X+ (put 'calcFunc-ln 'math-inverse-sign 1)
X
X (put 'calcFunc-log10 'math-inverse
X (function (lambda (x) (list 'calcFunc-exp10 x))))
X+ (put 'calcFunc-log10 'math-inverse-sign 1)
X
X (put 'calcFunc-lnp1 'math-inverse
X (function (lambda (x) (list 'calcFunc-expm1 x))))
X+ (put 'calcFunc-lnp1 'math-inverse-sign 1)
X
X (put 'calcFunc-exp 'math-inverse
X (function (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x))
X***************
X*** 12843,12848 ****
X--- 19927,19933 ----
X (math-mul '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i))))))))
X+ (put 'calcFunc-exp 'math-inverse-sign 1)
X
X (put 'calcFunc-expm1 'math-inverse
X (function (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x))
X***************
X*** 12850,12855 ****
X--- 19935,19941 ----
X (math-mul '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i))))))))
X+ (put 'calcFunc-expm1 'math-inverse-sign 1)
X
X (put 'calcFunc-sin 'math-inverse
X (function (lambda (x) (let ((n (math-solve-get-int 1)))
X***************
X*** 12889,12894 ****
X--- 19975,19981 ----
X (math-mul
X '(var i var-i)
X n)))))))
X+ (put 'calcFunc-sinh 'math-inverse-sign 1)
X
X (put 'calcFunc-cosh 'math-inverse
X (function (lambda (x) (math-add (math-solve-get-sign
X***************
X*** 12904,12912 ****
X--- 19991,20001 ----
X (math-mul (math-half-circle t)
X (math-solve-get-int
X '(var i var-i)))))))
X+ (put 'calcFunc-tanh 'math-inverse-sign 1)
X
X (put 'calcFunc-arcsinh 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-sinh x)))))
X+ (put 'calcFunc-arcsinh 'math-inverse-sign 1)
X
X (put 'calcFunc-arccosh 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-cosh x)))))
X***************
X*** 12913,12918 ****
X--- 20002,20008 ----
X
X (put 'calcFunc-arctanh 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-tanh x)))))
X+ (put 'calcFunc-arctanh 'math-inverse-sign 1)
X
X
X
X***************
X*** 12948,12953 ****
X--- 20038,20804 ----
X
X
X
X+
X+ ;;; The following algorithms are from Numerical Recipes chapter 9.
X+
X+ ;;; "rtnewt" with safety kludges
X+ (defun math-newton-root (expr deriv guess orig-guess limit)
X+ (math-working "newton" guess)
X+ (let* ((var-DUMMY guess)
X+ next dval)
X+ (setq next (math-evaluate-expr expr)
X+ dval (math-evaluate-expr deriv))
X+ (if (and (Math-numberp next)
X+ (Math-numberp dval)
SHAR_EOF
echo "End of part 10, continue with part 11"
echo "11" > s2_seq_.tmp
exit 0
More information about the Comp.sources.misc
mailing list