daveg@csvax.cs.caltech.edu (David Gillespie) (10/15/90)
Posting-number: Volume 15, Issue 38 Submitted-by: daveg@csvax.cs.caltech.edu (David Gillespie) Archive-name: calc-1.05/part11 #!/bin/sh # this is part 11 of a multipart archive # do not concatenate these parts, unpack them in order with /bin/sh # file calc.patch continued # CurArch=11 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+ (not (Math-zerop dval))) X+ (progn X+ (setq next (math-sub guess (math-div next dval))) X+ (if (math-nearly-equal guess (setq next (math-float next))) X+ (progn X+ (setq var-DUMMY next) X+ (list 'vec next (math-evaluate-expr expr))) X+ (if (math-lessp (math-abs-approx (math-sub next orig-guess)) X+ limit) X+ (math-newton-root expr deriv next orig-guess limit) X+ (math-reject-arg next "Newton's method failed to converge")))) X+ (math-reject-arg next "Newton's method encountered a singularity"))) X+ ) X+ X+ ;;; Inspired by "rtsafe" X+ (defun math-newton-search-root (expr deriv guess vguess ostep oostep X+ low vlow high vhigh) X+ (let ((var-DUMMY guess) X+ (better t) X+ pos step next vnext) X+ (if guess X+ (math-working "newton" (list 'intv 0 low high)) X+ (math-working "bisect" (list 'intv 0 low high)) X+ (setq ostep (math-mul-float (math-sub-float high low) X+ '(float 5 -1)) X+ guess (math-add-float low ostep) X+ var-DUMMY guess X+ vguess (math-evaluate-expr expr)) X+ (or (Math-realp vguess) X+ (progn X+ (setq ostep (math-mul-float ostep '(float 6 -1)) X+ guess (math-add-float low ostep) X+ var-DUMMY guess X+ vguess (math-evaluate-expr expr)) X+ (or (math-realp vguess) X+ (progn X+ (setq ostep (math-mul-float ostep '(float 123456 -5)) X+ guess (math-add-float low ostep) X+ var-DUMMY guess X+ vguess nil)))))) X+ (or vguess X+ (setq vguess (math-evaluate-expr expr))) X+ (or (Math-realp vguess) X+ (math-reject-arg guess "Newton's method encountered a singularity")) X+ (setq vguess (math-float vguess)) X+ (if (eq (Math-negp vlow) (setq pos (Math-posp vguess))) X+ (setq high guess X+ vhigh vguess) X+ (if (eq (Math-negp vhigh) pos) X+ (setq low guess X+ vlow vguess) X+ (setq better nil))) X+ (if (or (Math-zerop vguess) X+ (math-nearly-equal low high)) X+ (list 'vec guess vguess) X+ (setq step (math-evaluate-expr deriv)) X+ (if (and (Math-realp step) X+ (not (Math-zerop step)) X+ (setq step (math-div-float vguess (math-float step)) X+ next (math-sub-float guess step)) X+ (not (math-lessp-float high next)) X+ (not (math-lessp-float next low))) X+ (if (or (Math-zerop vnext) X+ (math-nearly-equal next guess)) X+ (list 'vec next vnext) X+ (setq var-DUMMY next X+ vnext (math-evaluate-expr expr)) X+ (if (and better X+ (math-lessp-float (math-abs (or oostep X+ (math-sub-float X+ high low))) X+ (math-abs X+ (math-mul-float '(float 2 0) X+ step)))) X+ (math-newton-search-root expr deriv nil nil nil ostep X+ low vlow high vhigh) X+ (math-newton-search-root expr deriv next vnext step ostep X+ low vlow high vhigh))) X+ (if (or (and (Math-posp vlow) (Math-posp vhigh)) X+ (and (Math-negp vlow) (Math-negp vhigh))) X+ (math-search-root expr deriv low vlow high vhigh) X+ (math-newton-search-root expr deriv nil nil nil ostep X+ low vlow high vhigh))))) X+ ) X+ X+ ;;; Search for a root in an interval with no overt zero crossing. X+ (defun math-search-root (expr deriv low vlow high vhigh) X+ (let (found) X+ (if root-widen X+ (let ((iters 0) X+ diff) X+ (while (or (and (math-posp vlow) (math-posp vhigh)) X+ (and (math-negp vlow) (math-negp vhigh))) X+ (math-working "widen" (list 'intv 0 low high)) X+ (if (> (setq iters (1+ iters)) 20) X+ (math-reject-arg (list 'intv 0 low high) X+ "Unable to bracket root")) X+ (setq diff (math-mul-float (math-sub-float high low) X+ '(float 16 -1))) X+ (if (Math-zerop diff) X+ (setq low (math-increment low -1) X+ high (math-increment high 1)) X+ (if (math-lessp-float (math-abs vlow) (math-abs vhigh)) X+ (setq low (math-sub low diff) X+ var-DUMMY low X+ vlow (math-evaluate-expr expr)) X+ (setq high (math-add high diff) X+ var-DUMMY high X+ vhigh (math-evaluate-expr expr))))) X+ (setq found t)) X+ (or (Math-realp vlow) X+ (math-reject-arg vlow 'realp)) X+ (or (Math-realp vhigh) X+ (math-reject-arg vhigh 'realp)) X+ (let ((xvals (list low high)) X+ (yvals (list vlow vhigh)) X+ (pos (Math-posp vlow)) X+ (levels 0) X+ (step (math-sub-float high low)) X+ xp yp var-DUMMY) X+ (while (and (<= (setq levels (1+ levels)) 5) X+ (not found)) X+ (setq xp xvals X+ yp yvals X+ step (math-mul-float step '(float 497 -3))) X+ (while (and (cdr xp) (not found)) X+ (if (Math-realp (car yp)) X+ (setq low (car xp) X+ vlow (car yp))) X+ (setq high (math-add-float (car xp) step) X+ var-DUMMY high X+ vhigh (math-evaluate-expr expr)) X+ (math-working "search" high) X+ (if (and (Math-realp vhigh) X+ (eq (math-negp vhigh) pos)) X+ (setq found t) X+ (setcdr xp (cons high (cdr xp))) X+ (setcdr yp (cons vhigh (cdr yp))) X+ (setq xp (cdr (cdr xp)) X+ yp (cdr (cdr yp)))))))) X+ (if found X+ (if deriv X+ (math-newton-search-root expr deriv nil nil nil nil X+ low vlow high vhigh) X+ (math-bisect-root expr low vlow high vhigh)) X+ (math-reject-arg (list 'intv 3 low high) X+ "Unable to find a sign change in this interval"))) X+ ) X+ X+ ;;; "rtbis" (but we should be using Brent's method) X+ (defun math-bisect-root (expr low vlow high vhigh) X+ (let ((step (math-sub-float high low)) X+ (pos (Math-posp vhigh)) X+ var-DUMMY X+ mid vmid) X+ (while (not (or (math-nearly-equal low X+ (setq step (math-mul-float X+ step '(float 5 -1)) X+ mid (math-add-float low step))) X+ (progn X+ (setq var-DUMMY mid X+ vmid (math-evaluate-expr expr)) X+ (Math-zerop vmid)))) X+ (math-working "bisect" mid) X+ (if (eq (Math-posp vmid) pos) X+ (setq high mid X+ vhigh vmid) X+ (setq low mid X+ vlow vmid))) X+ (list 'vec mid vmid)) X+ ) X+ X+ ;;; "mnewt" X+ (defun math-newton-multi (expr jacob n guess orig-guess limit) X+ (let ((m -1) X+ (p guess) X+ p2 expr-val jacob-val next) X+ (while (< (setq p (cdr p) m (1+ m)) n) X+ (set (nth 2 (aref math-root-vars m)) (car p))) X+ (setq expr-val (math-evaluate-expr expr) X+ jacob-val (math-evaluate-expr jacob)) X+ (or (and (math-constp expr-val) X+ (math-constp jacob-val)) X+ (math-reject-arg guess "Newton's method encountered a singularity")) X+ (setq next (math-add guess (math-div (math-float (math-neg expr-val)) X+ (math-float jacob-val))) X+ p guess p2 next) X+ (math-working "newton" next) X+ (while (and (setq p (cdr p) p2 (cdr p2)) X+ (math-nearly-equal (car p) (car p2)))) X+ (if p X+ (if (math-lessp (math-abs-approx (math-sub next orig-guess)) X+ limit) X+ (math-newton-multi expr jacob n next orig-guess limit) X+ (math-reject-arg "Newton's method failed to converge")) X+ (list 'vec next expr-val))) X+ ) X+ X+ (defvar math-root-vars [(var DUMMY var-DUMMY)]) X+ X+ (defun math-find-root (expr var guess root-widen) X+ (if (eq (car-safe expr) 'vec) X+ (let ((n (1- (length expr))) X+ (calc-symbolic-flag nil) X+ (var-DUMMY nil) X+ (jacob (list 'vec)) X+ p p2 m row) X+ (setq expr (copy-sequence expr)) X+ (while (>= n (length math-root-vars)) X+ (let ((symb (intern (concat "math-root-v" X+ (int-to-string X+ (length math-root-vars)))))) X+ (setq math-root-vars (vconcat math-root-vars X+ (vector (list 'var symb symb)))))) X+ (setq m -1) X+ (while (< (setq m (1+ m)) n) X+ (set (nth 2 (aref math-root-vars m)) nil)) X+ (or (eq (car-safe var) 'vec) X+ (math-reject-arg var 'vectorp)) X+ (or (= (length var) (1+ n)) X+ (math-dimension-error)) X+ (setq m -1 p var) X+ (while (setq m (1+ m) p (cdr p)) X+ (or (eq (car-safe (car p)) 'var) X+ (math-reject-arg var "Expected a variable")) X+ (setq p2 expr) X+ (while (setq p2 (cdr p2)) X+ (setcar p2 (math-expr-subst (car p2) (car p) X+ (aref math-root-vars m))))) X+ (or (eq (car-safe guess) 'vec) X+ (math-reject-arg guess 'vectorp)) X+ (or (= (length guess) (1+ n)) X+ (math-dimension-error)) X+ (setq guess (copy-sequence guess) X+ p guess) X+ (while (setq p (cdr p)) X+ (or (Math-numberp (car guess)) X+ (math-reject-arg guess 'numberp)) X+ (setcar p (math-float (car p)))) X+ (setq p expr) X+ (while (setq p (cdr p)) X+ (if (assq (car-safe (car p)) calc-tweak-eqn-table) X+ (setcar p (math-sub (nth 1 (car p)) (nth 2 (car p))))) X+ (setcar p (math-evaluate-expr (car p))) X+ (setq row (list 'vec) X+ m -1) X+ (while (< (setq m (1+ m)) n) X+ (nconc row (list (math-evaluate-expr X+ (or (calcFunc-deriv (car p) X+ (aref math-root-vars m) X+ nil t) X+ (math-reject-arg X+ expr X+ "Formulas must be differentiable")))))) X+ (nconc jacob (list row))) X+ (setq m (math-abs-approx guess)) X+ (math-newton-multi expr jacob n guess guess X+ (if (math-zerop m) '(float 1 3) (math-mul m 10)))) X+ (or (eq (car-safe var) 'var) X+ (math-reject-arg var "Expected a variable")) X+ (or (math-expr-contains expr var) X+ (math-reject-arg expr "Formula does not contain specified variable")) X+ (if (assq (car expr) calc-tweak-eqn-table) X+ (setq expr (math-sub (nth 1 expr) (nth 2 expr)))) X+ (math-with-extra-prec 2 X+ (setq expr (math-expr-subst expr var '(var DUMMY var-DUMMY))) X+ (let* ((calc-symbolic-flag nil) X+ (var-DUMMY nil) X+ (expr (math-evaluate-expr expr)) X+ (deriv (calcFunc-deriv expr '(var DUMMY var-DUMMY) nil t)) X+ low high vlow vhigh) X+ (and deriv (setq deriv (math-evaluate-expr deriv))) X+ (setq guess (math-float guess)) X+ (if (and (math-numberp guess) X+ deriv) X+ (math-newton-root expr deriv guess guess X+ (if (math-zerop guess) '(float 1 6) X+ (math-mul (math-abs-approx guess) 100))) X+ (if (Math-realp guess) X+ (setq low guess X+ high guess X+ var-DUMMY guess X+ vlow (math-evaluate-expr expr) X+ vhigh vlow X+ root-widen t) X+ (if (eq (car guess) 'intv) X+ (progn X+ (setq low (nth 2 guess) X+ high (nth 3 guess)) X+ (if (memq (nth 1 guess) '(0 1)) X+ (setq low (math-increment low 1 high))) X+ (if (memq (nth 1 guess) '(0 2)) X+ (setq high (math-increment high -1 low))) X+ (setq var-DUMMY low X+ vlow (math-evaluate-expr expr) X+ var-DUMMY high X+ vhigh (math-evaluate-expr expr))) X+ (if (math-complexp guess) X+ (math-reject-arg "Complex root finder must have derivative") X+ (math-reject-arg guess X+ "Guess must be a number or an interval")))) X+ (if (Math-zerop vlow) X+ (list 'vec low vlow) X+ (if (Math-zerop vhigh) X+ (list 'vec high vhigh) X+ (if deriv X+ (math-newton-search-root expr deriv nil nil nil nil X+ low vlow high vhigh) X+ (if (or (and (Math-posp vlow) (Math-posp vhigh)) X+ (and (Math-negp vlow) (Math-negp vhigh))) X+ (math-search-root expr deriv low vlow high vhigh) X+ (math-bisect-root expr low vlow high vhigh))))))))) X+ ) X+ X+ (defun calcFunc-root (expr var guess) X+ (math-find-root expr var guess nil) X+ ) X+ X+ (defun calcFunc-wroot (expr var guess) X+ (math-find-root expr var guess t) X+ ) X+ X+ X+ X+ X+ ;;; The following algorithms come from Numerical Recipes, chapter 10. X+ X+ (defun math-min-eval (expr a) X+ (if (Math-vectorp a) X+ (let ((m -1)) X+ (while (setq m (1+ m) a (cdr a)) X+ (set (nth 2 (aref math-min-vars m)) (car a)))) X+ (setq var-DUMMY a)) X+ (setq a (math-evaluate-expr expr)) X+ (if (Math-ratp a) X+ (math-float a) X+ (if (eq (car a) 'float) X+ a X+ (math-reject-arg a 'realp))) X+ ) X+ X+ X+ ;;; A bracket for a minimum is a < b < c where f(b) < f(a) and f(b) < f(c). X+ X+ ;;; "mnbrak" X+ (defun math-widen-min (expr a b) X+ (let ((done nil) X+ (iters 30) X+ incr c va vb vc u vu r q ulim bc ba qr) X+ (or b (setq b (math-mul a '(float 101 -2)))) X+ (setq va (math-min-eval expr a) X+ vb (math-min-eval expr b)) X+ (if (math-lessp-float va vb) X+ (setq u a a b b u X+ vu va va vb vb vu)) X+ (setq c (math-add-float b (math-mul-float '(float 161803 -5) X+ (math-sub-float b a))) X+ vc (math-min-eval expr c)) X+ (while (and (not done) (math-lessp-float vc vb)) X+ (math-working "widen" (list 'intv 0 a c)) X+ (if (= (setq iters (1- iters)) 0) X+ (math-reject-arg nil "Unable to find a minimum near the interval")) X+ (setq bc (math-sub-float b c) X+ ba (math-sub-float b a) X+ r (math-mul-float ba (math-sub-float vb vc)) X+ q (math-mul-float bc (math-sub-float vb va)) X+ qr (math-sub-float q r)) X+ (if (math-lessp-float (math-abs qr) '(float 1 -20)) X+ (setq qr (if (math-negp qr) '(float -1 -20) '(float 1 -20)))) X+ (setq u (math-sub-float X+ b X+ (math-div-float (math-sub-float (math-mul-float bc q) X+ (math-mul-float ba r)) X+ (math-mul-float '(float 2 0) qr))) X+ ulim (math-add-float b (math-mul-float '(float -1 2) bc)) X+ incr (math-negp bc)) X+ (if (if incr (math-lessp-float b u) (math-lessp-float u b)) X+ (if (if incr (math-lessp-float u c) (math-lessp-float c u)) X+ (if (math-lessp-float (setq vu (math-min-eval expr u)) vc) X+ (setq a b va vb X+ b u vb vu X+ done t) X+ (if (math-lessp-float vb vu) X+ (setq c u vc vu X+ done t) X+ (setq u (math-add-float c (math-mul-float '(float -161803 -5) X+ bc)) X+ vu (math-min-eval expr u)))) X+ (if (if incr (math-lessp-float u ulim) (math-lessp-float ulim u)) X+ (if (math-lessp-float (setq vu (math-min-eval expr u)) vc) X+ (setq b c vb vc X+ c u vc vu X+ u (math-add-float c (math-mul-float X+ '(float -161803 -5) X+ (math-sub-float b c))) X+ vu (math-min-eval expr u))) X+ (setq u ulim X+ vu (math-min-eval expr u)))) X+ (setq u (math-add-float c (math-mul-float '(float -161803 -5) X+ bc)) X+ vu (math-min-eval expr u))) X+ (setq a b va vb X+ b c vb vc X+ c u vc vu)) X+ (if (math-lessp-float a c) X+ (list a va b vb c vc) X+ (list c vc b vb a va))) X+ ) X+ X+ (defun math-narrow-min (expr a c) X+ (let ((xvals (list a c)) X+ (yvals (list (math-min-eval expr a) X+ (math-min-eval expr c))) X+ (levels 0) X+ (step (math-sub-float c a)) X+ (found nil) X+ xp yp b) X+ (while (and (<= (setq levels (1+ levels)) 5) X+ (not found)) X+ (setq xp xvals X+ yp yvals X+ step (math-mul-float step '(float 497 -3))) X+ (while (and (cdr xp) (not found)) X+ (setq b (math-add-float (car xp) step)) X+ (math-working "search" b) X+ (setcdr xp (cons b (cdr xp))) X+ (setcdr yp (cons (math-min-eval expr b) (cdr yp))) X+ (if (and (math-lessp-float (nth 1 yp) (car yp)) X+ (math-lessp-float (nth 1 yp) (nth 2 yp))) X+ (setq found t) X+ (setq xp (cdr xp) X+ yp (cdr yp)) X+ (if (and (cdr (cdr yp)) X+ (math-lessp-float (nth 1 yp) (car yp)) X+ (math-lessp-float (nth 1 yp) (nth 2 yp))) X+ (setq found t) X+ (setq xp (cdr xp) X+ yp (cdr yp)))))) X+ (if found X+ (list (car xp) (car yp) X+ (nth 1 xp) (nth 1 yp) X+ (nth 2 xp) (nth 2 yp)) X+ (math-reject-arg nil "Unable to find a minimum in the interval"))) X+ ) X+ X+ ;;; "brent" X+ (defun math-brent-min (expr prec a va x vx b vb) X+ (let ((iters (+ 20 (* 5 prec))) X+ (w x) X+ (vw vx) X+ (v x) X+ (vv vx) X+ (tol (list 'float 1 (- -1 prec))) X+ (zeps (list 'float 1 (- -5 prec))) X+ (e '(float 0 0)) X+ u vu xm tol1 tol2 etemp p q r xv xw) X+ (while (progn X+ (setq xm (math-mul-float '(float 5 -1) X+ (math-add-float a b)) X+ tol1 (math-add-float X+ zeps X+ (math-mul-float tol (math-abs x))) X+ tol2 (math-mul-float tol1 '(float 2 0))) X+ (math-lessp-float (math-sub-float tol2 X+ (math-mul-float X+ '(float 5 -1) X+ (math-sub-float b a))) X+ (math-abs (math-sub-float x xm)))) X+ (if (= (setq iters (1- iters)) 0) X+ (math-reject-arg nil "Unable to converge on a minimum")) X+ (math-working "brent" x) X+ (if (math-lessp-float (math-abs e) tol1) X+ (setq e (if (math-lessp-float x xm) X+ (math-sub-float b x) X+ (math-sub-float a x)) X+ d (math-mul-float '(float 381966 -6) e)) X+ (setq xw (math-sub-float x w) X+ r (math-mul-float xw (math-sub-float vx vv)) X+ xv (math-sub-float x v) X+ q (math-mul-float xv (math-sub-float vx vw)) X+ p (math-sub-float (math-mul-float xv q) X+ (math-mul-float xw r)) X+ q (math-mul-float '(float 2 0) (math-sub-float q r))) X+ (if (math-posp q) X+ (setq p (math-neg-float p)) X+ (setq q (math-neg-float q))) X+ (setq etemp e X+ e d) X+ (if (and (math-lessp-float (math-abs p) X+ (math-abs (math-mul-float X+ '(float 5 -1) X+ (math-mul-float q etemp)))) X+ (math-lessp-float (math-mul-float X+ q (math-sub-float a x)) p) X+ (math-lessp-float p (math-mul-float X+ q (math-sub-float b x)))) X+ (progn X+ (setq d (math-div-float p q) X+ u (math-add-float x d)) X+ (if (or (math-lessp-float (math-sub-float u a) tol2) X+ (math-lessp-float (math-sub-float b u) tol2)) X+ (setq d (if (math-lessp-float xm x) X+ (math-neg-float tol1) X+ tol1)))) X+ (setq e (if (math-lessp-float x xm) X+ (math-sub-float b x) X+ (math-sub-float a x)) X+ d (math-mul-float '(float 381966 -6) e)))) X+ (setq u (math-add-float x X+ (if (math-lessp-float (math-abs d) tol1) X+ (if (math-negp d) X+ (math-neg-float tol1) X+ tol1) X+ d)) X+ vu (math-min-eval expr u)) X+ (if (math-lessp-float vx vu) X+ (progn X+ (if (math-lessp-float u x) X+ (setq a u) X+ (setq b u)) X+ (if (or (equal w x) X+ (not (math-lessp-float vw vu))) X+ (setq v w vv vw X+ w u vw vu) X+ (if (or (equal v x) X+ (equal v w) X+ (not (math-lessp-float vv vu))) X+ (setq v u vv vu)))) X+ (if (math-lessp-float u x) X+ (setq b x) X+ (setq a x)) X+ (setq v w vv vw X+ w x vw vx X+ x u vx vu))) X+ (list 'vec x vx)) X+ ) X+ X+ ;;; "powell" X+ (defun math-powell-min (expr n guesses prec) X+ (let* ((f1dim (math-line-min-func expr n)) X+ (xi (math-diag-matrix 1 n)) X+ (p (cons 'vec (mapcar 'car guesses))) X+ (pt p) X+ (ftol (list 'float 1 (- prec))) X+ (fret (math-min-eval expr p)) X+ fp ptt fptt xit i ibig del diff res) X+ (while (progn X+ (setq fp fret X+ ibig 0 X+ del '(float 0 0) X+ i 0) X+ (while (<= (setq i (1+ i)) n) X+ (setq fptt fret X+ res (math-line-min f1dim p X+ (math-mat-col xi i) X+ n prec) X+ p (let ((calc-internal-prec prec)) X+ (math-normalize (car res))) X+ fret (nth 2 res) X+ diff (math-abs (math-sub-float fptt fret))) X+ (if (math-lessp-float del diff) X+ (setq del diff X+ ibig i))) X+ (math-lessp-float X+ (math-mul-float ftol X+ (math-add-float (math-abs fp) X+ (math-abs fret))) X+ (math-mul-float '(float 2 0) X+ (math-abs (math-sub-float fp X+ fret))))) X+ (setq ptt (math-sub (math-mul '(float 2 0) p) pt) X+ xit (math-sub p pt) X+ pt p X+ fptt (math-min-eval expr ptt)) X+ (if (and (math-lessp-float fptt fp) X+ (math-lessp-float X+ (math-mul-float X+ (math-mul-float '(float 2 0) X+ (math-add-float X+ (math-sub-float fp X+ (math-mul-float '(float 2 0) X+ fret)) X+ fptt)) X+ (math-sqr-float (math-sub-float X+ (math-sub-float fp fret) del))) X+ (math-mul-float del X+ (math-sqr-float (math-sub-float fp fptt))))) X+ (progn X+ (setq res (math-line-min f1dim p xit n prec) X+ p (car res) X+ fret (nth 2 res) X+ i 0) X+ (while (<= (setq i (1+ i)) n) X+ (setcar (nthcdr ibig (nth i xi)) X+ (nth i (nth 1 res))))))) X+ (list 'vec p fret)) X+ ) X+ X+ (defun math-line-min-func (expr n) X+ (let ((m -1)) X+ (while (< (setq m (1+ m)) n) X+ (set (nth 2 (aref math-min-vars m)) X+ (list '+ X+ (list '* X+ '(var DUMMY var-DUMMY) X+ (list 'calcFunc-mrow '(var line-xi line-xi) (1+ m))) X+ (list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) X+ (math-evaluate-expr expr)) X+ ) X+ X+ (defun math-line-min (f1dim line-p line-xi n prec) X+ (let* ((var-DUMMY nil) X+ (expr (math-evaluate-expr f1dim)) X+ (params (math-widen-min expr '(float 0 0) '(float 1 0))) X+ (res (apply 'math-brent-min expr prec params)) X+ (xi (math-mul (nth 1 res) line-xi))) X+ (list (math-add line-p xi) xi (nth 2 res))) X+ ) X+ X+ X+ (defvar math-min-vars [(var DUMMY var-DUMMY)]) X+ X+ (defun math-find-minimum (expr var guess min-widen) X+ (let* ((calc-symbolic-flag nil) X+ (n 0) X+ (var-DUMMY nil) X+ (isvec (math-vectorp var)) X+ g guesses) X+ (or (math-vectorp var) X+ (setq var (list 'vec var))) X+ (or (math-vectorp guess) X+ (setq guess (list 'vec guess))) X+ (or (= (length var) (length guess)) X+ (math-dimension-error)) X+ (while (setq var (cdr var) guess (cdr guess)) X+ (or (eq (car-safe (car var)) 'var) X+ (math-reject-arg (car vg) "Expected a variable")) X+ (or (math-expr-contains expr (car var)) X+ (math-reject-arg (car var) X+ "Formula does not contain specified variable")) X+ (while (>= (1+ n) (length math-min-vars)) X+ (let ((symb (intern (concat "math-min-v" X+ (int-to-string X+ (length math-min-vars)))))) X+ (setq math-min-vars (vconcat math-min-vars X+ (vector (list 'var symb symb)))))) X+ (set (nth 2 (aref math-min-vars n)) nil) X+ (set (nth 2 (aref math-min-vars (1+ n))) nil) X+ (if (math-complexp (car guess)) X+ (setq expr (math-expr-subst expr X+ (car var) X+ (list '+ (aref math-min-vars n) X+ (list '* X+ (aref math-min-vars (1+ n)) X+ '(cplx 0 1)))) X+ guesses (let ((g (math-float (math-complex (car guess))))) X+ (cons (list (nth 2 g) nil nil) X+ (cons (list (nth 1 g) nil nil t) X+ guesses))) X+ n (+ n 2)) X+ (setq expr (math-expr-subst expr X+ (car var) X+ (aref math-min-vars n)) X+ guesses (cons (if (math-realp (car guess)) X+ (list (math-float (car guess)) nil nil) X+ (if (eq (car-safe (car guess)) 'intv) X+ (list (math-mul X+ (math-add (nth 2 (car guess)) X+ (nth 3 (car guess))) X+ '(float 5 -1)) X+ (math-float (nth 2 (car guess))) X+ (math-float (nth 3 (car guess)))) X+ (math-reject-arg X+ (car guess) X+ "Guess must be a number or an interval"))) X+ guesses) X+ n (1+ n)))) X+ (setq guesses (nreverse guesses) X+ expr (math-evaluate-expr expr)) X+ (if (= n 1) X+ (let* ((params (if (nth 1 (car guesses)) X+ (if min-widen X+ (math-widen-min expr X+ (nth 1 (car guesses)) X+ (nth 2 (car guesses))) X+ (math-narrow-min expr X+ (nth 1 (car guesses)) X+ (nth 2 (car guesses)))) X+ (math-widen-min expr X+ (car (car guesses)) X+ nil))) X+ (prec calc-internal-prec) X+ (res (math-with-extra-prec (+ calc-internal-prec 2) X+ (apply 'math-brent-min expr prec params)))) X+ (if isvec X+ (list 'vec (list 'vec (nth 1 res)) (nth 2 res)) X+ res)) X+ (let* ((prec calc-internal-prec) X+ (res (math-with-extra-prec (+ calc-internal-prec 2) X+ (math-powell-min expr n guesses prec))) X+ (p (nth 1 res)) X+ (vec (list 'vec))) X+ (while (setq p (cdr p)) X+ (if (nth 3 (car guesses)) X+ (progn X+ (nconc vec (list (math-normalize X+ (list 'cplx (car p) (nth 1 p))))) X+ (setq p (cdr p) X+ guesses (cdr guesses))) X+ (nconc vec (list (car p)))) X+ (setq guesses (cdr guesses))) X+ (if isvec X+ (list 'vec vec (nth 2 res)) X+ (list 'vec (nth 1 vec) (nth 2 res)))))) X+ ) X+ X+ (defun calcFunc-minimize (expr var guess) X+ (let ((calc-internal-prec (max (/ calc-internal-prec 2) 3))) X+ (math-find-minimum (math-normalize expr) X+ (math-normalize var) X+ (math-normalize guess) nil)) X+ ) X+ X+ (defun calcFunc-wminimize (expr var guess) X+ (let ((calc-internal-prec (max (/ calc-internal-prec 2) 3))) X+ (math-find-minimum (math-normalize expr) X+ (math-normalize var) X+ (math-normalize guess) t)) X+ ) X+ X+ (defun calcFunc-maximize (expr var guess) X+ (let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) X+ (res (math-find-minimum (math-normalize (math-neg expr)) X+ (math-normalize var) X+ (math-normalize guess) nil))) X+ (list 'vec (nth 1 res) (math-neg (nth 2 res)))) X+ ) X+ X+ (defun calcFunc-wmaximize (expr var guess) X+ (let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) X+ (res (math-find-minimum (math-normalize (math-neg expr)) X+ (math-normalize var) X+ (math-normalize guess) t))) X+ (list 'vec (nth 1 res) (math-neg (nth 2 res)))) X+ ) X+ X+ X+ X+ X ;;;; [calc-alg.el] X X ;;; Simple operations on expressions. X*************** X*** 13025,13030 **** X--- 20876,20882 ---- X (math-build-polynomial-expr p base) X expr)) X ) X+ (fset 'calcFunc-collect (symbol-function 'math-collect-terms)) X X ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...), X ;;; else return nil if not in polynomial form. If "loose", coefficients X*************** X*** 13178,13189 **** X ;;; Build an expression from a polynomial list. X (defun math-build-polynomial-expr (p var) X (if p X! (let ((accum (car p)) X! (n 0)) X! (while (setq p (cdr p)) X! (setq n (1+ n) X! accum (math-add (math-mul (car p) (math-pow var n)) accum))) X! accum)) X ) X X X--- 21030,21056 ---- X ;;; Build an expression from a polynomial list. X (defun math-build-polynomial-expr (p var) X (if p X! (if (Math-numberp var) X! (math-with-extra-prec 1 X! (let* ((rp (reverse p)) X! (accum (car rp))) X! (while (setq rp (cdr rp)) X! (setq accum (math-add (car rp) (math-mul accum var)))) X! accum)) X! (let* ((rp (reverse p)) X! (n (1- (length rp))) X! (accum (math-mul (car rp) (math-pow var n))) X! term) X! (while (setq rp (cdr rp)) X! (setq n (1- n)) X! (or (math-zerop (car rp)) X! (setq accum (list (if (math-looks-negp (car rp)) '- '+) X! accum X! (math-mul (if (math-looks-negp (car rp)) X! (math-neg (car rp)) X! (car rp)) X! (math-pow var n)))))) X! accum))) X ) X X X*************** X*** 13415,13422 **** X (let* ((combined-units (append math-additional-units X math-standard-units)) X (unit-list (mapcar 'car combined-units)) X- (calc-language nil) X- (math-expr-opers math-standard-opers) X tab) X (message "Building units table...") X (setq math-units-table-buffer-valid nil) X--- 21282,21287 ---- X*************** X*** 13425,13431 **** X (list (car x) X (and (nth 1 x) X (if (stringp (nth 1 x)) X! (let ((exp (math-read-expr X (nth 1 x)))) X (if (eq (car-safe exp) 'error) X (error "Format error in definition of %s in units table: %s" X--- 21290,21296 ---- X (list (car x) X (and (nth 1 x) X (if (stringp (nth 1 x)) X! (let ((exp (math-read-plain-expr X (nth 1 x)))) X (if (eq (car-safe exp) 'error) X (error "Format error in definition of %s in units table: %s" X*************** X*** 13648,13653 **** X--- 21513,21519 ---- X (let ((math-simplifying-units t)) X (math-simplify a)) X ) X+ (fset 'calcFunc-usimplify (symbol-function 'math-simplify-units)) X X (math-defsimplify (+ -) X (and math-simplifying-units X*************** X*** 13667,13672 **** X--- 21533,21544 ---- X (and math-simplifying-units X (let ((np (cdr expr)) X n nn) X+ (if (or (math-floatp (car (setq n (nthcdr 2 expr)))) X+ (and (eq (car-safe (nth 2 expr)) '*) X+ (math-floatp (car (setq n (cdr (nth 2 expr))))))) X+ (progn X+ (setcar (cdr expr) (math-mul (nth 1 expr) (math-div 1 (car n)))) X+ (setcar n 1))) X (while (eq (car-safe (setq n (car np))) '*) X (math-simplify-units-divisor (cdr n) (cdr (cdr expr))) X (setq np (cdr (cdr n)))) X*************** X*** 13931,13936 **** X--- 21803,21809 ---- X ;;; Compiling Lisp-like forms to use the math library. X X (defun math-do-defmath (func args body) X+ (calc-need-macros) X (let* ((fname (intern (concat "calcFunc-" (symbol-name func)))) X (doc (if (stringp (car body)) (list (car body)))) X (clargs (mapcar 'math-clean-arg args)) X*************** X*** 14140,14151 **** X ((and (eq (car body) ':) X (stringp (nth 1 body))) X (cons (let* ((math-read-expr-quotes t) X! (calc-language nil) X! (math-expr-opers math-standard-opers) X! (exp (math-read-expr (nth 1 body)))) X! (if (eq (car exp) 'error) X! (error "Bad format: %s" (nth 1 body)) X! (math-define-exp exp))) X (math-define-list (cdr (cdr body))))) X (quote X (cons (cond ((consp (car body)) X--- 22013,22020 ---- X ((and (eq (car body) ':) X (stringp (nth 1 body))) X (cons (let* ((math-read-expr-quotes t) X! (exp (math-read-plain-expr (nth 1 body) t))) X! (math-define-exp exp)) X (math-define-list (cdr (cdr body))))) X (quote X (cons (cond ((consp (car body)) X*************** X*** 14516,14521 **** X--- 22385,22413 ---- X X (cond X X+ ;; Integer+fractions X+ ((string-match "^\\([0-9]*\\)[:/]\\([0-9]*\\)[:/]\\([0-9]*\\)$" s) X+ (let ((int (math-match-substring s 1)) X+ (num (math-match-substring s 2)) X+ (den (math-match-substring s 3))) X+ (let ((int (if (> (length int) 0) (math-read-number int) 0)) X+ (num (if (> (length num) 0) (math-read-number num) 1)) X+ (den (if (> (length num) 0) (math-read-number den) 1))) X+ (and int num den X+ (math-integerp int) (math-integerp num) (math-integerp den) X+ (not (math-zerop den)) X+ (list 'frac (math-add num (math-mul int den)) den))))) X+ X+ ;; Fractions X+ ((string-match "^\\([0-9]*\\)[:/]\\([0-9]*\\)$" s) X+ (let ((num (math-match-substring s 1)) X+ (den (math-match-substring s 2))) X+ (let ((num (if (> (length num) 0) (math-read-number num) 1)) X+ (den (if (> (length num) 0) (math-read-number den) 1))) X+ (and num den (math-integerp num) (math-integerp den) X+ (not (math-zerop den)) X+ (list 'frac num den))))) X+ X ;; Modulo forms X ((string-match "^\\(.*\\) *mod *\\(.*\\)$" s) X (let* ((n (math-match-substring s 1)) X*************** X*** 14647,14653 **** X (exp-keep-spaces nil) X exp-token exp-data) X (while (setq exp-token (string-match "\\.\\." exp-str)) X! (setq exp-str (concat (substring exp-str exp-token) "\\dots" X (substring exp-str (+ exp-token 2))))) X (math-read-token) X (let ((val (catch 'syntax (math-read-expr-level 0)))) X--- 22539,22545 ---- X (exp-keep-spaces nil) X exp-token exp-data) X (while (setq exp-token (string-match "\\.\\." exp-str)) X! (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots" X (substring exp-str (+ exp-token 2))))) X (math-read-token) X (let ((val (catch 'syntax (math-read-expr-level 0)))) X*************** X*** 14658,14663 **** X--- 22550,22565 ---- X (list 'error exp-old-pos "Syntax error"))))) X ) X X+ (defun math-read-plain-expr (exp-str &optional error-check) X+ (let* ((calc-language nil) X+ (math-expr-opers math-standard-opers) X+ (val (math-read-expr exp-str))) X+ (and error-check X+ (eq (car-safe val) 'error) X+ (error "%s: %s" (nth 2 val) exp-str)) X+ val) X+ ) X+ X ;;;; [calc-vec.el] X X (defun math-read-brackets (space-sep close) X*************** X*** 14761,14768 **** X ((eq (car a) 'incomplete) X (concat "'" (prin1-to-string a))) X ((eq (car a) 'vec) X! (concat "[" (math-format-flat-vector (cdr a) ", " X! (if (cdr (cdr a)) 0 1000)) "]")) X ((eq (car a) 'intv) X (concat (if (memq (nth 1 a) '(0 1)) "(" "[") X (math-format-flat-expr (nth 2 a) 1000) X--- 22663,22677 ---- X ((eq (car a) 'incomplete) X (concat "'" (prin1-to-string a))) X ((eq (car a) 'vec) X! (if (or calc-full-trail-vectors (not calc-can-abbrev-vectors) X! (< (length a) 7)) X! (concat "[" (math-format-flat-vector (cdr a) ", " X! (if (cdr (cdr a)) 0 1000)) "]") X! (concat "[" X! (math-format-flat-expr (nth 1 a) 0) ", " X! (math-format-flat-expr (nth 2 a) 0) ", " X! (math-format-flat-expr (nth 3 a) 0) ", ..., " X! (math-format-flat-expr (nth (1- (length a)) a) 0) "]"))) X ((eq (car a) 'intv) X (concat (if (memq (nth 1 a) '(0 1)) "(" "[") X (math-format-flat-expr (nth 2 a) 1000) X*************** X*** 14805,14810 **** X--- 22714,22744 ---- X buf) X "") X ) X+ (setq calc-can-abbrev-vectors nil) X+ X+ (defun math-format-nice-expr (x w) X+ (cond ((and (eq (car-safe x) 'vec) X+ (cdr (cdr x)) X+ (or (eq (car-safe (nth 1 x)) 'vec) X+ (eq (car-safe (nth 2 x)) 'vec) X+ (eq (car-safe (nth 3 x)) 'vec) X+ calc-break-vectors)) X+ (concat "[ " (math-format-flat-vector (cdr x) ",\n " 0) " ]")) X+ (t X+ (let ((str (math-format-flat-expr x 0)) X+ (pos 0) p) X+ (or (string-match "\"" str) X+ (while (<= (setq p (+ pos w)) (length str)) X+ (while (and (> (setq p (1- p)) pos) X+ (not (= (aref str p) ? )))) X+ (if (> p (+ pos 5)) X+ (setq str (concat (substring str 0 p) X+ "\n " X+ (substring str p)) X+ pos (1+ p)) X+ (setq pos (+ pos w))))) X+ str))) X+ ) X X (defun math-assq2 (v a) X (cond ((null a) nil) X*************** X*** 14815,14831 **** X X (defun math-format-number-fancy (a) X (cond X ((eq (car a) 'cplx) X! (if (null calc-complex-format) X! (concat "(" (math-format-number (nth 1 a)) X! ", " (math-format-number (nth 2 a)) ")") X! (if (math-zerop (nth 1 a)) X! (concat (math-format-number (nth 2 a)) X! (symbol-name calc-complex-format)) X! (concat (math-format-number (nth 1 a)) X! (if (math-negp (nth 2 a)) " - " " + ") X! (math-format-number (math-abs (nth 2 a))) X! (symbol-name calc-complex-format))))) X ((eq (car a) 'polar) X (concat "(" (math-format-number (nth 1 a)) X "; " (math-format-number (nth 2 a)) ")")) X--- 22749,22783 ---- X X (defun math-format-number-fancy (a) X (cond X+ ((eq (car a) 'frac) X+ (if (> (length calc-frac-format) 1) X+ (if (Math-integer-negp (nth 1 a)) X+ (concat "-" (math-format-number (math-neg a))) X+ (let ((q (math-idivmod (nth 1 a) (nth 2 a)))) X+ (concat (math-format-number (car q)) X+ (substring calc-frac-format 0 1) X+ (let ((math-radix-explicit-format nil)) X+ (math-format-number (cdr q))) X+ (substring calc-frac-format 1 2) X+ (let ((math-radix-explicit-format nil)) X+ (math-format-number (nth 2 a)))))) X+ (concat (math-format-number (nth 1 a)) X+ calc-frac-format X+ (let ((math-radix-explicit-format nil)) X+ (math-format-number (nth 2 a)))))) X ((eq (car a) 'cplx) X! (if (math-zerop (nth 2 a)) X! (math-format-number (nth 1 a)) X! (if (null calc-complex-format) X! (concat "(" (math-format-number (nth 1 a)) X! ", " (math-format-number (nth 2 a)) ")") X! (if (math-zerop (nth 1 a)) X! (concat (math-format-number (nth 2 a)) X! (symbol-name calc-complex-format)) X! (concat (math-format-number (nth 1 a)) X! (if (math-negp (nth 2 a)) " - " " + ") X! (math-format-number (math-abs (nth 2 a))) X! (symbol-name calc-complex-format)))))) X ((eq (car a) 'polar) X (concat "(" (math-format-number (nth 1 a)) X "; " (math-format-number (nth 2 a)) ")")) X*************** X*** 14839,14844 **** X--- 22791,22808 ---- X (math-format-number (nth 1 a)) X (math-format-number (nth 2 a)) X (math-format-number (nth 3 a)))))) X+ ((eq (car a) 'intv) X+ (concat (if (memq (nth 1 a) '(0 1)) "(" "[") X+ (math-format-number (nth 2 a)) X+ " .. " X+ (math-format-number (nth 3 a)) X+ (if (memq (nth 1 a) '(0 2)) ")" "]"))) X+ ((eq (car a) 'sdev) X+ (concat (math-format-number (nth 1 a)) X+ " +/- " X+ (math-format-number (nth 2 a)))) X+ ((eq (car a) 'vec) X+ (math-format-flat-expr a 0)) X (t (format "%s" a))) X ) X X*************** X*** 15033,15042 **** X--- 22997,23014 ---- X ;;; (supscr C1 C2) Composition C1 with superscript C2 X ;;; (subscr C1 C2) Composition C1 with subscript C2 X ;;; (rule) Horizontal line, full width of enclosing comp X+ ;;; X+ ;;; (tag X C) Composition C corresponds to sub-expression X X X (defun math-compose-expr (a prec) X (let ((math-compose-level (1+ math-compose-level))) X (cond X+ ((or (eq a math-comp-selected) X+ (and math-comp-tagged X+ (not (eq math-comp-tagged a)))) X+ (let ((math-comp-selected nil)) X+ (and math-comp-tagged (setq math-comp-tagged a)) X+ (list 'tag a (math-compose-expr a prec)))) X ((math-scalarp a) X (if (and (eq (car-safe a) 'frac) X (memq calc-language '(tex math))) X*************** X*** 15048,15064 **** X (substring calc-vector-brackets 0 1) "")) X (right-bracket (if calc-vector-brackets X (substring calc-vector-brackets 1 2) "")) X! (comma (or calc-vector-commas " ")) X (just (cond ((eq calc-matrix-just 'right) 'vright) X ((eq calc-matrix-just 'center) 'vcent) X! (t 'vleft)))) X! (if (and (math-matrixp a) (not (math-matrixp (nth 1 a))) X! (memq calc-language '(nil big))) X (if (= (length a) 2) X (list 'horiz X (concat left-bracket left-bracket " ") X (math-compose-vector (cdr (nth 1 a)) X! (concat comma " ")) X (concat " " right-bracket right-bracket)) X (let* ((rows (1- (length a))) X (cols (1- (length (nth 1 a)))) X--- 23020,23042 ---- X (substring calc-vector-brackets 0 1) "")) X (right-bracket (if calc-vector-brackets X (substring calc-vector-brackets 1 2) "")) X! (comma-spc (or calc-vector-commas " ")) X! (comma (or calc-vector-commas "")) X (just (cond ((eq calc-matrix-just 'right) 'vright) X ((eq calc-matrix-just 'center) 'vcent) X! (t 'vleft))) X! (break calc-break-vectors)) X! (if (and (memq calc-language '(nil big)) X! (not calc-break-vectors) X! (math-matrixp a) (not (math-matrixp (nth 1 a))) X! (or calc-full-vectors X! (and (< (length a) 7) (< (length (nth 1 a)) 7)) X! (progn (setq break t) nil))) X (if (= (length a) 2) X (list 'horiz X (concat left-bracket left-bracket " ") X (math-compose-vector (cdr (nth 1 a)) X! (concat comma-spc " ")) X (concat " " right-bracket right-bracket)) X (let* ((rows (1- (length a))) X (cols (1- (length (nth 1 a)))) X*************** X*** 15089,15099 **** X (if (and calc-display-strings X (math-vector-is-string a)) X (prin1-to-string (concat (cdr a))) X! (list 'horiz X! left-bracket X! (math-compose-vector (cdr a) X! (concat (or calc-vector-commas "") " ")) X! right-bracket))))) X ((eq (car a) 'incomplete) X (if (cdr (cdr a)) X (cond ((eq (nth 1 a) 'vec) X--- 23067,23107 ---- X (if (and calc-display-strings X (math-vector-is-string a)) X (prin1-to-string (concat (cdr a))) X! (if (and break (cdr a) X! (not (eq calc-language 'flat))) X! (let* ((full (or calc-full-vectors (< (length a) 7))) X! (rows (if full (1- (length a)) 5)) X! (base (/ (1- rows) 2)) X! (just 'vleft) X! (calc-break-vectors nil)) X! (list 'horiz X! (append '(vleft) X! (list base X! (concat left-bracket " ")) X! (make-list (1- rows) " ")) X! (cons 'vleft (cons base X! (math-compose-rows X! (cdr a) X! (if full rows 3)))))) X! (if (or calc-full-vectors (< (length a) 7)) X! (if (and (eq calc-language 'tex) X! (math-matrixp a)) X! (append '(horiz "\\matrix{ ") X! (math-compose-tex-matrix (cdr a)) X! '(" }")) X! (list 'horiz X! left-bracket X! (math-compose-vector (cdr a) (concat comma " ")) X! right-bracket)) X! (list 'horiz X! left-bracket X! (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a)) X! (concat comma " ")) X! comma (if (eq calc-language 'tex) " \\dots" " ...") X! comma " " X! (list 'break math-compose-level) X! (math-compose-expr (nth (1- (length a)) a) 0) X! right-bracket))))))) X ((eq (car a) 'incomplete) X (if (cdr (cdr a)) X (cond ((eq (nth 1 a) 'vec) X*************** X*** 15146,15152 **** X (eq calc-language 'big)) X (let ((a1 (math-compose-expr (nth 1 a) 1000)) X (a2 (math-compose-expr (nth 2 a) 0))) X! (if (eq (car-safe a1) 'subscr) X (list 'subscr X (nth 1 a1) X (list 'horiz X--- 23154,23162 ---- X (eq calc-language 'big)) X (let ((a1 (math-compose-expr (nth 1 a) 1000)) X (a2 (math-compose-expr (nth 2 a) 0))) X! (if (or (eq (car-safe a1) 'subscr) X! (and (eq (car-safe a1) 'tag) X! (eq (car-safe (nth 2 a1)) 'subscr))) X (list 'subscr X (nth 1 a1) X (list 'horiz X*************** X*** 15196,15205 **** X (>= prec 0)) X (list 'horiz "{" (math-compose-expr a -1) "}")) X (t X! (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))) X! (rhs (math-compose-expr (nth 2 a) (nth 3 op)))) X (and (equal (car op) "^") X! (= (math-comp-first-char lhs) ?-) X (setq lhs (list 'horiz "(" lhs ")"))) X (and (eq calc-language 'tex) X (or (equal (car op) "^") (equal (car op) "_")) X--- 23206,23218 ---- X (>= prec 0)) X (list 'horiz "{" (math-compose-expr a -1) "}")) X (t X! (let* ((math-comp-tagged (and math-comp-tagged X! (not (math-primp a)) X! math-comp-tagged)) X! (lhs (math-compose-expr (nth 1 a) (nth 2 op))) X! (rhs (math-compose-expr (nth 2 a) (nth 3 op)))) X (and (equal (car op) "^") X! (eq (math-comp-first-char lhs) ?-) X (setq lhs (list 'horiz "(" lhs ")"))) X (and (eq calc-language 'tex) X (or (equal (car op) "^") (equal (car op) "_")) X*************** X*** 15339,15345 **** X--- 23352,23368 ---- X (math-compose-vector (cdr a) ", ") X right)))))))) X ) X+ X+ ;;;; [calc-ext.el] X+ X (setq math-compose-level 0) X+ (setq math-comp-selected nil) X+ (setq math-comp-tagged nil) X+ (setq math-comp-sel-hpos nil) X+ (setq math-comp-sel-vpos nil) X+ (setq math-comp-sel-cpos nil) X+ X+ ;;;; [calc-comp.el] X X (defun math-prod-first-term (x) X (if (eq (car-safe x) '*) X*************** X*** 15386,15396 **** X (lambda (r) (list 'horiz X (math-compose-expr (nth col r) X 0) X! (concat comma " ")))) X a))) X (math-compose-matrix-step a (1+ col)))) X ) X X (defun math-vector-is-string (a) X (and (cdr a) X (progn X--- 23409,23443 ---- X (lambda (r) (list 'horiz X (math-compose-expr (nth col r) X 0) X! (concat comma-spc " ")))) X a))) X (math-compose-matrix-step a (1+ col)))) X ) X X+ (defun math-compose-rows (a count) X+ (if (cdr a) X+ (if (<= count 0) X+ (if (< count 0) X+ (math-compose-rows (cdr a) -1) X+ (cons (concat (if (eq calc-language 'tex) "\\dots" "...") comma) X+ (math-compose-rows (cdr a) -1))) X+ (cons (list 'horiz X+ (math-compose-expr (car a) 0) X+ comma) X+ (math-compose-rows (cdr a) (1- count)))) X+ (list (list 'horiz X+ (math-compose-expr (car a) 0) X+ (concat " " right-bracket)))) X+ ) X+ X+ (defun math-compose-tex-matrix (a) X+ (if (cdr a) X+ (cons (math-compose-vector (cdr (car a)) " & ") X+ (cons " \\\\ " X+ (math-compose-tex-matrix (cdr a)))) X+ (list (math-compose-vector (cdr (car a)) " & "))) X+ ) X+ X (defun math-vector-is-string (a) X (and (cdr a) X (progn X*************** X*** 15435,15440 **** X--- 23482,23489 ---- X (and (= (length c) 3) X (= (nth 1 c) 0) X (math-comp-is-flat (nth 2 c)))) X+ ((eq (car c) 'tag) X+ (math-comp-is-flat (nth 2 c))) X (t nil)) X ) X X*************** X*** 15445,15451 **** X (let ((comp-buf "") X (comp-word "") X (comp-pos 0) X! (comp-wlen 0)) X (math-comp-to-string-flat-term c) X (math-comp-to-string-flat-term '(break -1)) X comp-buf) X--- 23494,23502 ---- X (let ((comp-buf "") X (comp-word "") X (comp-pos 0) X! (comp-wlen 0) X! (comp-lnum 0) X! (comp-highlight (and math-comp-selected calc-show-selections))) X (math-comp-to-string-flat-term c) X (math-comp-to-string-flat-term '(break -1)) X comp-buf) X*************** X*** 15453,15459 **** X X (defun math-comp-to-string-flat-term (c) X (cond ((not (consp c)) X! (setq comp-word (concat comp-word c) X comp-wlen (+ comp-wlen (length c)))) X ((eq (car c) 'horiz) X (while (setq c (cdr c)) X--- 23504,23512 ---- X X (defun math-comp-to-string-flat-term (c) X (cond ((not (consp c)) X! (setq comp-word (concat comp-word (if comp-highlight X! (math-comp-highlight-string c) X! c)) X comp-wlen (+ comp-wlen (length c)))) X ((eq (car c) 'horiz) X (while (setq c (cdr c)) X*************** X*** 15466,15479 **** X comp-pos (+ comp-pos comp-wlen)) X (if calc-line-numbering X (setq comp-buf (concat comp-buf "\n " comp-word) X! comp-pos (+ comp-wlen 5)) X (setq comp-buf (concat comp-buf "\n " comp-word) X! comp-pos (1+ comp-wlen)))) X (setq comp-word "" X comp-wlen 0)) X (t (math-comp-to-string-flat-term (nth 2 c)))) X ) X X X ;;; Simplify a composition to a canonical form consisting of X ;;; (vleft n "string" "string" "string" ...) X--- 23519,23556 ---- X comp-pos (+ comp-pos comp-wlen)) X (if calc-line-numbering X (setq comp-buf (concat comp-buf "\n " comp-word) X! comp-pos (+ comp-wlen 5) X! comp-lnum (1+ comp-lnum)) X (setq comp-buf (concat comp-buf "\n " comp-word) X! comp-pos (1+ comp-wlen) X! comp-lnum (1+ comp-lnum)))) X (setq comp-word "" X comp-wlen 0)) X+ ((eq (car c) 'tag) X+ (cond ((eq (nth 1 c) math-comp-selected) X+ (let ((comp-highlight (not calc-show-selections))) X+ (math-comp-to-string-flat-term (nth 2 c)))) X+ ((eq (nth 1 c) t) X+ (let ((comp-highlight nil)) X+ (math-comp-to-string-flat-term (nth 2 c)))) X+ ((and math-comp-sel-hpos X+ (<= (+ comp-pos comp-wlen) math-comp-sel-cpos)) X+ (math-comp-to-string-flat-term (nth 2 c)) X+ (if (> (+ comp-pos comp-wlen) math-comp-sel-cpos) X+ (setq math-comp-sel-tag c X+ math-comp-sel-cpos 10000))) X+ (t (math-comp-to-string-flat-term (nth 2 c))))) X (t (math-comp-to-string-flat-term (nth 2 c)))) X ) X X+ (defun math-comp-highlight-string (s) X+ (setq s (copy-sequence s)) X+ (let ((i (length s))) X+ (while (>= (setq i (1- i)) 0) X+ (or (memq (aref s i) '(32 ?\n)) X+ (aset s i (if calc-show-selections ?\. ?\#))))) X+ s X+ ) X X ;;; Simplify a composition to a canonical form consisting of X ;;; (vleft n "string" "string" "string" ...) X*************** X*** 15484,15490 **** X (comp-base 0) X (comp-height 1) X (comp-hpos 0) X! (comp-vpos 0)) X (math-comp-simplify-term c) X (cons 'vleft (cons comp-base comp-buf))) X ) X--- 23561,23569 ---- X (comp-base 0) X (comp-height 1) X (comp-hpos 0) X! (comp-vpos 0) X! (comp-highlight (and math-comp-selected calc-show-selections)) X! (comp-tag nil)) X (math-comp-simplify-term c) X (cons 'vleft (cons comp-base comp-buf))) X ) X*************** X*** 15492,15510 **** X (defun math-comp-add-string (s h v) X (and (> (length s) 0) X (let ((vv (+ v comp-base))) X! (if (< vv 0) X! (setq comp-buf (nconc (make-list (- vv) "") comp-buf) X! comp-base (- v) X! comp-height (- comp-height vv) X! vv 0) X! (if (>= vv comp-height) X! (setq comp-buf (nconc comp-buf X! (make-list (1+ (- vv comp-height)) "")) X! comp-height (1+ vv)))) X! (let ((str (nthcdr vv comp-buf))) X! (setcar str (concat (car str) X! (make-string (- h (length (car str))) 32) X! s))))) X ) X X (defun math-comp-simplify-term (c) X--- 23571,23602 ---- X (defun math-comp-add-string (s h v) X (and (> (length s) 0) X (let ((vv (+ v comp-base))) X! (if math-comp-sel-hpos X! (math-comp-add-string-sel h vv (length s) 1) X! (if (< vv 0) X! (setq comp-buf (nconc (make-list (- vv) "") comp-buf) X! comp-base (- v) X! comp-height (- comp-height vv) X! vv 0) X! (if (>= vv comp-height) X! (setq comp-buf (nconc comp-buf X! (make-list (1+ (- vv comp-height)) "")) X! comp-height (1+ vv)))) X! (let ((str (nthcdr vv comp-buf))) X! (setcar str (concat (car str) X! (make-string (- h (length (car str))) 32) X! (if comp-highlight X! (math-comp-highlight-string s) X! s))))))) X! ) X! X! (defun math-comp-add-string-sel (x y w h) X! (if (and (<= y math-comp-sel-vpos) X! (> (+ y h) math-comp-sel-vpos) X! (<= x math-comp-sel-hpos) X! (> (+ x w) math-comp-sel-hpos)) X! (setq math-comp-sel-tag comp-tag X! math-comp-sel-vpos 10000)) X ) X X (defun math-comp-simplify-term (c) X*************** X*** 15540,15556 **** X widths (cdr widths)))) X (setq comp-hpos (+ comp-hpos maxwid)))) X ((eq (car c) 'supscr) X- (math-comp-simplify-term (nth 1 c)) X (let* ((asc (math-comp-ascent (nth 1 c))) X (desc (math-comp-descent (nth 2 c))) X (comp-vpos (- comp-vpos (+ asc desc)))) X! (math-comp-simplify-term (nth 2 c)))) X ((eq (car c) 'subscr) X (math-comp-simplify-term (nth 1 c)) X (let* ((asc (math-comp-ascent (nth 2 c))) X (desc (math-comp-descent (nth 1 c))) X (comp-vpos (+ comp-vpos (+ asc desc)))) X! (math-comp-simplify-term (nth 2 c))))) X ) X X X--- 23632,23666 ---- X widths (cdr widths)))) X (setq comp-hpos (+ comp-hpos maxwid)))) X ((eq (car c) 'supscr) X (let* ((asc (math-comp-ascent (nth 1 c))) X (desc (math-comp-descent (nth 2 c))) X+ (oldh (prog1 X+ comp-hpos X+ (math-comp-simplify-term (nth 1 c)))) X (comp-vpos (- comp-vpos (+ asc desc)))) X! (math-comp-simplify-term (nth 2 c)) X! (if math-comp-sel-hpos X! (math-comp-add-string-sel oldh X! (- comp-vpos X! -1 X! (math-comp-ascent (nth 2 c))) X! (- comp-hpos oldh) X! (math-comp-height c))))) X ((eq (car c) 'subscr) X (math-comp-simplify-term (nth 1 c)) X (let* ((asc (math-comp-ascent (nth 2 c))) X (desc (math-comp-descent (nth 1 c))) X (comp-vpos (+ comp-vpos (+ asc desc)))) X! (math-comp-simplify-term (nth 2 c)))) X! ((eq (car c) 'tag) X! (cond ((eq (nth 1 c) math-comp-selected) X! (let ((comp-highlight (not calc-show-selections))) X! (math-comp-simplify-term (nth 2 c)))) X! ((eq (nth 1 c) t) X! (let ((comp-highlight nil)) X! (math-comp-simplify-term (nth 2 c)))) X! (t (let ((comp-tag c)) X! (math-comp-simplify-term (nth 2 c))))))) X ) X X X*************** X*** 15564,15570 **** X (let (ch) X (while (and (setq c (cdr c)) X (not (setq ch (math-comp-first-char (car c)))))) X! ch))) X ) X X (defun math-comp-last-char (c) X--- 23674,23682 ---- X (let (ch) X (while (and (setq c (cdr c)) X (not (setq ch (math-comp-first-char (car c)))))) X! ch)) X! ((eq (car c) 'tag) X! (math-comp-first-char (nth 2 c)))) X ) X X (defun math-comp-last-char (c) X*************** X*** 15576,15582 **** X (while (and c X (not (setq ch (math-comp-last-char (car c))))) X (setq c (cdr c))) X! ch))) X ) X X (defun math-comp-width (c) X--- 23688,23696 ---- X (while (and c X (not (setq ch (math-comp-last-char (car c))))) X (setq c (cdr c))) X! ch)) X! ((eq (car c) 'tag) X! (math-comp-last-char (nth 2 c)))) X ) X X (defun math-comp-width (c) X*************** X*** 15592,15597 **** X--- 23706,23713 ---- X (while (setq c (cdr c)) X (setq accum (max accum (math-comp-width (car c))))) X accum)) X+ ((eq (car c) 'tag) X+ (math-comp-width (nth 2 c))) X (t 0)) X ) X X*************** X*** 15614,15619 **** X--- 23730,23737 ---- X (+ (math-comp-ascent (nth 1 c)) (math-comp-height (nth 2 c)))) X ((eq (car c) 'subscr) X (math-comp-ascent (nth 1 c))) X+ ((eq (car c) 'tag) X+ (math-comp-ascent (nth 2 c))) X (t 1)) X ) X X*************** X*** 15634,15639 **** X--- 23752,23759 ---- X (math-comp-descent (nth 1 c))) X ((eq (car c) 'subscr) X (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c)))) X+ ((eq (car c) 'tag) X+ (math-comp-descent (nth 2 c))) X (t 0)) X ) X X*************** X*** 15690,15709 **** X X ;;;; Splitting calc-ext.el into smaller parts. [Suggested by Juha Sarlin.] X X! (defun calc-split (directory no-save) X "Split the file \"calc-ext.el\" into smaller parts for faster loading. X This should be done during installation of Calc only." X (interactive "DDirectory for resulting files: \nP") X- (or (string-match "calc-ext.el" (buffer-file-name)) X- (error "This command is for Calc installers only. (Refer to the documentation.)")) X (or (equal directory "") X (setq directory (file-name-as-directory (expand-file-name directory)))) X- (and (or (get-buffer "calc-incom.el") X- (file-exists-p (concat directory "calc-incom.el"))) X- (error "calc-split has already been used!")) X (let (copyright-point X autoload-point X (start (point-marker)) X filename X (dest-buffer nil) X (done nil) X--- 23810,23827 ---- X X ;;;; Splitting calc-ext.el into smaller parts. [Suggested by Juha Sarlin.] X X! (defun calc-split (directory no-save &optional compile) X "Split the file \"calc-ext.el\" into smaller parts for faster loading. X This should be done during installation of Calc only." X (interactive "DDirectory for resulting files: \nP") SHAR_EOF echo "End of part 11, continue with part 12" echo "12" > s2_seq_.tmp exit 0