home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume15 / calc-1.05 / part11 < prev    next >
Lisp/Scheme  |  1990-10-14  |  57KB  |  1,692 lines
  1. Newsgroups: comp.sources.misc
  2. X-UNIX-From: daveg@csvax.cs.caltech.edu
  3. subject: v15i038: Patch for GNU Emacs Calc, version 1.04 -> 1.05, part 11/20
  4. from: daveg@csvax.cs.caltech.edu (David Gillespie)
  5. Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  6.  
  7. Posting-number: Volume 15, Issue 38
  8. Submitted-by: daveg@csvax.cs.caltech.edu (David Gillespie)
  9. Archive-name: calc-1.05/part11
  10.  
  11. #!/bin/sh
  12. # this is part 11 of a multipart archive
  13. # do not concatenate these parts, unpack them in order with /bin/sh
  14. # file calc.patch continued
  15. #
  16. CurArch=11
  17. if test ! -r s2_seq_.tmp
  18. then echo "Please unpack part 1 first!"
  19.      exit 1; fi
  20. ( read Scheck
  21.   if test "$Scheck" != $CurArch
  22.   then echo "Please unpack part $Scheck next!"
  23.        exit 1;
  24.   else exit 0; fi
  25. ) < s2_seq_.tmp || exit 1
  26. sed 's/^X//' << 'SHAR_EOF' >> calc.patch
  27. X+          (not (Math-zerop dval)))
  28. X+     (progn
  29. X+       (setq next (math-sub guess (math-div next dval)))
  30. X+       (if (math-nearly-equal guess (setq next (math-float next)))
  31. X+           (progn
  32. X+         (setq var-DUMMY next)
  33. X+         (list 'vec next (math-evaluate-expr expr)))
  34. X+         (if (math-lessp (math-abs-approx (math-sub next orig-guess))
  35. X+                 limit)
  36. X+         (math-newton-root expr deriv next orig-guess limit)
  37. X+           (math-reject-arg next "Newton's method failed to converge"))))
  38. X+       (math-reject-arg next "Newton's method encountered a singularity")))
  39. X+ )
  40. X+ 
  41. X+ ;;; Inspired by "rtsafe"
  42. X+ (defun math-newton-search-root (expr deriv guess vguess ostep oostep
  43. X+                      low vlow high vhigh)
  44. X+   (let ((var-DUMMY guess)
  45. X+     (better t)
  46. X+     pos step next vnext)
  47. X+     (if guess
  48. X+     (math-working "newton" (list 'intv 0 low high))
  49. X+       (math-working "bisect" (list 'intv 0 low high))
  50. X+       (setq ostep (math-mul-float (math-sub-float high low)
  51. X+                   '(float 5 -1))
  52. X+         guess (math-add-float low ostep)
  53. X+         var-DUMMY guess
  54. X+         vguess (math-evaluate-expr expr))
  55. X+       (or (Math-realp vguess)
  56. X+       (progn
  57. X+         (setq ostep (math-mul-float ostep '(float 6 -1))
  58. X+           guess (math-add-float low ostep)
  59. X+           var-DUMMY guess
  60. X+           vguess (math-evaluate-expr expr))
  61. X+         (or (math-realp vguess)
  62. X+         (progn
  63. X+           (setq ostep (math-mul-float ostep '(float 123456 -5))
  64. X+             guess (math-add-float low ostep)
  65. X+             var-DUMMY guess
  66. X+             vguess nil))))))
  67. X+     (or vguess
  68. X+     (setq vguess (math-evaluate-expr expr)))
  69. X+     (or (Math-realp vguess)
  70. X+     (math-reject-arg guess "Newton's method encountered a singularity"))
  71. X+     (setq vguess (math-float vguess))
  72. X+     (if (eq (Math-negp vlow) (setq pos (Math-posp vguess)))
  73. X+     (setq high guess
  74. X+           vhigh vguess)
  75. X+       (if (eq (Math-negp vhigh) pos)
  76. X+       (setq low guess
  77. X+         vlow vguess)
  78. X+     (setq better nil)))
  79. X+     (if (or (Math-zerop vguess)
  80. X+         (math-nearly-equal low high))
  81. X+     (list 'vec guess vguess)
  82. X+       (setq step (math-evaluate-expr deriv))
  83. X+       (if (and (Math-realp step)
  84. X+            (not (Math-zerop step))
  85. X+            (setq step (math-div-float vguess (math-float step))
  86. X+              next (math-sub-float guess step))
  87. X+            (not (math-lessp-float high next))
  88. X+            (not (math-lessp-float next low)))
  89. X+       (if (or (Math-zerop vnext)
  90. X+           (math-nearly-equal next guess))
  91. X+           (list 'vec next vnext)
  92. X+         (setq var-DUMMY next
  93. X+           vnext (math-evaluate-expr expr))
  94. X+         (if (and better
  95. X+              (math-lessp-float (math-abs (or oostep
  96. X+                              (math-sub-float
  97. X+                               high low)))
  98. X+                        (math-abs
  99. X+                     (math-mul-float '(float 2 0)
  100. X+                             step))))
  101. X+         (math-newton-search-root expr deriv nil nil nil ostep
  102. X+                      low vlow high vhigh)
  103. X+           (math-newton-search-root expr deriv next vnext step ostep
  104. X+                        low vlow high vhigh)))
  105. X+     (if (or (and (Math-posp vlow) (Math-posp vhigh))
  106. X+         (and (Math-negp vlow) (Math-negp vhigh)))
  107. X+         (math-search-root expr deriv low vlow high vhigh)
  108. X+       (math-newton-search-root expr deriv nil nil nil ostep
  109. X+                    low vlow high vhigh)))))
  110. X+ )
  111. X+ 
  112. X+ ;;; Search for a root in an interval with no overt zero crossing.
  113. X+ (defun math-search-root (expr deriv low vlow high vhigh)
  114. X+   (let (found)
  115. X+     (if root-widen
  116. X+     (let ((iters 0)
  117. X+           diff)
  118. X+       (while (or (and (math-posp vlow) (math-posp vhigh))
  119. X+              (and (math-negp vlow) (math-negp vhigh)))
  120. X+         (math-working "widen" (list 'intv 0 low high))
  121. X+         (if (> (setq iters (1+ iters)) 20)
  122. X+         (math-reject-arg (list 'intv 0 low high)
  123. X+                  "Unable to bracket root"))
  124. X+         (setq diff (math-mul-float (math-sub-float high low)
  125. X+                        '(float 16 -1)))
  126. X+         (if (Math-zerop diff)
  127. X+         (setq low (math-increment low -1)
  128. X+               high (math-increment high 1))
  129. X+           (if (math-lessp-float (math-abs vlow) (math-abs vhigh))
  130. X+           (setq low (math-sub low diff)
  131. X+             var-DUMMY low
  132. X+             vlow (math-evaluate-expr expr))
  133. X+         (setq high (math-add high diff)
  134. X+               var-DUMMY high
  135. X+               vhigh (math-evaluate-expr expr)))))
  136. X+       (setq found t))
  137. X+       (or (Math-realp vlow)
  138. X+       (math-reject-arg vlow 'realp))
  139. X+       (or (Math-realp vhigh)
  140. X+       (math-reject-arg vhigh 'realp))
  141. X+       (let ((xvals (list low high))
  142. X+         (yvals (list vlow vhigh))
  143. X+         (pos (Math-posp vlow))
  144. X+         (levels 0)
  145. X+         (step (math-sub-float high low))
  146. X+         xp yp var-DUMMY)
  147. X+     (while (and (<= (setq levels (1+ levels)) 5)
  148. X+             (not found))
  149. X+       (setq xp xvals
  150. X+         yp yvals
  151. X+         step (math-mul-float step '(float 497 -3)))
  152. X+       (while (and (cdr xp) (not found))
  153. X+         (if (Math-realp (car yp))
  154. X+         (setq low (car xp)
  155. X+               vlow (car yp)))
  156. X+         (setq high (math-add-float (car xp) step)
  157. X+           var-DUMMY high
  158. X+           vhigh (math-evaluate-expr expr))
  159. X+         (math-working "search" high)
  160. X+         (if (and (Math-realp vhigh)
  161. X+              (eq (math-negp vhigh) pos))
  162. X+         (setq found t)
  163. X+           (setcdr xp (cons high (cdr xp)))
  164. X+           (setcdr yp (cons vhigh (cdr yp)))
  165. X+           (setq xp (cdr (cdr xp))
  166. X+             yp (cdr (cdr yp))))))))
  167. X+     (if found
  168. X+     (if deriv
  169. X+         (math-newton-search-root expr deriv nil nil nil nil
  170. X+                      low vlow high vhigh)
  171. X+       (math-bisect-root expr low vlow high vhigh))
  172. X+       (math-reject-arg (list 'intv 3 low high)
  173. X+                "Unable to find a sign change in this interval")))
  174. X+ )
  175. X+ 
  176. X+ ;;; "rtbis"  (but we should be using Brent's method)
  177. X+ (defun math-bisect-root (expr low vlow high vhigh)
  178. X+   (let ((step (math-sub-float high low))
  179. X+     (pos (Math-posp vhigh))
  180. X+     var-DUMMY
  181. X+     mid vmid)
  182. X+     (while (not (or (math-nearly-equal low
  183. X+                        (setq step (math-mul-float
  184. X+                            step '(float 5 -1))
  185. X+                          mid (math-add-float low step)))
  186. X+             (progn
  187. X+               (setq var-DUMMY mid
  188. X+                 vmid (math-evaluate-expr expr))
  189. X+               (Math-zerop vmid))))
  190. X+       (math-working "bisect" mid)
  191. X+       (if (eq (Math-posp vmid) pos)
  192. X+       (setq high mid
  193. X+         vhigh vmid)
  194. X+     (setq low mid
  195. X+           vlow vmid)))
  196. X+     (list 'vec mid vmid))
  197. X+ )
  198. X+ 
  199. X+ ;;; "mnewt"
  200. X+ (defun math-newton-multi (expr jacob n guess orig-guess limit)
  201. X+   (let ((m -1)
  202. X+     (p guess)
  203. X+     p2 expr-val jacob-val next)
  204. X+     (while (< (setq p (cdr p) m (1+ m)) n)
  205. X+       (set (nth 2 (aref math-root-vars m)) (car p)))
  206. X+     (setq expr-val (math-evaluate-expr expr)
  207. X+       jacob-val (math-evaluate-expr jacob))
  208. X+     (or (and (math-constp expr-val)
  209. X+          (math-constp jacob-val))
  210. X+     (math-reject-arg guess "Newton's method encountered a singularity"))
  211. X+     (setq next (math-add guess (math-div (math-float (math-neg expr-val))
  212. X+                      (math-float jacob-val)))
  213. X+       p guess p2 next)
  214. X+     (math-working "newton" next)
  215. X+     (while (and (setq p (cdr p) p2 (cdr p2))
  216. X+         (math-nearly-equal (car p) (car p2))))
  217. X+     (if p
  218. X+     (if (math-lessp (math-abs-approx (math-sub next orig-guess))
  219. X+             limit)
  220. X+         (math-newton-multi expr jacob n next orig-guess limit)
  221. X+       (math-reject-arg "Newton's method failed to converge"))
  222. X+       (list 'vec next expr-val)))
  223. X+ )
  224. X+ 
  225. X+ (defvar math-root-vars [(var DUMMY var-DUMMY)])
  226. X+ 
  227. X+ (defun math-find-root (expr var guess root-widen)
  228. X+   (if (eq (car-safe expr) 'vec)
  229. X+       (let ((n (1- (length expr)))
  230. X+         (calc-symbolic-flag nil)
  231. X+         (var-DUMMY nil)
  232. X+         (jacob (list 'vec))
  233. X+         p p2 m row)
  234. X+     (setq expr (copy-sequence expr))
  235. X+     (while (>= n (length math-root-vars))
  236. X+       (let ((symb (intern (concat "math-root-v"
  237. X+                       (int-to-string
  238. X+                        (length math-root-vars))))))
  239. X+         (setq math-root-vars (vconcat math-root-vars
  240. X+                       (vector (list 'var symb symb))))))
  241. X+     (setq m -1)
  242. X+     (while (< (setq m (1+ m)) n)
  243. X+       (set (nth 2 (aref math-root-vars m)) nil))
  244. X+     (or (eq (car-safe var) 'vec)
  245. X+         (math-reject-arg var 'vectorp))
  246. X+     (or (= (length var) (1+ n))
  247. X+         (math-dimension-error))
  248. X+     (setq m -1 p var)
  249. X+     (while (setq m (1+ m) p (cdr p))
  250. X+       (or (eq (car-safe (car p)) 'var)
  251. X+           (math-reject-arg var "Expected a variable"))
  252. X+       (setq p2 expr)
  253. X+       (while (setq p2 (cdr p2))
  254. X+         (setcar p2 (math-expr-subst (car p2) (car p)
  255. X+                     (aref math-root-vars m)))))
  256. X+     (or (eq (car-safe guess) 'vec)
  257. X+         (math-reject-arg guess 'vectorp))
  258. X+     (or (= (length guess) (1+ n))
  259. X+         (math-dimension-error))
  260. X+     (setq guess (copy-sequence guess)
  261. X+           p guess)
  262. X+     (while (setq p (cdr p))
  263. X+       (or (Math-numberp (car guess))
  264. X+           (math-reject-arg guess 'numberp))
  265. X+       (setcar p (math-float (car p))))
  266. X+     (setq p expr)
  267. X+     (while (setq p (cdr p))
  268. X+       (if (assq (car-safe (car p)) calc-tweak-eqn-table)
  269. X+           (setcar p (math-sub (nth 1 (car p)) (nth 2 (car p)))))
  270. X+       (setcar p (math-evaluate-expr (car p)))
  271. X+       (setq row (list 'vec)
  272. X+         m -1)
  273. X+       (while (< (setq m (1+ m)) n)
  274. X+         (nconc row (list (math-evaluate-expr
  275. X+                   (or (calcFunc-deriv (car p)
  276. X+                           (aref math-root-vars m)
  277. X+                           nil t)
  278. X+                   (math-reject-arg
  279. X+                    expr
  280. X+                    "Formulas must be differentiable"))))))
  281. X+       (nconc jacob (list row)))
  282. X+     (setq m (math-abs-approx guess))
  283. X+     (math-newton-multi expr jacob n guess guess
  284. X+                (if (math-zerop m) '(float 1 3) (math-mul m 10))))
  285. X+     (or (eq (car-safe var) 'var)
  286. X+     (math-reject-arg var "Expected a variable"))
  287. X+     (or (math-expr-contains expr var)
  288. X+     (math-reject-arg expr "Formula does not contain specified variable"))
  289. X+     (if (assq (car expr) calc-tweak-eqn-table)
  290. X+     (setq expr (math-sub (nth 1 expr) (nth 2 expr))))
  291. X+     (math-with-extra-prec 2
  292. X+       (setq expr (math-expr-subst expr var '(var DUMMY var-DUMMY)))
  293. X+       (let* ((calc-symbolic-flag nil)
  294. X+          (var-DUMMY nil)
  295. X+          (expr (math-evaluate-expr expr))
  296. X+          (deriv (calcFunc-deriv expr '(var DUMMY var-DUMMY) nil t))
  297. X+          low high vlow vhigh)
  298. X+     (and deriv (setq deriv (math-evaluate-expr deriv)))
  299. X+     (setq guess (math-float guess))
  300. X+     (if (and (math-numberp guess)
  301. X+          deriv)
  302. X+         (math-newton-root expr deriv guess guess
  303. X+                   (if (math-zerop guess) '(float 1 6)
  304. X+                 (math-mul (math-abs-approx guess) 100)))
  305. X+       (if (Math-realp guess)
  306. X+           (setq low guess
  307. X+             high guess
  308. X+             var-DUMMY guess
  309. X+             vlow (math-evaluate-expr expr)
  310. X+             vhigh vlow
  311. X+             root-widen t)
  312. X+         (if (eq (car guess) 'intv)
  313. X+         (progn
  314. X+           (setq low (nth 2 guess)
  315. X+             high (nth 3 guess))
  316. X+           (if (memq (nth 1 guess) '(0 1))
  317. X+               (setq low (math-increment low 1 high)))
  318. X+           (if (memq (nth 1 guess) '(0 2))
  319. X+               (setq high (math-increment high -1 low)))
  320. X+           (setq var-DUMMY low
  321. X+             vlow (math-evaluate-expr expr)
  322. X+             var-DUMMY high
  323. X+             vhigh (math-evaluate-expr expr)))
  324. X+           (if (math-complexp guess)
  325. X+           (math-reject-arg "Complex root finder must have derivative")
  326. X+         (math-reject-arg guess
  327. X+                  "Guess must be a number or an interval"))))
  328. X+       (if (Math-zerop vlow)
  329. X+           (list 'vec low vlow)
  330. X+         (if (Math-zerop vhigh)
  331. X+         (list 'vec high vhigh)
  332. X+           (if deriv
  333. X+           (math-newton-search-root expr deriv nil nil nil nil
  334. X+                        low vlow high vhigh)
  335. X+         (if (or (and (Math-posp vlow) (Math-posp vhigh))
  336. X+             (and (Math-negp vlow) (Math-negp vhigh)))
  337. X+             (math-search-root expr deriv low vlow high vhigh)
  338. X+           (math-bisect-root expr low vlow high vhigh)))))))))
  339. X+ )
  340. X+ 
  341. X+ (defun calcFunc-root (expr var guess)
  342. X+   (math-find-root expr var guess nil)
  343. X+ )
  344. X+ 
  345. X+ (defun calcFunc-wroot (expr var guess)
  346. X+   (math-find-root expr var guess t)
  347. X+ )
  348. X+ 
  349. X+ 
  350. X+ 
  351. X+ 
  352. X+ ;;; The following algorithms come from Numerical Recipes, chapter 10.
  353. X+ 
  354. X+ (defun math-min-eval (expr a)
  355. X+   (if (Math-vectorp a)
  356. X+       (let ((m -1))
  357. X+     (while (setq m (1+ m) a (cdr a))
  358. X+       (set (nth 2 (aref math-min-vars m)) (car a))))
  359. X+     (setq var-DUMMY a))
  360. X+   (setq a (math-evaluate-expr expr))
  361. X+   (if (Math-ratp a)
  362. X+       (math-float a)
  363. X+     (if (eq (car a) 'float)
  364. X+     a
  365. X+       (math-reject-arg a 'realp)))
  366. X+ )
  367. X+ 
  368. X+ 
  369. X+ ;;; A bracket for a minimum is a < b < c where f(b) < f(a) and f(b) < f(c).
  370. X+ 
  371. X+ ;;; "mnbrak"
  372. X+ (defun math-widen-min (expr a b)
  373. X+   (let ((done nil)
  374. X+     (iters 30)
  375. X+     incr c va vb vc u vu r q ulim bc ba qr)
  376. X+     (or b (setq b (math-mul a '(float 101 -2))))
  377. X+     (setq va (math-min-eval expr a)
  378. X+       vb (math-min-eval expr b))
  379. X+     (if (math-lessp-float va vb)
  380. X+     (setq u a a b b u
  381. X+           vu va va vb vb vu))
  382. X+     (setq c (math-add-float b (math-mul-float '(float 161803 -5)
  383. X+                           (math-sub-float b a)))
  384. X+       vc (math-min-eval expr c))
  385. X+     (while (and (not done) (math-lessp-float vc vb))
  386. X+       (math-working "widen" (list 'intv 0 a c))
  387. X+       (if (= (setq iters (1- iters)) 0)
  388. X+       (math-reject-arg nil "Unable to find a minimum near the interval"))
  389. X+       (setq bc (math-sub-float b c)
  390. X+         ba (math-sub-float b a)
  391. X+         r (math-mul-float ba (math-sub-float vb vc))
  392. X+         q (math-mul-float bc (math-sub-float vb va))
  393. X+         qr (math-sub-float q r))
  394. X+       (if (math-lessp-float (math-abs qr) '(float 1 -20))
  395. X+       (setq qr (if (math-negp qr) '(float -1 -20) '(float 1 -20))))
  396. X+       (setq u (math-sub-float
  397. X+            b
  398. X+            (math-div-float (math-sub-float (math-mul-float bc q)
  399. X+                            (math-mul-float ba r))
  400. X+                    (math-mul-float '(float 2 0) qr)))
  401. X+         ulim (math-add-float b (math-mul-float '(float -1 2) bc))
  402. X+         incr (math-negp bc))
  403. X+       (if (if incr (math-lessp-float b u) (math-lessp-float u b))
  404. X+       (if (if incr (math-lessp-float u c) (math-lessp-float c u))
  405. X+           (if (math-lessp-float (setq vu (math-min-eval expr u)) vc)
  406. X+           (setq a b  va vb
  407. X+             b u  vb vu
  408. X+             done t)
  409. X+         (if (math-lessp-float vb vu)
  410. X+             (setq c u  vc vu
  411. X+               done t)
  412. X+           (setq u (math-add-float c (math-mul-float '(float -161803 -5)
  413. X+                                 bc))
  414. X+             vu (math-min-eval expr u))))
  415. X+         (if (if incr (math-lessp-float u ulim) (math-lessp-float ulim u))
  416. X+         (if (math-lessp-float (setq vu (math-min-eval expr u)) vc)
  417. X+             (setq b c  vb vc
  418. X+               c u  vc vu
  419. X+               u (math-add-float c (math-mul-float
  420. X+                            '(float -161803 -5)
  421. X+                            (math-sub-float b c)))
  422. X+               vu (math-min-eval expr u)))
  423. X+           (setq u ulim
  424. X+             vu (math-min-eval expr u))))
  425. X+     (setq u (math-add-float c (math-mul-float '(float -161803 -5)
  426. X+                           bc))
  427. X+           vu (math-min-eval expr u)))
  428. X+       (setq a b  va vb
  429. X+         b c  vb vc
  430. X+         c u  vc vu))
  431. X+     (if (math-lessp-float a c)
  432. X+     (list a va b vb c vc)
  433. X+       (list c vc b vb a va)))
  434. X+ )
  435. X+ 
  436. X+ (defun math-narrow-min (expr a c)
  437. X+   (let ((xvals (list a c))
  438. X+     (yvals (list (math-min-eval expr a)
  439. X+              (math-min-eval expr c)))
  440. X+     (levels 0)
  441. X+     (step (math-sub-float c a))
  442. X+     (found nil)
  443. X+     xp yp b)
  444. X+     (while (and (<= (setq levels (1+ levels)) 5)
  445. X+         (not found))
  446. X+       (setq xp xvals
  447. X+         yp yvals
  448. X+         step (math-mul-float step '(float 497 -3)))
  449. X+       (while (and (cdr xp) (not found))
  450. X+     (setq b (math-add-float (car xp) step))
  451. X+     (math-working "search" b)
  452. X+     (setcdr xp (cons b (cdr xp)))
  453. X+     (setcdr yp (cons (math-min-eval expr b) (cdr yp)))
  454. X+     (if (and (math-lessp-float (nth 1 yp) (car yp))
  455. X+          (math-lessp-float (nth 1 yp) (nth 2 yp)))
  456. X+         (setq found t)
  457. X+       (setq xp (cdr xp)
  458. X+         yp (cdr yp))
  459. X+       (if (and (cdr (cdr yp))
  460. X+            (math-lessp-float (nth 1 yp) (car yp))
  461. X+            (math-lessp-float (nth 1 yp) (nth 2 yp)))
  462. X+           (setq found t)
  463. X+         (setq xp (cdr xp)
  464. X+           yp (cdr yp))))))
  465. X+     (if found
  466. X+     (list (car xp) (car yp)
  467. X+           (nth 1 xp) (nth 1 yp)
  468. X+           (nth 2 xp) (nth 2 yp))
  469. X+       (math-reject-arg nil "Unable to find a minimum in the interval")))
  470. X+ )
  471. X+ 
  472. X+ ;;; "brent"
  473. X+ (defun math-brent-min (expr prec a va x vx b vb)
  474. X+   (let ((iters (+ 20 (* 5 prec)))
  475. X+     (w x)
  476. X+     (vw vx)
  477. X+     (v x)
  478. X+     (vv vx)
  479. X+     (tol (list 'float 1 (- -1 prec)))
  480. X+     (zeps (list 'float 1 (- -5 prec)))
  481. X+     (e '(float 0 0))
  482. X+     u vu xm tol1 tol2 etemp p q r xv xw)
  483. X+     (while (progn
  484. X+          (setq xm (math-mul-float '(float 5 -1)
  485. X+                       (math-add-float a b))
  486. X+            tol1 (math-add-float
  487. X+              zeps
  488. X+              (math-mul-float tol (math-abs x)))
  489. X+            tol2 (math-mul-float tol1 '(float 2 0)))
  490. X+          (math-lessp-float (math-sub-float tol2
  491. X+                            (math-mul-float
  492. X+                         '(float 5 -1)
  493. X+                         (math-sub-float b a)))
  494. X+                    (math-abs (math-sub-float x xm))))
  495. X+       (if (= (setq iters (1- iters)) 0)
  496. X+       (math-reject-arg nil "Unable to converge on a minimum"))
  497. X+       (math-working "brent" x)
  498. X+       (if (math-lessp-float (math-abs e) tol1)
  499. X+       (setq e (if (math-lessp-float x xm)
  500. X+               (math-sub-float b x)
  501. X+             (math-sub-float a x))
  502. X+         d (math-mul-float '(float 381966 -6) e))
  503. X+     (setq xw (math-sub-float x w)
  504. X+           r (math-mul-float xw (math-sub-float vx vv))
  505. X+           xv (math-sub-float x v)
  506. X+           q (math-mul-float xv (math-sub-float vx vw))
  507. X+           p (math-sub-float (math-mul-float xv q)
  508. X+                 (math-mul-float xw r))
  509. X+           q (math-mul-float '(float 2 0) (math-sub-float q r)))
  510. X+     (if (math-posp q)
  511. X+         (setq p (math-neg-float p))
  512. X+       (setq q (math-neg-float q)))
  513. X+     (setq etemp e
  514. X+           e d)
  515. X+     (if (and (math-lessp-float (math-abs p)
  516. X+                    (math-abs (math-mul-float
  517. X+                           '(float 5 -1)
  518. X+                           (math-mul-float q etemp))))
  519. X+          (math-lessp-float (math-mul-float
  520. X+                     q (math-sub-float a x)) p)
  521. X+          (math-lessp-float p (math-mul-float
  522. X+                       q (math-sub-float b x))))
  523. X+         (progn
  524. X+           (setq d (math-div-float p q)
  525. X+             u (math-add-float x d))
  526. X+           (if (or (math-lessp-float (math-sub-float u a) tol2)
  527. X+               (math-lessp-float (math-sub-float b u) tol2))
  528. X+           (setq d (if (math-lessp-float xm x)
  529. X+                   (math-neg-float tol1)
  530. X+                 tol1))))
  531. X+       (setq e (if (math-lessp-float x xm)
  532. X+               (math-sub-float b x)
  533. X+             (math-sub-float a x))
  534. X+         d (math-mul-float '(float 381966 -6) e))))
  535. X+       (setq u (math-add-float x
  536. X+                   (if (math-lessp-float (math-abs d) tol1)
  537. X+                   (if (math-negp d)
  538. X+                       (math-neg-float tol1)
  539. X+                     tol1)
  540. X+                 d))
  541. X+         vu (math-min-eval expr u))
  542. X+       (if (math-lessp-float vx vu)
  543. X+       (progn
  544. X+         (if (math-lessp-float u x)
  545. X+         (setq a u)
  546. X+           (setq b u))
  547. X+         (if (or (equal w x)
  548. X+             (not (math-lessp-float vw vu)))
  549. X+         (setq v w  vv vw
  550. X+               w u  vw vu)
  551. X+           (if (or (equal v x)
  552. X+               (equal v w)
  553. X+               (not (math-lessp-float vv vu)))
  554. X+           (setq v u  vv vu))))
  555. X+     (if (math-lessp-float u x)
  556. X+         (setq b x)
  557. X+       (setq a x))
  558. X+     (setq v w  vv vw
  559. X+           w x  vw vx
  560. X+           x u  vx vu)))
  561. X+     (list 'vec x vx))
  562. X+ )
  563. X+ 
  564. X+ ;;; "powell"
  565. X+ (defun math-powell-min (expr n guesses prec)
  566. X+   (let* ((f1dim (math-line-min-func expr n))
  567. X+      (xi (math-diag-matrix 1 n))
  568. X+      (p (cons 'vec (mapcar 'car guesses)))
  569. X+      (pt p)
  570. X+      (ftol (list 'float 1 (- prec)))
  571. X+      (fret (math-min-eval expr p))
  572. X+      fp ptt fptt xit i ibig del diff res)
  573. X+     (while (progn
  574. X+          (setq fp fret
  575. X+            ibig 0
  576. X+            del '(float 0 0)
  577. X+            i 0)
  578. X+          (while (<= (setq i (1+ i)) n)
  579. X+            (setq fptt fret
  580. X+              res (math-line-min f1dim p
  581. X+                     (math-mat-col xi i)
  582. X+                     n prec)
  583. X+              p (let ((calc-internal-prec prec))
  584. X+              (math-normalize (car res)))
  585. X+              fret (nth 2 res)
  586. X+              diff (math-abs (math-sub-float fptt fret)))
  587. X+            (if (math-lessp-float del diff)
  588. X+            (setq del diff
  589. X+              ibig i)))
  590. X+          (math-lessp-float
  591. X+           (math-mul-float ftol
  592. X+                   (math-add-float (math-abs fp)
  593. X+                           (math-abs fret)))
  594. X+           (math-mul-float '(float 2 0)
  595. X+                   (math-abs (math-sub-float fp
  596. X+                             fret)))))
  597. X+       (setq ptt (math-sub (math-mul '(float 2 0) p) pt)
  598. X+         xit (math-sub p pt)
  599. X+         pt p
  600. X+         fptt (math-min-eval expr ptt))
  601. X+       (if (and (math-lessp-float fptt fp)
  602. X+            (math-lessp-float
  603. X+         (math-mul-float
  604. X+          (math-mul-float '(float 2 0)
  605. X+                  (math-add-float
  606. X+                   (math-sub-float fp
  607. X+                           (math-mul-float '(float 2 0)
  608. X+                                   fret))
  609. X+                   fptt))
  610. X+          (math-sqr-float (math-sub-float
  611. X+                   (math-sub-float fp fret) del)))
  612. X+         (math-mul-float del
  613. X+                 (math-sqr-float (math-sub-float fp fptt)))))
  614. X+       (progn
  615. X+         (setq res (math-line-min f1dim p xit n prec)
  616. X+           p (car res)
  617. X+           fret (nth 2 res)
  618. X+           i 0)
  619. X+         (while (<= (setq i (1+ i)) n)
  620. X+           (setcar (nthcdr ibig (nth i xi))
  621. X+               (nth i (nth 1 res)))))))
  622. X+     (list 'vec p fret))
  623. X+ )
  624. X+ 
  625. X+ (defun math-line-min-func (expr n)
  626. X+   (let ((m -1))
  627. X+     (while (< (setq m (1+ m)) n)
  628. X+       (set (nth 2 (aref math-min-vars m))
  629. X+        (list '+
  630. X+          (list '*
  631. X+                '(var DUMMY var-DUMMY)
  632. X+                (list 'calcFunc-mrow '(var line-xi line-xi) (1+ m)))
  633. X+          (list 'calcFunc-mrow '(var line-p line-p) (1+ m)))))
  634. X+     (math-evaluate-expr expr))
  635. X+ )
  636. X+ 
  637. X+ (defun math-line-min (f1dim line-p line-xi n prec)
  638. X+   (let* ((var-DUMMY nil)
  639. X+      (expr (math-evaluate-expr f1dim))
  640. X+      (params (math-widen-min expr '(float 0 0) '(float 1 0)))
  641. X+      (res (apply 'math-brent-min expr prec params))
  642. X+      (xi (math-mul (nth 1 res) line-xi)))
  643. X+     (list (math-add line-p xi) xi (nth 2 res)))
  644. X+ )
  645. X+ 
  646. X+ 
  647. X+ (defvar math-min-vars [(var DUMMY var-DUMMY)])
  648. X+ 
  649. X+ (defun math-find-minimum (expr var guess min-widen)
  650. X+   (let* ((calc-symbolic-flag nil)
  651. X+      (n 0)
  652. X+      (var-DUMMY nil)
  653. X+      (isvec (math-vectorp var))
  654. X+      g guesses)
  655. X+     (or (math-vectorp var)
  656. X+     (setq var (list 'vec var)))
  657. X+     (or (math-vectorp guess)
  658. X+     (setq guess (list 'vec guess)))
  659. X+     (or (= (length var) (length guess))
  660. X+     (math-dimension-error))
  661. X+     (while (setq var (cdr var) guess (cdr guess))
  662. X+       (or (eq (car-safe (car var)) 'var)
  663. X+       (math-reject-arg (car vg) "Expected a variable"))
  664. X+       (or (math-expr-contains expr (car var))
  665. X+       (math-reject-arg (car var)
  666. X+                "Formula does not contain specified variable"))
  667. X+       (while (>= (1+ n) (length math-min-vars))
  668. X+     (let ((symb (intern (concat "math-min-v"
  669. X+                     (int-to-string
  670. X+                      (length math-min-vars))))))
  671. X+       (setq math-min-vars (vconcat math-min-vars
  672. X+                        (vector (list 'var symb symb))))))
  673. X+       (set (nth 2 (aref math-min-vars n)) nil)
  674. X+       (set (nth 2 (aref math-min-vars (1+ n))) nil)
  675. X+       (if (math-complexp (car guess))
  676. X+       (setq expr (math-expr-subst expr
  677. X+                       (car var)
  678. X+                       (list '+ (aref math-min-vars n)
  679. X+                         (list '*
  680. X+                           (aref math-min-vars (1+ n))
  681. X+                           '(cplx 0 1))))
  682. X+         guesses (let ((g (math-float (math-complex (car guess)))))
  683. X+               (cons (list (nth 2 g) nil nil)
  684. X+                 (cons (list (nth 1 g) nil nil t)
  685. X+                       guesses)))
  686. X+         n (+ n 2))
  687. X+     (setq expr (math-expr-subst expr
  688. X+                     (car var)
  689. X+                     (aref math-min-vars n))
  690. X+           guesses (cons (if (math-realp (car guess))
  691. X+                 (list (math-float (car guess)) nil nil)
  692. X+                   (if (eq (car-safe (car guess)) 'intv)
  693. X+                   (list (math-mul
  694. X+                      (math-add (nth 2 (car guess))
  695. X+                            (nth 3 (car guess)))
  696. X+                      '(float 5 -1))
  697. X+                     (math-float (nth 2 (car guess)))
  698. X+                     (math-float (nth 3 (car guess))))
  699. X+                 (math-reject-arg
  700. X+                  (car guess)
  701. X+                  "Guess must be a number or an interval")))
  702. X+                 guesses)
  703. X+           n (1+ n))))
  704. X+     (setq guesses (nreverse guesses)
  705. X+       expr (math-evaluate-expr expr))
  706. X+     (if (= n 1)
  707. X+     (let* ((params (if (nth 1 (car guesses))
  708. X+                (if min-widen
  709. X+                    (math-widen-min expr
  710. X+                            (nth 1 (car guesses))
  711. X+                            (nth 2 (car guesses)))
  712. X+                  (math-narrow-min expr
  713. X+                           (nth 1 (car guesses))
  714. X+                           (nth 2 (car guesses))))
  715. X+              (math-widen-min expr
  716. X+                      (car (car guesses))
  717. X+                      nil)))
  718. X+            (prec calc-internal-prec)
  719. X+            (res (math-with-extra-prec (+ calc-internal-prec 2)
  720. X+               (apply 'math-brent-min expr prec params))))
  721. X+       (if isvec
  722. X+           (list 'vec (list 'vec (nth 1 res)) (nth 2 res))
  723. X+         res))
  724. X+       (let* ((prec calc-internal-prec)
  725. X+          (res (math-with-extra-prec (+ calc-internal-prec 2)
  726. X+             (math-powell-min expr n guesses prec)))
  727. X+          (p (nth 1 res))
  728. X+          (vec (list 'vec)))
  729. X+     (while (setq p (cdr p))
  730. X+       (if (nth 3 (car guesses))
  731. X+           (progn
  732. X+         (nconc vec (list (math-normalize
  733. X+                   (list 'cplx (car p) (nth 1 p)))))
  734. X+         (setq p (cdr p)
  735. X+               guesses (cdr guesses)))
  736. X+         (nconc vec (list (car p))))
  737. X+       (setq guesses (cdr guesses)))
  738. X+     (if isvec
  739. X+         (list 'vec vec (nth 2 res))
  740. X+       (list 'vec (nth 1 vec) (nth 2 res))))))
  741. X+ )
  742. X+ 
  743. X+ (defun calcFunc-minimize (expr var guess)
  744. X+   (let ((calc-internal-prec (max (/ calc-internal-prec 2) 3)))
  745. X+     (math-find-minimum (math-normalize expr)
  746. X+                (math-normalize var)
  747. X+                (math-normalize guess) nil))
  748. X+ )
  749. X+ 
  750. X+ (defun calcFunc-wminimize (expr var guess)
  751. X+   (let ((calc-internal-prec (max (/ calc-internal-prec 2) 3)))
  752. X+     (math-find-minimum (math-normalize expr)
  753. X+                (math-normalize var)
  754. X+                (math-normalize guess) t))
  755. X+ )
  756. X+ 
  757. X+ (defun calcFunc-maximize (expr var guess)
  758. X+   (let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3))
  759. X+      (res (math-find-minimum (math-normalize (math-neg expr))
  760. X+                  (math-normalize var)
  761. X+                  (math-normalize guess) nil)))
  762. X+     (list 'vec (nth 1 res) (math-neg (nth 2 res))))
  763. X+ )
  764. X+ 
  765. X+ (defun calcFunc-wmaximize (expr var guess)
  766. X+   (let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3))
  767. X+      (res (math-find-minimum (math-normalize (math-neg expr))
  768. X+                  (math-normalize var)
  769. X+                  (math-normalize guess) t)))
  770. X+     (list 'vec (nth 1 res) (math-neg (nth 2 res))))
  771. X+ )
  772. X+ 
  773. X+ 
  774. X+ 
  775. X+ 
  776. X  ;;;; [calc-alg.el]
  777. X  
  778. X  ;;; Simple operations on expressions.
  779. X***************
  780. X*** 13025,13030 ****
  781. X--- 20876,20882 ----
  782. X      (math-build-polynomial-expr p base)
  783. X        expr))
  784. X  )
  785. X+ (fset 'calcFunc-collect (symbol-function 'math-collect-terms))
  786. X  
  787. X  ;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
  788. X  ;;; else return nil if not in polynomial form.  If "loose", coefficients
  789. X***************
  790. X*** 13178,13189 ****
  791. X  ;;; Build an expression from a polynomial list.
  792. X  (defun math-build-polynomial-expr (p var)
  793. X    (if p
  794. X!       (let ((accum (car p))
  795. X!         (n 0))
  796. X!     (while (setq p (cdr p))
  797. X!       (setq n (1+ n)
  798. X!         accum (math-add (math-mul (car p) (math-pow var n)) accum)))
  799. X!     accum))
  800. X  )
  801. X  
  802. X  
  803. X--- 21030,21056 ----
  804. X  ;;; Build an expression from a polynomial list.
  805. X  (defun math-build-polynomial-expr (p var)
  806. X    (if p
  807. X!       (if (Math-numberp var)
  808. X!       (math-with-extra-prec 1
  809. X!         (let* ((rp (reverse p))
  810. X!            (accum (car rp)))
  811. X!           (while (setq rp (cdr rp))
  812. X!         (setq accum (math-add (car rp) (math-mul accum var))))
  813. X!           accum))
  814. X!     (let* ((rp (reverse p))
  815. X!            (n (1- (length rp)))
  816. X!            (accum (math-mul (car rp) (math-pow var n)))
  817. X!            term)
  818. X!       (while (setq rp (cdr rp))
  819. X!         (setq n (1- n))
  820. X!         (or (math-zerop (car rp))
  821. X!         (setq accum (list (if (math-looks-negp (car rp)) '- '+)
  822. X!                   accum
  823. X!                   (math-mul (if (math-looks-negp (car rp))
  824. X!                         (math-neg (car rp))
  825. X!                           (car rp))
  826. X!                         (math-pow var n))))))
  827. X!       accum)))
  828. X  )
  829. X  
  830. X  
  831. X***************
  832. X*** 13415,13422 ****
  833. X        (let* ((combined-units (append math-additional-units
  834. X                       math-standard-units))
  835. X           (unit-list (mapcar 'car combined-units))
  836. X-          (calc-language nil)
  837. X-          (math-expr-opers math-standard-opers)
  838. X           tab)
  839. X      (message "Building units table...")
  840. X      (setq math-units-table-buffer-valid nil)
  841. X--- 21282,21287 ----
  842. X***************
  843. X*** 13425,13431 ****
  844. X                   (list (car x)
  845. X                     (and (nth 1 x)
  846. X                      (if (stringp (nth 1 x))
  847. X!                         (let ((exp (math-read-expr
  848. X                              (nth 1 x))))
  849. X                            (if (eq (car-safe exp) 'error)
  850. X                            (error "Format error in definition of %s in units table: %s"
  851. X--- 21290,21296 ----
  852. X                   (list (car x)
  853. X                     (and (nth 1 x)
  854. X                      (if (stringp (nth 1 x))
  855. X!                         (let ((exp (math-read-plain-expr
  856. X                              (nth 1 x))))
  857. X                            (if (eq (car-safe exp) 'error)
  858. X                            (error "Format error in definition of %s in units table: %s"
  859. X***************
  860. X*** 13648,13653 ****
  861. X--- 21513,21519 ----
  862. X    (let ((math-simplifying-units t))
  863. X      (math-simplify a))
  864. X  )
  865. X+ (fset 'calcFunc-usimplify (symbol-function 'math-simplify-units))
  866. X  
  867. X  (math-defsimplify (+ -)
  868. X    (and math-simplifying-units
  869. X***************
  870. X*** 13667,13672 ****
  871. X--- 21533,21544 ----
  872. X    (and math-simplifying-units
  873. X         (let ((np (cdr expr))
  874. X           n nn)
  875. X+      (if (or (math-floatp (car (setq n (nthcdr 2 expr))))
  876. X+          (and (eq (car-safe (nth 2 expr)) '*)
  877. X+               (math-floatp (car (setq n (cdr (nth 2 expr)))))))
  878. X+          (progn
  879. X+            (setcar (cdr expr) (math-mul (nth 1 expr) (math-div 1 (car n))))
  880. X+            (setcar n 1)))
  881. X       (while (eq (car-safe (setq n (car np))) '*)
  882. X         (math-simplify-units-divisor (cdr n) (cdr (cdr expr)))
  883. X         (setq np (cdr (cdr n))))
  884. X***************
  885. X*** 13931,13936 ****
  886. X--- 21803,21809 ----
  887. X  ;;; Compiling Lisp-like forms to use the math library.
  888. X  
  889. X  (defun math-do-defmath (func args body)
  890. X+   (calc-need-macros)
  891. X    (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
  892. X       (doc (if (stringp (car body)) (list (car body))))
  893. X       (clargs (mapcar 'math-clean-arg args))
  894. X***************
  895. X*** 14140,14151 ****
  896. X      ((and (eq (car body) ':)
  897. X            (stringp (nth 1 body)))
  898. X       (cons (let* ((math-read-expr-quotes t)
  899. X!               (calc-language nil)
  900. X!               (math-expr-opers math-standard-opers)
  901. X!               (exp (math-read-expr (nth 1 body))))
  902. X!          (if (eq (car exp) 'error)
  903. X!              (error "Bad format: %s" (nth 1 body))
  904. X!            (math-define-exp exp)))
  905. X             (math-define-list (cdr (cdr body)))))
  906. X      (quote
  907. X       (cons (cond ((consp (car body))
  908. X--- 22013,22020 ----
  909. X      ((and (eq (car body) ':)
  910. X            (stringp (nth 1 body)))
  911. X       (cons (let* ((math-read-expr-quotes t)
  912. X!               (exp (math-read-plain-expr (nth 1 body) t)))
  913. X!          (math-define-exp exp))
  914. X             (math-define-list (cdr (cdr body)))))
  915. X      (quote
  916. X       (cons (cond ((consp (car body))
  917. X***************
  918. X*** 14516,14521 ****
  919. X--- 22385,22413 ----
  920. X  
  921. X    (cond
  922. X  
  923. X+    ;; Integer+fractions
  924. X+    ((string-match "^\\([0-9]*\\)[:/]\\([0-9]*\\)[:/]\\([0-9]*\\)$" s)
  925. X+     (let ((int (math-match-substring s 1))
  926. X+       (num (math-match-substring s 2))
  927. X+       (den (math-match-substring s 3)))
  928. X+       (let ((int (if (> (length int) 0) (math-read-number int) 0))
  929. X+         (num (if (> (length num) 0) (math-read-number num) 1))
  930. X+         (den (if (> (length num) 0) (math-read-number den) 1)))
  931. X+     (and int num den
  932. X+          (math-integerp int) (math-integerp num) (math-integerp den)
  933. X+          (not (math-zerop den))
  934. X+          (list 'frac (math-add num (math-mul int den)) den)))))
  935. X+    
  936. X+    ;; Fractions
  937. X+    ((string-match "^\\([0-9]*\\)[:/]\\([0-9]*\\)$" s)
  938. X+     (let ((num (math-match-substring s 1))
  939. X+       (den (math-match-substring s 2)))
  940. X+       (let ((num (if (> (length num) 0) (math-read-number num) 1))
  941. X+         (den (if (> (length num) 0) (math-read-number den) 1)))
  942. X+     (and num den (math-integerp num) (math-integerp den)
  943. X+          (not (math-zerop den))
  944. X+          (list 'frac num den)))))
  945. X+    
  946. X     ;; Modulo forms
  947. X     ((string-match "^\\(.*\\) *mod *\\(.*\\)$" s)
  948. X      (let* ((n (math-match-substring s 1))
  949. X***************
  950. X*** 14647,14653 ****
  951. X      (exp-keep-spaces nil)
  952. X      exp-token exp-data)
  953. X      (while (setq exp-token (string-match "\\.\\." exp-str))
  954. X!       (setq exp-str (concat (substring exp-str exp-token) "\\dots"
  955. X                  (substring exp-str (+ exp-token 2)))))
  956. X      (math-read-token)
  957. X      (let ((val (catch 'syntax (math-read-expr-level 0))))
  958. X--- 22539,22545 ----
  959. X      (exp-keep-spaces nil)
  960. X      exp-token exp-data)
  961. X      (while (setq exp-token (string-match "\\.\\." exp-str))
  962. X!       (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots"
  963. X                  (substring exp-str (+ exp-token 2)))))
  964. X      (math-read-token)
  965. X      (let ((val (catch 'syntax (math-read-expr-level 0))))
  966. X***************
  967. X*** 14658,14663 ****
  968. X--- 22550,22565 ----
  969. X        (list 'error exp-old-pos "Syntax error")))))
  970. X  )
  971. X  
  972. X+ (defun math-read-plain-expr (exp-str &optional error-check)
  973. X+   (let* ((calc-language nil)
  974. X+      (math-expr-opers math-standard-opers)
  975. X+      (val (math-read-expr exp-str)))
  976. X+     (and error-check
  977. X+      (eq (car-safe val) 'error)
  978. X+      (error "%s: %s" (nth 2 val) exp-str))
  979. X+     val)
  980. X+ )
  981. X+ 
  982. X  ;;;; [calc-vec.el]
  983. X  
  984. X  (defun math-read-brackets (space-sep close)
  985. X***************
  986. X*** 14761,14768 ****
  987. X     ((eq (car a) 'incomplete)
  988. X      (concat "'" (prin1-to-string a)))
  989. X     ((eq (car a) 'vec)
  990. X!     (concat "[" (math-format-flat-vector (cdr a) ", "
  991. X!                      (if (cdr (cdr a)) 0 1000)) "]"))
  992. X     ((eq (car a) 'intv)
  993. X      (concat (if (memq (nth 1 a) '(0 1)) "(" "[")
  994. X          (math-format-flat-expr (nth 2 a) 1000)
  995. X--- 22663,22677 ----
  996. X     ((eq (car a) 'incomplete)
  997. X      (concat "'" (prin1-to-string a)))
  998. X     ((eq (car a) 'vec)
  999. X!     (if (or calc-full-trail-vectors (not calc-can-abbrev-vectors)
  1000. X!         (< (length a) 7))
  1001. X!     (concat "[" (math-format-flat-vector (cdr a) ", "
  1002. X!                          (if (cdr (cdr a)) 0 1000)) "]")
  1003. X!       (concat "["
  1004. X!           (math-format-flat-expr (nth 1 a) 0) ", "
  1005. X!           (math-format-flat-expr (nth 2 a) 0) ", "
  1006. X!           (math-format-flat-expr (nth 3 a) 0) ", ..., "
  1007. X!           (math-format-flat-expr (nth (1- (length a)) a) 0) "]")))
  1008. X     ((eq (car a) 'intv)
  1009. X      (concat (if (memq (nth 1 a) '(0 1)) "(" "[")
  1010. X          (math-format-flat-expr (nth 2 a) 1000)
  1011. X***************
  1012. X*** 14805,14810 ****
  1013. X--- 22714,22744 ----
  1014. X      buf)
  1015. X      "")
  1016. X  )
  1017. X+ (setq calc-can-abbrev-vectors nil)
  1018. X+ 
  1019. X+ (defun math-format-nice-expr (x w)
  1020. X+   (cond ((and (eq (car-safe x) 'vec)
  1021. X+           (cdr (cdr x))
  1022. X+           (or (eq (car-safe (nth 1 x)) 'vec)
  1023. X+           (eq (car-safe (nth 2 x)) 'vec)
  1024. X+           (eq (car-safe (nth 3 x)) 'vec)
  1025. X+           calc-break-vectors))
  1026. X+      (concat "[ " (math-format-flat-vector (cdr x) ",\n  " 0) " ]"))
  1027. X+     (t
  1028. X+      (let ((str (math-format-flat-expr x 0))
  1029. X+            (pos 0) p)
  1030. X+        (or (string-match "\"" str)
  1031. X+            (while (<= (setq p (+ pos w)) (length str))
  1032. X+          (while (and (> (setq p (1- p)) pos)
  1033. X+                  (not (= (aref str p) ? ))))
  1034. X+          (if (> p (+ pos 5))
  1035. X+              (setq str (concat (substring str 0 p)
  1036. X+                        "\n "
  1037. X+                        (substring str p))
  1038. X+                pos (1+ p))
  1039. X+            (setq pos (+ pos w)))))
  1040. X+        str)))
  1041. X+ )
  1042. X  
  1043. X  (defun math-assq2 (v a)
  1044. X    (cond ((null a) nil)
  1045. X***************
  1046. X*** 14815,14831 ****
  1047. X  
  1048. X  (defun math-format-number-fancy (a)
  1049. X    (cond
  1050. X     ((eq (car a) 'cplx)
  1051. X!     (if (null calc-complex-format)
  1052. X!     (concat "(" (math-format-number (nth 1 a))
  1053. X!         ", " (math-format-number (nth 2 a)) ")")
  1054. X!       (if (math-zerop (nth 1 a))
  1055. X!       (concat (math-format-number (nth 2 a))
  1056. X!           (symbol-name calc-complex-format))
  1057. X!     (concat (math-format-number (nth 1 a))
  1058. X!         (if (math-negp (nth 2 a)) " - " " + ")
  1059. X!         (math-format-number (math-abs (nth 2 a)))
  1060. X!         (symbol-name calc-complex-format)))))
  1061. X     ((eq (car a) 'polar)
  1062. X      (concat "(" (math-format-number (nth 1 a))
  1063. X          "; " (math-format-number (nth 2 a)) ")"))
  1064. X--- 22749,22783 ----
  1065. X  
  1066. X  (defun math-format-number-fancy (a)
  1067. X    (cond
  1068. X+    ((eq (car a) 'frac)
  1069. X+     (if (> (length calc-frac-format) 1)
  1070. X+     (if (Math-integer-negp (nth 1 a))
  1071. X+         (concat "-" (math-format-number (math-neg a)))
  1072. X+       (let ((q (math-idivmod (nth 1 a) (nth 2 a))))
  1073. X+         (concat (math-format-number (car q))
  1074. X+             (substring calc-frac-format 0 1)
  1075. X+             (let ((math-radix-explicit-format nil))
  1076. X+               (math-format-number (cdr q)))
  1077. X+             (substring calc-frac-format 1 2)
  1078. X+             (let ((math-radix-explicit-format nil))
  1079. X+               (math-format-number (nth 2 a))))))
  1080. X+       (concat (math-format-number (nth 1 a))
  1081. X+           calc-frac-format
  1082. X+           (let ((math-radix-explicit-format nil))
  1083. X+         (math-format-number (nth 2 a))))))
  1084. X     ((eq (car a) 'cplx)
  1085. X!     (if (math-zerop (nth 2 a))
  1086. X!     (math-format-number (nth 1 a))
  1087. X!       (if (null calc-complex-format)
  1088. X!       (concat "(" (math-format-number (nth 1 a))
  1089. X!           ", " (math-format-number (nth 2 a)) ")")
  1090. X!     (if (math-zerop (nth 1 a))
  1091. X!         (concat (math-format-number (nth 2 a))
  1092. X!             (symbol-name calc-complex-format))
  1093. X!       (concat (math-format-number (nth 1 a))
  1094. X!           (if (math-negp (nth 2 a)) " - " " + ")
  1095. X!           (math-format-number (math-abs (nth 2 a)))
  1096. X!           (symbol-name calc-complex-format))))))
  1097. X     ((eq (car a) 'polar)
  1098. X      (concat "(" (math-format-number (nth 1 a))
  1099. X          "; " (math-format-number (nth 2 a)) ")"))
  1100. X***************
  1101. X*** 14839,14844 ****
  1102. X--- 22791,22808 ----
  1103. X          (math-format-number (nth 1 a))
  1104. X          (math-format-number (nth 2 a))
  1105. X          (math-format-number (nth 3 a))))))
  1106. X+    ((eq (car a) 'intv)
  1107. X+     (concat (if (memq (nth 1 a) '(0 1)) "(" "[")
  1108. X+         (math-format-number (nth 2 a))
  1109. X+         " .. "
  1110. X+         (math-format-number (nth 3 a))
  1111. X+         (if (memq (nth 1 a) '(0 2)) ")" "]")))
  1112. X+    ((eq (car a) 'sdev)
  1113. X+     (concat (math-format-number (nth 1 a))
  1114. X+         " +/- "
  1115. X+         (math-format-number (nth 2 a))))
  1116. X+    ((eq (car a) 'vec)
  1117. X+     (math-format-flat-expr a 0))
  1118. X     (t (format "%s" a)))
  1119. X  )
  1120. X  
  1121. X***************
  1122. X*** 15033,15042 ****
  1123. X--- 22997,23014 ----
  1124. X  ;;;    (supscr C1 C2)        Composition C1 with superscript C2
  1125. X  ;;;    (subscr C1 C2)        Composition C1 with subscript C2
  1126. X  ;;;    (rule)                Horizontal line, full width of enclosing comp
  1127. X+ ;;;
  1128. X+ ;;;    (tag X C)             Composition C corresponds to sub-expression X
  1129. X  
  1130. X  (defun math-compose-expr (a prec)
  1131. X    (let ((math-compose-level (1+ math-compose-level)))
  1132. X      (cond
  1133. X+      ((or (eq a math-comp-selected)
  1134. X+       (and math-comp-tagged
  1135. X+            (not (eq math-comp-tagged a))))
  1136. X+       (let ((math-comp-selected nil))
  1137. X+     (and math-comp-tagged (setq math-comp-tagged a))
  1138. X+     (list 'tag a (math-compose-expr a prec))))
  1139. X       ((math-scalarp a)
  1140. X        (if (and (eq (car-safe a) 'frac)
  1141. X             (memq calc-language '(tex math)))
  1142. X***************
  1143. X*** 15048,15064 ****
  1144. X                    (substring calc-vector-brackets 0 1) ""))
  1145. X          (right-bracket (if calc-vector-brackets
  1146. X                     (substring calc-vector-brackets 1 2) ""))
  1147. X!         (comma (or calc-vector-commas " "))
  1148. X          (just (cond ((eq calc-matrix-just 'right) 'vright)
  1149. X              ((eq calc-matrix-just 'center) 'vcent)
  1150. X!             (t 'vleft))))
  1151. X!     (if (and (math-matrixp a) (not (math-matrixp (nth 1 a)))
  1152. X!          (memq calc-language '(nil big)))
  1153. X          (if (= (length a) 2)
  1154. X          (list 'horiz
  1155. X                (concat left-bracket left-bracket " ")
  1156. X                (math-compose-vector (cdr (nth 1 a))
  1157. X!                        (concat comma " "))
  1158. X                (concat " " right-bracket right-bracket))
  1159. X            (let* ((rows (1- (length a)))
  1160. X               (cols (1- (length (nth 1 a))))
  1161. X--- 23020,23042 ----
  1162. X                    (substring calc-vector-brackets 0 1) ""))
  1163. X          (right-bracket (if calc-vector-brackets
  1164. X                     (substring calc-vector-brackets 1 2) ""))
  1165. X!         (comma-spc (or calc-vector-commas " "))
  1166. X!         (comma (or calc-vector-commas ""))
  1167. X          (just (cond ((eq calc-matrix-just 'right) 'vright)
  1168. X              ((eq calc-matrix-just 'center) 'vcent)
  1169. X!             (t 'vleft)))
  1170. X!         (break calc-break-vectors))
  1171. X!     (if (and (memq calc-language '(nil big))
  1172. X!          (not calc-break-vectors)
  1173. X!          (math-matrixp a) (not (math-matrixp (nth 1 a)))
  1174. X!          (or calc-full-vectors
  1175. X!              (and (< (length a) 7) (< (length (nth 1 a)) 7))
  1176. X!              (progn (setq break t) nil)))
  1177. X          (if (= (length a) 2)
  1178. X          (list 'horiz
  1179. X                (concat left-bracket left-bracket " ")
  1180. X                (math-compose-vector (cdr (nth 1 a))
  1181. X!                        (concat comma-spc " "))
  1182. X                (concat " " right-bracket right-bracket))
  1183. X            (let* ((rows (1- (length a)))
  1184. X               (cols (1- (length (nth 1 a))))
  1185. X***************
  1186. X*** 15089,15099 ****
  1187. X        (if (and calc-display-strings
  1188. X             (math-vector-is-string a))
  1189. X            (prin1-to-string (concat (cdr a)))
  1190. X!         (list 'horiz
  1191. X!           left-bracket
  1192. X!           (math-compose-vector (cdr a)
  1193. X!                        (concat (or calc-vector-commas "") " "))
  1194. X!           right-bracket)))))
  1195. X       ((eq (car a) 'incomplete)
  1196. X        (if (cdr (cdr a))
  1197. X        (cond ((eq (nth 1 a) 'vec)
  1198. X--- 23067,23107 ----
  1199. X        (if (and calc-display-strings
  1200. X             (math-vector-is-string a))
  1201. X            (prin1-to-string (concat (cdr a)))
  1202. X!         (if (and break (cdr a)
  1203. X!              (not (eq calc-language 'flat)))
  1204. X!         (let* ((full (or calc-full-vectors (< (length a) 7)))
  1205. X!                (rows (if full (1- (length a)) 5))
  1206. X!                (base (/ (1- rows) 2))
  1207. X!                (just 'vleft)
  1208. X!                (calc-break-vectors nil))
  1209. X!           (list 'horiz
  1210. X!             (append '(vleft)
  1211. X!                 (list base
  1212. X!                       (concat left-bracket " "))
  1213. X!                 (make-list (1- rows) "  "))
  1214. X!             (cons 'vleft (cons base
  1215. X!                        (math-compose-rows
  1216. X!                         (cdr a)
  1217. X!                         (if full rows 3))))))
  1218. X!           (if (or calc-full-vectors (< (length a) 7))
  1219. X!           (if (and (eq calc-language 'tex)
  1220. X!                (math-matrixp a))
  1221. X!               (append '(horiz "\\matrix{ ")
  1222. X!                   (math-compose-tex-matrix (cdr a))
  1223. X!                   '(" }"))
  1224. X!             (list 'horiz
  1225. X!               left-bracket
  1226. X!               (math-compose-vector (cdr a) (concat comma " "))
  1227. X!               right-bracket))
  1228. X!         (list 'horiz
  1229. X!               left-bracket
  1230. X!               (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
  1231. X!                        (concat comma " "))
  1232. X!               comma (if (eq calc-language 'tex) " \\dots" " ...")
  1233. X!               comma " "
  1234. X!               (list 'break math-compose-level)
  1235. X!               (math-compose-expr (nth (1- (length a)) a) 0)
  1236. X!               right-bracket)))))))
  1237. X       ((eq (car a) 'incomplete)
  1238. X        (if (cdr (cdr a))
  1239. X        (cond ((eq (nth 1 a) 'vec)
  1240. X***************
  1241. X*** 15146,15152 ****
  1242. X         (eq calc-language 'big))
  1243. X        (let ((a1 (math-compose-expr (nth 1 a) 1000))
  1244. X          (a2 (math-compose-expr (nth 2 a) 0)))
  1245. X!     (if (eq (car-safe a1) 'subscr)
  1246. X          (list 'subscr
  1247. X            (nth 1 a1)
  1248. X            (list 'horiz
  1249. X--- 23154,23162 ----
  1250. X         (eq calc-language 'big))
  1251. X        (let ((a1 (math-compose-expr (nth 1 a) 1000))
  1252. X          (a2 (math-compose-expr (nth 2 a) 0)))
  1253. X!     (if (or (eq (car-safe a1) 'subscr)
  1254. X!         (and (eq (car-safe a1) 'tag)
  1255. X!              (eq (car-safe (nth 2 a1)) 'subscr)))
  1256. X          (list 'subscr
  1257. X            (nth 1 a1)
  1258. X            (list 'horiz
  1259. X***************
  1260. X*** 15196,15205 ****
  1261. X                (>= prec 0))
  1262. X           (list 'horiz "{" (math-compose-expr a -1) "}"))
  1263. X          (t
  1264. X!          (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))
  1265. X!                (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
  1266. X             (and (equal (car op) "^")
  1267. X!             (= (math-comp-first-char lhs) ?-)
  1268. X              (setq lhs (list 'horiz "(" lhs ")")))
  1269. X             (and (eq calc-language 'tex)
  1270. X              (or (equal (car op) "^") (equal (car op) "_"))
  1271. X--- 23206,23218 ----
  1272. X                (>= prec 0))
  1273. X           (list 'horiz "{" (math-compose-expr a -1) "}"))
  1274. X          (t
  1275. X!          (let* ((math-comp-tagged (and math-comp-tagged
  1276. X!                            (not (math-primp a))
  1277. X!                            math-comp-tagged))
  1278. X!             (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
  1279. X!             (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
  1280. X             (and (equal (car op) "^")
  1281. X!             (eq (math-comp-first-char lhs) ?-)
  1282. X              (setq lhs (list 'horiz "(" lhs ")")))
  1283. X             (and (eq calc-language 'tex)
  1284. X              (or (equal (car op) "^") (equal (car op) "_"))
  1285. X***************
  1286. X*** 15339,15345 ****
  1287. X--- 23352,23368 ----
  1288. X                 (math-compose-vector (cdr a) ", ")
  1289. X                 right))))))))
  1290. X  )
  1291. X+ 
  1292. X+ ;;;; [calc-ext.el]
  1293. X+ 
  1294. X  (setq math-compose-level 0)
  1295. X+ (setq math-comp-selected nil)
  1296. X+ (setq math-comp-tagged nil)
  1297. X+ (setq math-comp-sel-hpos nil)
  1298. X+ (setq math-comp-sel-vpos nil)
  1299. X+ (setq math-comp-sel-cpos nil)
  1300. X+ 
  1301. X+ ;;;; [calc-comp.el]
  1302. X  
  1303. X  (defun math-prod-first-term (x)
  1304. X    (if (eq (car-safe x) '*)
  1305. X***************
  1306. X*** 15386,15396 ****
  1307. X                     (lambda (r) (list 'horiz
  1308. X                           (math-compose-expr (nth col r)
  1309. X                                      0)
  1310. X!                          (concat comma " "))))
  1311. X                    a)))
  1312. X        (math-compose-matrix-step a (1+ col))))
  1313. X  )
  1314. X  
  1315. X  (defun math-vector-is-string (a)
  1316. X    (and (cdr a)
  1317. X         (progn
  1318. X--- 23409,23443 ----
  1319. X                     (lambda (r) (list 'horiz
  1320. X                           (math-compose-expr (nth col r)
  1321. X                                      0)
  1322. X!                          (concat comma-spc " "))))
  1323. X                    a)))
  1324. X        (math-compose-matrix-step a (1+ col))))
  1325. X  )
  1326. X  
  1327. X+ (defun math-compose-rows (a count)
  1328. X+   (if (cdr a)
  1329. X+       (if (<= count 0)
  1330. X+       (if (< count 0)
  1331. X+           (math-compose-rows (cdr a) -1)
  1332. X+         (cons (concat (if (eq calc-language 'tex) "\\dots" "...") comma)
  1333. X+           (math-compose-rows (cdr a) -1)))
  1334. X+     (cons (list 'horiz
  1335. X+             (math-compose-expr (car a) 0)
  1336. X+             comma)
  1337. X+           (math-compose-rows (cdr a) (1- count))))
  1338. X+     (list (list 'horiz
  1339. X+         (math-compose-expr (car a) 0)
  1340. X+         (concat " " right-bracket))))
  1341. X+ )
  1342. X+ 
  1343. X+ (defun math-compose-tex-matrix (a)
  1344. X+   (if (cdr a)
  1345. X+       (cons (math-compose-vector (cdr (car a)) " & ")
  1346. X+         (cons " \\\\ "
  1347. X+           (math-compose-tex-matrix (cdr a))))
  1348. X+     (list (math-compose-vector (cdr (car a)) " & ")))
  1349. X+ )
  1350. X+ 
  1351. X  (defun math-vector-is-string (a)
  1352. X    (and (cdr a)
  1353. X         (progn
  1354. X***************
  1355. X*** 15435,15440 ****
  1356. X--- 23482,23489 ----
  1357. X       (and (= (length c) 3)
  1358. X            (= (nth 1 c) 0)
  1359. X            (math-comp-is-flat (nth 2 c))))
  1360. X+     ((eq (car c) 'tag)
  1361. X+      (math-comp-is-flat (nth 2 c)))
  1362. X      (t nil))
  1363. X  )
  1364. X  
  1365. X***************
  1366. X*** 15445,15451 ****
  1367. X    (let ((comp-buf "")
  1368. X      (comp-word "")
  1369. X      (comp-pos 0)
  1370. X!     (comp-wlen 0))
  1371. X      (math-comp-to-string-flat-term c)
  1372. X      (math-comp-to-string-flat-term '(break -1))
  1373. X      comp-buf)
  1374. X--- 23494,23502 ----
  1375. X    (let ((comp-buf "")
  1376. X      (comp-word "")
  1377. X      (comp-pos 0)
  1378. X!     (comp-wlen 0)
  1379. X!     (comp-lnum 0)
  1380. X!     (comp-highlight (and math-comp-selected calc-show-selections)))
  1381. X      (math-comp-to-string-flat-term c)
  1382. X      (math-comp-to-string-flat-term '(break -1))
  1383. X      comp-buf)
  1384. X***************
  1385. X*** 15453,15459 ****
  1386. X  
  1387. X  (defun math-comp-to-string-flat-term (c)
  1388. X    (cond ((not (consp c))
  1389. X!      (setq comp-word (concat comp-word c)
  1390. X             comp-wlen (+ comp-wlen (length c))))
  1391. X      ((eq (car c) 'horiz)
  1392. X       (while (setq c (cdr c))
  1393. X--- 23504,23512 ----
  1394. X  
  1395. X  (defun math-comp-to-string-flat-term (c)
  1396. X    (cond ((not (consp c))
  1397. X!      (setq comp-word (concat comp-word (if comp-highlight
  1398. X!                            (math-comp-highlight-string c)
  1399. X!                          c))
  1400. X             comp-wlen (+ comp-wlen (length c))))
  1401. X      ((eq (car c) 'horiz)
  1402. X       (while (setq c (cdr c))
  1403. X***************
  1404. X*** 15466,15479 ****
  1405. X             comp-pos (+ comp-pos comp-wlen))
  1406. X         (if calc-line-numbering
  1407. X             (setq comp-buf (concat comp-buf "\n     " comp-word)
  1408. X!              comp-pos (+ comp-wlen 5))
  1409. X           (setq comp-buf (concat comp-buf "\n " comp-word)
  1410. X!            comp-pos (1+ comp-wlen))))
  1411. X       (setq comp-word ""
  1412. X             comp-wlen 0))
  1413. X      (t (math-comp-to-string-flat-term (nth 2 c))))
  1414. X  )
  1415. X  
  1416. X  
  1417. X  ;;; Simplify a composition to a canonical form consisting of
  1418. X  ;;;   (vleft n "string" "string" "string" ...)
  1419. X--- 23519,23556 ----
  1420. X             comp-pos (+ comp-pos comp-wlen))
  1421. X         (if calc-line-numbering
  1422. X             (setq comp-buf (concat comp-buf "\n     " comp-word)
  1423. X!              comp-pos (+ comp-wlen 5)
  1424. X!              comp-lnum (1+ comp-lnum))
  1425. X           (setq comp-buf (concat comp-buf "\n " comp-word)
  1426. X!            comp-pos (1+ comp-wlen)
  1427. X!            comp-lnum (1+ comp-lnum))))
  1428. X       (setq comp-word ""
  1429. X             comp-wlen 0))
  1430. X+     ((eq (car c) 'tag)
  1431. X+      (cond ((eq (nth 1 c) math-comp-selected)
  1432. X+         (let ((comp-highlight (not calc-show-selections)))
  1433. X+           (math-comp-to-string-flat-term (nth 2 c))))
  1434. X+            ((eq (nth 1 c) t)
  1435. X+         (let ((comp-highlight nil))
  1436. X+           (math-comp-to-string-flat-term (nth 2 c))))
  1437. X+            ((and math-comp-sel-hpos
  1438. X+              (<= (+ comp-pos comp-wlen) math-comp-sel-cpos))
  1439. X+         (math-comp-to-string-flat-term (nth 2 c))
  1440. X+         (if (> (+ comp-pos comp-wlen) math-comp-sel-cpos)
  1441. X+             (setq math-comp-sel-tag c
  1442. X+               math-comp-sel-cpos 10000)))
  1443. X+            (t (math-comp-to-string-flat-term (nth 2 c)))))
  1444. X      (t (math-comp-to-string-flat-term (nth 2 c))))
  1445. X  )
  1446. X  
  1447. X+ (defun math-comp-highlight-string (s)
  1448. X+   (setq s (copy-sequence s))
  1449. X+   (let ((i (length s)))
  1450. X+     (while (>= (setq i (1- i)) 0)
  1451. X+       (or (memq (aref s i) '(32 ?\n))
  1452. X+       (aset s i (if calc-show-selections ?\. ?\#)))))
  1453. X+   s
  1454. X+ )
  1455. X  
  1456. X  ;;; Simplify a composition to a canonical form consisting of
  1457. X  ;;;   (vleft n "string" "string" "string" ...)
  1458. X***************
  1459. X*** 15484,15490 ****
  1460. X      (comp-base 0)
  1461. X      (comp-height 1)
  1462. X      (comp-hpos 0)
  1463. X!     (comp-vpos 0))
  1464. X      (math-comp-simplify-term c)
  1465. X      (cons 'vleft (cons comp-base comp-buf)))
  1466. X  )
  1467. X--- 23561,23569 ----
  1468. X      (comp-base 0)
  1469. X      (comp-height 1)
  1470. X      (comp-hpos 0)
  1471. X!     (comp-vpos 0)
  1472. X!     (comp-highlight (and math-comp-selected calc-show-selections))
  1473. X!     (comp-tag nil))
  1474. X      (math-comp-simplify-term c)
  1475. X      (cons 'vleft (cons comp-base comp-buf)))
  1476. X  )
  1477. X***************
  1478. X*** 15492,15510 ****
  1479. X  (defun math-comp-add-string (s h v)
  1480. X    (and (> (length s) 0)
  1481. X         (let ((vv (+ v comp-base)))
  1482. X!      (if (< vv 0)
  1483. X!          (setq comp-buf (nconc (make-list (- vv) "") comp-buf)
  1484. X!            comp-base (- v)
  1485. X!            comp-height (- comp-height vv)
  1486. X!            vv 0)
  1487. X!        (if (>= vv comp-height)
  1488. X!            (setq comp-buf (nconc comp-buf
  1489. X!                      (make-list (1+ (- vv comp-height)) ""))
  1490. X!              comp-height (1+ vv))))
  1491. X!      (let ((str (nthcdr vv comp-buf)))
  1492. X!        (setcar str (concat (car str)
  1493. X!                    (make-string (- h (length (car str))) 32)
  1494. X!                    s)))))
  1495. X  )
  1496. X  
  1497. X  (defun math-comp-simplify-term (c)
  1498. X--- 23571,23602 ----
  1499. X  (defun math-comp-add-string (s h v)
  1500. X    (and (> (length s) 0)
  1501. X         (let ((vv (+ v comp-base)))
  1502. X!      (if math-comp-sel-hpos
  1503. X!          (math-comp-add-string-sel h vv (length s) 1)
  1504. X!        (if (< vv 0)
  1505. X!            (setq comp-buf (nconc (make-list (- vv) "") comp-buf)
  1506. X!              comp-base (- v)
  1507. X!              comp-height (- comp-height vv)
  1508. X!              vv 0)
  1509. X!          (if (>= vv comp-height)
  1510. X!          (setq comp-buf (nconc comp-buf
  1511. X!                        (make-list (1+ (- vv comp-height)) ""))
  1512. X!                comp-height (1+ vv))))
  1513. X!        (let ((str (nthcdr vv comp-buf)))
  1514. X!          (setcar str (concat (car str)
  1515. X!                  (make-string (- h (length (car str))) 32)
  1516. X!                  (if comp-highlight
  1517. X!                      (math-comp-highlight-string s)
  1518. X!                    s)))))))
  1519. X! )
  1520. X! 
  1521. X! (defun math-comp-add-string-sel (x y w h)
  1522. X!   (if (and (<= y math-comp-sel-vpos)
  1523. X!        (> (+ y h) math-comp-sel-vpos)
  1524. X!        (<= x math-comp-sel-hpos)
  1525. X!        (> (+ x w) math-comp-sel-hpos))
  1526. X!       (setq math-comp-sel-tag comp-tag
  1527. X!         math-comp-sel-vpos 10000))
  1528. X  )
  1529. X  
  1530. X  (defun math-comp-simplify-term (c)
  1531. X***************
  1532. X*** 15540,15556 ****
  1533. X              widths (cdr widths))))
  1534. X         (setq comp-hpos (+ comp-hpos maxwid))))
  1535. X      ((eq (car c) 'supscr)
  1536. X-      (math-comp-simplify-term (nth 1 c))
  1537. X       (let* ((asc (math-comp-ascent (nth 1 c)))
  1538. X          (desc (math-comp-descent (nth 2 c)))
  1539. X          (comp-vpos (- comp-vpos (+ asc desc))))
  1540. X!        (math-comp-simplify-term (nth 2 c))))
  1541. X      ((eq (car c) 'subscr)
  1542. X       (math-comp-simplify-term (nth 1 c))
  1543. X       (let* ((asc (math-comp-ascent (nth 2 c)))
  1544. X          (desc (math-comp-descent (nth 1 c)))
  1545. X          (comp-vpos (+ comp-vpos (+ asc desc))))
  1546. X!        (math-comp-simplify-term (nth 2 c)))))
  1547. X  )
  1548. X  
  1549. X  
  1550. X--- 23632,23666 ----
  1551. X              widths (cdr widths))))
  1552. X         (setq comp-hpos (+ comp-hpos maxwid))))
  1553. X      ((eq (car c) 'supscr)
  1554. X       (let* ((asc (math-comp-ascent (nth 1 c)))
  1555. X          (desc (math-comp-descent (nth 2 c)))
  1556. X+         (oldh (prog1
  1557. X+             comp-hpos
  1558. X+             (math-comp-simplify-term (nth 1 c))))
  1559. X          (comp-vpos (- comp-vpos (+ asc desc))))
  1560. X!        (math-comp-simplify-term (nth 2 c))
  1561. X!        (if math-comp-sel-hpos
  1562. X!            (math-comp-add-string-sel oldh
  1563. X!                      (- comp-vpos
  1564. X!                         -1
  1565. X!                         (math-comp-ascent (nth 2 c)))
  1566. X!                      (- comp-hpos oldh)
  1567. X!                      (math-comp-height c)))))
  1568. X      ((eq (car c) 'subscr)
  1569. X       (math-comp-simplify-term (nth 1 c))
  1570. X       (let* ((asc (math-comp-ascent (nth 2 c)))
  1571. X          (desc (math-comp-descent (nth 1 c)))
  1572. X          (comp-vpos (+ comp-vpos (+ asc desc))))
  1573. X!        (math-comp-simplify-term (nth 2 c))))
  1574. X!     ((eq (car c) 'tag)
  1575. X!      (cond ((eq (nth 1 c) math-comp-selected)
  1576. X!         (let ((comp-highlight (not calc-show-selections)))
  1577. X!           (math-comp-simplify-term (nth 2 c))))
  1578. X!            ((eq (nth 1 c) t)
  1579. X!         (let ((comp-highlight nil))
  1580. X!           (math-comp-simplify-term (nth 2 c))))
  1581. X!            (t (let ((comp-tag c))
  1582. X!             (math-comp-simplify-term (nth 2 c)))))))
  1583. X  )
  1584. X  
  1585. X  
  1586. X***************
  1587. X*** 15564,15570 ****
  1588. X       (let (ch)
  1589. X         (while (and (setq c (cdr c))
  1590. X                 (not (setq ch (math-comp-first-char (car c))))))
  1591. X!        ch)))
  1592. X  )
  1593. X  
  1594. X  (defun math-comp-last-char (c)
  1595. X--- 23674,23682 ----
  1596. X       (let (ch)
  1597. X         (while (and (setq c (cdr c))
  1598. X                 (not (setq ch (math-comp-first-char (car c))))))
  1599. X!        ch))
  1600. X!     ((eq (car c) 'tag)
  1601. X!      (math-comp-first-char (nth 2 c))))
  1602. X  )
  1603. X  
  1604. X  (defun math-comp-last-char (c)
  1605. X***************
  1606. X*** 15576,15582 ****
  1607. X         (while (and c
  1608. X                 (not (setq ch (math-comp-last-char (car c)))))
  1609. X           (setq c (cdr c)))
  1610. X!        ch)))
  1611. X  )
  1612. X  
  1613. X  (defun math-comp-width (c)
  1614. X--- 23688,23696 ----
  1615. X         (while (and c
  1616. X                 (not (setq ch (math-comp-last-char (car c)))))
  1617. X           (setq c (cdr c)))
  1618. X!        ch))
  1619. X!     ((eq (car c) 'tag)
  1620. X!      (math-comp-last-char (nth 2 c))))
  1621. X  )
  1622. X  
  1623. X  (defun math-comp-width (c)
  1624. X***************
  1625. X*** 15592,15597 ****
  1626. X--- 23706,23713 ----
  1627. X         (while (setq c (cdr c))
  1628. X           (setq accum (max accum (math-comp-width (car c)))))
  1629. X         accum))
  1630. X+     ((eq (car c) 'tag)
  1631. X+      (math-comp-width (nth 2 c)))
  1632. X      (t 0))
  1633. X  )
  1634. X  
  1635. X***************
  1636. X*** 15614,15619 ****
  1637. X--- 23730,23737 ----
  1638. X       (+ (math-comp-ascent (nth 1 c)) (math-comp-height (nth 2 c))))
  1639. X      ((eq (car c) 'subscr)
  1640. X       (math-comp-ascent (nth 1 c)))
  1641. X+     ((eq (car c) 'tag)
  1642. X+      (math-comp-ascent (nth 2 c)))
  1643. X      (t 1))
  1644. X  )
  1645. X  
  1646. X***************
  1647. X*** 15634,15639 ****
  1648. X--- 23752,23759 ----
  1649. X       (math-comp-descent (nth 1 c)))
  1650. X      ((eq (car c) 'subscr)
  1651. X       (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
  1652. X+     ((eq (car c) 'tag)
  1653. X+      (math-comp-descent (nth 2 c)))
  1654. X      (t 0))
  1655. X  )
  1656. X  
  1657. X***************
  1658. X*** 15690,15709 ****
  1659. X  
  1660. X  ;;;; Splitting calc-ext.el into smaller parts.  [Suggested by Juha Sarlin.]
  1661. X  
  1662. X! (defun calc-split (directory no-save)
  1663. X    "Split the file \"calc-ext.el\" into smaller parts for faster loading.
  1664. X  This should be done during installation of Calc only."
  1665. X    (interactive "DDirectory for resulting files: \nP")
  1666. X-   (or (string-match "calc-ext.el" (buffer-file-name))
  1667. X-       (error "This command is for Calc installers only.  (Refer to the documentation.)"))
  1668. X    (or (equal directory "")
  1669. X        (setq directory (file-name-as-directory (expand-file-name directory))))
  1670. X-   (and (or (get-buffer "calc-incom.el")
  1671. X-        (file-exists-p (concat directory "calc-incom.el")))
  1672. X-        (error "calc-split has already been used!"))
  1673. X    (let (copyright-point
  1674. X      autoload-point
  1675. X      (start (point-marker))
  1676. X      filename
  1677. X      (dest-buffer nil)
  1678. X      (done nil)
  1679. X--- 23810,23827 ----
  1680. X  
  1681. X  ;;;; Splitting calc-ext.el into smaller parts.  [Suggested by Juha Sarlin.]
  1682. X  
  1683. X! (defun calc-split (directory no-save &optional compile)
  1684. X    "Split the file \"calc-ext.el\" into smaller parts for faster loading.
  1685. X  This should be done during installation of Calc only."
  1686. X    (interactive "DDirectory for resulting files: \nP")
  1687. SHAR_EOF
  1688. echo "End of part 11, continue with part 12"
  1689. echo "12" > s2_seq_.tmp
  1690. exit 0
  1691.  
  1692.