daveg@csvax.cs.caltech.edu (David Gillespie) (10/15/90)
Posting-number: Volume 15, Issue 37 Submitted-by: daveg@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