v15i038: Patch for GNU Emacs Calc, version 1.04 -> 1.05, part 11/20
David Gillespie
daveg at csvax.cs.caltech.edu
Mon Oct 15 11:18:33 AEST 1990
Posting-number: Volume 15, Issue 38
Submitted-by: daveg at 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
More information about the Comp.sources.misc
mailing list