home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume24 / gnucalc / part07 < prev    next >
Encoding:
Text File  |  1991-10-29  |  55.2 KB  |  1,739 lines
  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i055:  gnucalc - GNU Emacs Calculator, v2.00, Part07/56
  4. Message-ID: <1991Oct29.225818.19922@sparky.imd.sterling.com>
  5. X-Md4-Signature: 1eb577a4cebff995a6246c32fe6931f2
  6. Date: Tue, 29 Oct 1991 22:58:18 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 55
  11. Archive-name: gnucalc/part07
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # this is Part.07 (part 7 of a multipart archive)
  18. # do not concatenate these parts, unpack them in order with /bin/sh
  19. # file calc-alg-3.el continued
  20. #
  21. if test ! -r _shar_seq_.tmp; then
  22.     echo 'Please unpack part 1 first!'
  23.     exit 1
  24. fi
  25. (read Scheck
  26.  if test "$Scheck" != 7; then
  27.     echo Please unpack part "$Scheck" next!
  28.     exit 1
  29.  else
  30.     exit 0
  31.  fi
  32. ) < _shar_seq_.tmp || exit 1
  33. if test ! -f _shar_wnt_.tmp; then
  34.     echo 'x - still skipping calc-alg-3.el'
  35. else
  36. echo 'x - continuing file calc-alg-3.el'
  37. sed 's/^X//' << 'SHAR_EOF' >> 'calc-alg-3.el' &&
  38. X                 (math-float tlo) (math-float hi) 'inf))
  39. X          hi tlo)))
  40. X      (or (math-equal lo hi)
  41. X      (setq sum (math-add sum
  42. X                  (math-ninteg-romberg
  43. X                   'math-ninteg-midpoint expr
  44. X                   (math-float lo) (math-float hi) nil))))
  45. X      sum))
  46. )
  47. X
  48. X
  49. ;;; Open Romberg method; "qromo" in section 4.4.
  50. (defun math-ninteg-romberg (func expr lo hi mode)    
  51. X  (let ((curh '(float 1 0))
  52. X    (h nil)
  53. X    (s nil)
  54. X    (j 0)
  55. X    (ss nil)
  56. X    (prec calc-internal-prec)
  57. X    (integ-temp nil))
  58. X    (math-with-extra-prec 2
  59. X      ;; Limit on "j" loop must be 14 or less to keep "it" from overflowing.
  60. X      (or (while (and (null ss) (<= (setq j (1+ j)) 8))
  61. X        (setq s (nconc s (list (funcall func expr lo hi mode)))
  62. X          h (nconc h (list curh)))
  63. X        (if (>= j 3)
  64. X        (let ((res (math-poly-interp h s '(float 0 0) nil)))
  65. X          (if (math-lessp (math-abs (nth 1 res))
  66. X                  (calcFunc-scf (math-abs (car res))
  67. X                        (- prec)))
  68. X              (setq math-ninteg-convergence j
  69. X                ss (car res)))))
  70. X        (if (>= j 5)
  71. X        (setq s (cdr s)
  72. X              h (cdr h)))
  73. X        (setq curh (math-div-float curh '(float 9 0))))
  74. X      ss
  75. X      (math-reject-arg nil (format "*Integral failed to converge")))))
  76. )
  77. X
  78. X
  79. (defun math-ninteg-evaluate (expr x mode)
  80. X  (if (eq mode 'inf)
  81. X      (setq x (math-div '(float 1 0) x)))
  82. X  (let* ((var-DUMMY x)
  83. X     (res (math-evaluate-expr expr)))
  84. X    (or (Math-numberp res)
  85. X    (math-reject-arg res "*Integrand does not evaluate to a number"))
  86. X    (if (eq mode 'inf)
  87. X    (setq res (math-mul res (math-sqr x))))
  88. X    res)
  89. )
  90. X
  91. X
  92. (defun math-ninteg-midpoint (expr lo hi mode)    ; uses "integ-temp"
  93. X  (if (eq mode 'inf)
  94. X      (let ((math-infinite-mode t) temp)
  95. X    (setq temp (math-div 1 lo)
  96. X          lo (math-div 1 hi)
  97. X          hi temp)))
  98. X  (if integ-temp
  99. X      (let* ((it3 (* 3 (car integ-temp)))
  100. X         (math-working-step-2 (* 2 (car integ-temp)))
  101. X         (math-working-step 0)
  102. X         (range (math-sub hi lo))
  103. X         (del (math-div range (math-float it3)))
  104. X         (del2 (math-add del del))
  105. X         (del3 (math-add del del2))
  106. X         (x (math-add lo (math-mul '(float 5 -1) del)))
  107. X         (sum '(float 0 0))
  108. X         (j 0) temp)
  109. X    (while (<= (setq j (1+ j)) (car integ-temp))
  110. X      (setq math-working-step (1+ math-working-step)
  111. X        temp (math-ninteg-evaluate expr x mode)
  112. X        math-working-step (1+ math-working-step)
  113. X        sum (math-add sum (math-add temp (math-ninteg-evaluate
  114. X                          expr (math-add x del2)
  115. X                          mode)))
  116. X        x (math-add x del3)))
  117. X    (setq integ-temp (list it3
  118. X                   (math-add (math-div (nth 1 integ-temp)
  119. X                           '(float 3 0))
  120. X                     (math-mul sum del)))))
  121. X    (setq integ-temp (list 1 (math-mul
  122. X                  (math-sub hi lo)
  123. X                  (math-ninteg-evaluate
  124. X                   expr
  125. X                   (math-mul (math-add lo hi) '(float 5 -1))
  126. X                   mode)))))
  127. X  (nth 1 integ-temp)
  128. )
  129. X
  130. X
  131. X
  132. X
  133. X
  134. ;;; The following algorithms come from Numerical Recipes, chapter 14.
  135. X
  136. (setq math-dummy-vars [(var DUMMY var-DUMMY)])
  137. (setq math-dummy-counter 0)
  138. X
  139. (defun math-dummy-variable ()
  140. X  (if (= math-dummy-counter (length math-dummy-vars))
  141. X      (let ((symb (intern (format "math-dummy-%d" math-dummy-counter))))
  142. X    (setq math-dummy-vars (vconcat math-dummy-vars
  143. X                       (vector (list 'var symb symb))))))
  144. X  (set (nth 2 (aref math-dummy-vars math-dummy-counter)) nil)
  145. X  (prog1
  146. X      (aref math-dummy-vars math-dummy-counter)
  147. X    (setq math-dummy-counter (1+ math-dummy-counter)))
  148. )
  149. X
  150. X
  151. X
  152. (defun calcFunc-fit (expr vars &optional coefs data)
  153. X  (let ((math-in-fit 10))
  154. X    (math-with-extra-prec 2
  155. X      (math-general-fit expr vars coefs data nil)))
  156. )
  157. X
  158. (defun calcFunc-efit (expr vars &optional coefs data)
  159. X  (let ((math-in-fit 10))
  160. X    (math-with-extra-prec 2
  161. X      (math-general-fit expr vars coefs data 'sdev)))
  162. )
  163. X
  164. (defun calcFunc-xfit (expr vars &optional coefs data)
  165. X  (let ((math-in-fit 10))
  166. X    (math-with-extra-prec 2
  167. X      (math-general-fit expr vars coefs data 'full)))
  168. )
  169. X
  170. (defun math-general-fit (expr vars coefs data mode)
  171. X  (let ((calc-simplify-mode nil)
  172. X    (math-dummy-counter math-dummy-counter)
  173. X    (math-in-fit 1)
  174. X    (extended (eq mode 'full))
  175. X    (first-coef math-dummy-counter)
  176. X    first-var
  177. X    (plain-expr expr)
  178. X    orig-expr
  179. X    have-sdevs need-chisq chisq
  180. X    (x-funcs nil)
  181. X    (y-filter nil)
  182. X    y-dummy
  183. X    (coef-filters nil)
  184. X    new-coefs
  185. X    (xy-values nil)
  186. X    (weights nil)
  187. X    (var-YVAL nil) (var-YVALX nil)
  188. X    covar beta
  189. X    n nn m mm v dummy p)
  190. X
  191. X    ;; Validate and parse arguments.
  192. X    (or data
  193. X    (if coefs
  194. X        (setq data coefs
  195. X          coefs nil)
  196. X      (if (math-vectorp expr)
  197. X          (if (memq (length expr) '(3 4))
  198. X          (setq data vars
  199. X            vars (nth 2 expr)
  200. X            coefs (nth 3 expr)
  201. X            expr (nth 1 expr))
  202. X        (math-dimension-error))
  203. X        (setq data vars
  204. X          vars nil
  205. X          coefs nil))))
  206. X    (or (math-matrixp data) (math-reject-arg data 'matrixp))
  207. X    (setq v (1- (length data))
  208. X      n (1- (length (nth 1 data))))
  209. X    (or (math-vectorp vars) (null vars)
  210. X    (setq vars (list 'vec vars)))
  211. X    (or (math-vectorp coefs) (null coefs)
  212. X    (setq coefs (list 'vec coefs)))
  213. X    (or coefs
  214. X    (setq coefs (cons 'vec (math-all-vars-but expr vars))))
  215. X    (or vars
  216. X    (if (<= (1- (length coefs)) v)
  217. X        (math-reject-arg coefs "*Not enough variables in model")
  218. X      (setq coefs (copy-sequence coefs))
  219. X      (let ((p (nthcdr (- (length coefs) v
  220. X                  (if (eq (car-safe expr) 'calcFunc-eq) 1 0))
  221. X               coefs)))
  222. X        (setq vars (cons 'vec (cdr p)))
  223. X        (setcdr p nil))))
  224. X    (or (= (1- (length vars)) v)
  225. X    (= (length vars) v)
  226. X    (math-reject-arg vars "*Number of variables does not match data"))
  227. X    (setq m (1- (length coefs)))
  228. X    (if (< m 1)
  229. X    (math-reject-arg coefs "*Need at least one parameter"))
  230. X
  231. X    ;; Rewrite expr in terms of fitparam and fitvar, make into an equation.
  232. X    (setq p coefs)
  233. X    (while (setq p (cdr p))
  234. X      (or (eq (car-safe (car p)) 'var)
  235. X      (math-reject-arg (car p) "*Expected a variable"))
  236. X      (setq dummy (math-dummy-variable)
  237. X        expr (math-expr-subst expr (car p)
  238. X                  (list 'calcFunc-fitparam
  239. X                    (- math-dummy-counter first-coef)))))
  240. X    (setq first-var math-dummy-counter
  241. X      p vars)
  242. X    (while (setq p (cdr p))
  243. X      (or (eq (car-safe (car p)) 'var)
  244. X      (math-reject-arg (car p) "*Expected a variable"))
  245. X      (setq dummy (math-dummy-variable)
  246. X        expr (math-expr-subst expr (car p)
  247. X                  (list 'calcFunc-fitvar
  248. X                    (- math-dummy-counter first-var)))))
  249. X    (if (< math-dummy-counter (+ first-var v))
  250. X    (setq dummy (math-dummy-variable))) ; dependent variable may be unnamed
  251. X    (setq y-dummy dummy
  252. X      orig-expr expr)
  253. X    (or (eq (car-safe expr) 'calcFunc-eq)
  254. X    (setq expr (list 'calcFunc-eq (list 'calcFunc-fitvar v) expr)))
  255. X
  256. X    (let ((calc-symbolic-mode nil))
  257. X
  258. X      ;; Apply rewrites to put expr into a linear-like form.
  259. X      (setq expr (math-evaluate-expr expr)
  260. X        expr (math-rewrite (list 'calcFunc-fitmodel expr)
  261. X                   '(var FitRules var-FitRules))
  262. X        math-in-fit 2
  263. X        expr (math-evaluate-expr expr))
  264. X      (or (and (eq (car-safe expr) 'calcFunc-fitsystem)
  265. X           (= (length expr) 4)
  266. X           (math-vectorp (nth 2 expr))
  267. X           (math-vectorp (nth 3 expr))
  268. X           (> (length (nth 2 expr)) 1)
  269. X           (= (length (nth 3 expr)) (1+ m)))
  270. X      (math-reject-arg plain-expr "*Model expression is too complex"))
  271. X      (setq y-filter (nth 1 expr)
  272. X        x-funcs (vconcat (cdr (nth 2 expr)))
  273. X        coef-filters (nth 3 expr)
  274. X        mm (length x-funcs))
  275. X      (if (equal y-filter y-dummy)
  276. X      (setq y-filter nil))
  277. X
  278. X      ;; Build the (square) system of linear equations to be solved.
  279. X      (setq beta (cons 'vec (make-list mm 0))
  280. X        covar (cons 'vec (mapcar 'copy-sequence (make-list mm beta))))
  281. X      (let* ((ptrs (vconcat (cdr data)))
  282. X         (isigsq 1)
  283. X         (xvals (make-vector mm 0))
  284. X         (i 0)
  285. X         j k xval yval sigmasqr wt covj covjk covk betaj lud)
  286. X    (while (<= (setq i (1+ i)) n)
  287. X
  288. X      ;; Assign various independent variables for this data point.
  289. X      (setq j 0
  290. X        sigmasqr nil)
  291. X      (while (< j v)
  292. X        (aset ptrs j (cdr (aref ptrs j)))
  293. X        (setq xval (car (aref ptrs j)))
  294. X        (if (= j (1- v))
  295. X        (if sigmasqr
  296. X            (progn
  297. X              (if (eq (car-safe xval) 'sdev)
  298. X              (setq sigmasqr (math-add (math-sqr (nth 2 xval))
  299. X                           sigmasqr)
  300. X                xval (nth 1 xval)))
  301. X              (if y-filter
  302. X              (setq xval (math-make-sdev xval
  303. X                             (math-sqrt sigmasqr))))))
  304. X          (if (eq (car-safe xval) 'sdev)
  305. X          (setq sigmasqr (math-add (math-sqr (nth 2 xval))
  306. X                       (or sigmasqr 0))
  307. X            xval (nth 1 xval))))
  308. X        (set (nth 2 (aref math-dummy-vars (+ first-var j))) xval)
  309. X        (setq j (1+ j)))
  310. X
  311. X      ;; Compute Y value for this data point.
  312. X      (if y-filter
  313. X          (setq yval (math-evaluate-expr y-filter))
  314. X        (setq yval (symbol-value (nth 2 y-dummy))))
  315. X      (if (eq (car-safe yval) 'sdev)
  316. X          (setq sigmasqr (math-sqr (nth 2 yval))
  317. X            yval (nth 1 yval)))
  318. X      (if (= i 1)
  319. X          (setq have-sdevs sigmasqr
  320. X            need-chisq (or extended
  321. X                   (and (eq mode 'sdev) (not have-sdevs)))))
  322. X      (if have-sdevs
  323. X          (if sigmasqr
  324. X          (progn
  325. X            (setq isigsq (math-div 1 sigmasqr))
  326. X            (if need-chisq
  327. X            (setq weights (cons isigsq weights))))
  328. X        (math-reject-arg yval "*Mixed error forms and plain numbers"))
  329. X        (if sigmasqr
  330. X        (math-reject-arg yval "*Mixed error forms and plain numbers")))
  331. X
  332. X      ;; Compute X values for this data point and update covar and beta.
  333. X      (if (eq (car-safe xval) 'sdev)
  334. X          (set (nth 2 y-dummy) (nth 1 xval)))
  335. X      (setq j 0
  336. X        covj covar
  337. X        betaj beta)
  338. X      (while (< j mm)
  339. X        (setq wt (math-evaluate-expr (aref x-funcs j)))
  340. X        (aset xvals j wt)
  341. X        (setq wt (math-mul wt isigsq)
  342. X          betaj (cdr betaj)
  343. X          covjk (car (setq covj (cdr covj)))
  344. X          k 0)
  345. X        (while (<= k j)
  346. X          (setq covjk (cdr covjk))
  347. X          (setcar covjk (math-add (car covjk)
  348. X                      (math-mul wt (aref xvals k))))
  349. X          (setq k (1+ k)))
  350. X        (setcar betaj (math-add (car betaj) (math-mul wt yval)))
  351. X        (setq j (1+ j)))
  352. X      (if need-chisq
  353. X          (setq xy-values (cons (append xvals (list yval)) xy-values))))
  354. X
  355. X    ;; Fill in symmetric half of covar matrix.
  356. X    (setq j 0
  357. X          covj covar)
  358. X    (while (< j (1- mm))
  359. X      (setq k j
  360. X        j (1+ j)
  361. X        covjk (nthcdr j (car (setq covj (cdr covj))))
  362. X        covk (nthcdr j covar))
  363. X      (while (< (setq k (1+ k)) mm)
  364. X        (setq covjk (cdr covjk)
  365. X          covk (cdr covk))
  366. X        (setcar covjk (nth j (car covk))))))
  367. X
  368. X      ;; Solve the linear system.
  369. X      (if mode
  370. X      (progn
  371. X        (setq covar (math-matrix-inv-raw covar))
  372. X        (if covar
  373. X        (setq beta (math-mul covar beta))
  374. X          (if (math-zerop (math-abs beta))
  375. X          (setq covar (calcFunc-diag 0 (1- (length beta))))
  376. X        (math-reject-arg orig-expr "*Singular matrix")))
  377. X        (or (math-vectorp covar)
  378. X        (setq covar (list 'vec (list 'vec covar)))))
  379. X    (setq beta (math-div beta covar)))
  380. X
  381. X      ;; Compute chi-square statistic if necessary.
  382. X      (if need-chisq
  383. X      (let (bp xp sum)
  384. X        (setq chisq 0)
  385. X        (while xy-values
  386. X          (setq bp beta
  387. X            xp (car xy-values)
  388. X            sum 0)
  389. X          (while (setq bp (cdr bp))
  390. X        (setq sum (math-add sum (math-mul (car bp) (car xp)))
  391. X              xp (cdr xp)))
  392. X          (setq sum (math-sqr (math-sub (car xp) sum)))
  393. X          (if weights (setq sum (math-mul sum (car weights))))
  394. X          (setq chisq (math-add chisq sum)
  395. X            weights (cdr weights)
  396. X            xy-values (cdr xy-values)))))
  397. X
  398. X      ;; Convert coefficients back into original terms.
  399. X      (setq new-coefs (copy-sequence beta))
  400. X      (let* ((bp new-coefs)
  401. X         (cp covar)
  402. X         (sigdat 1)
  403. X         (math-in-fit 3)
  404. X         (j 0))
  405. X    (and mode (not have-sdevs)
  406. X         (setq sigdat (if (<= n mm)
  407. X                  0
  408. X                (math-div chisq (- n mm)))))
  409. X    (if mode
  410. X        (while (setq bp (cdr bp))
  411. X          (setcar bp (math-make-sdev
  412. X              (car bp)
  413. X              (math-sqrt (math-mul (nth (setq j (1+ j))
  414. X                            (car (setq cp (cdr cp))))
  415. X                           sigdat))))))
  416. X    (setq new-coefs (math-evaluate-expr coef-filters))
  417. X    (if calc-fit-to-trail
  418. X        (let ((bp new-coefs)
  419. X          (cp coefs)
  420. X          (vec nil))
  421. X          (while (setq bp (cdr bp) cp (cdr cp))
  422. X        (setq vec (cons (list 'calcFunc-eq (car cp) (car bp)) vec)))
  423. X          (setq calc-fit-to-trail (cons 'vec (nreverse vec)))))))
  424. X
  425. X    ;; Substitute best-fit coefficients back into original formula.
  426. X    (setq expr (math-multi-subst
  427. X        orig-expr
  428. X        (let ((n v)
  429. X              (vec nil))
  430. X          (while (>= n 1)
  431. X            (setq vec (cons (list 'calcFunc-fitvar n) vec)
  432. X              n (1- n)))
  433. X          (setq n m)
  434. X          (while (>= n 1)
  435. X            (setq vec (cons (list 'calcFunc-fitparam n) vec)
  436. X              n (1- n)))
  437. X          vec)
  438. X        (append (cdr new-coefs) (cdr vars))))
  439. X
  440. X    ;; Package the result.
  441. X    (math-normalize
  442. X     (if extended
  443. X     (list 'vec expr beta covar
  444. X           (let ((p coef-filters)
  445. X             (n 0))
  446. X         (while (and (setq n (1+ n) p (cdr p))
  447. X                 (eq (car-safe (car p)) 'calcFunc-fitdummy)
  448. X                 (eq (nth 1 (car p)) n)))
  449. X         (if p
  450. X             coef-filters
  451. X           (list 'vec)))
  452. X           chisq
  453. X           (if (and have-sdevs (> n mm))
  454. X           (list 'calcFunc-utpc chisq (- n mm))
  455. X         '(var nan var-nan)))
  456. X       expr)))
  457. )
  458. X
  459. (setq math-in-fit 0)
  460. (setq calc-fit-to-trail nil)
  461. X
  462. (defun calcFunc-fitvar (x)
  463. X  (if (>= math-in-fit 2)
  464. X      (progn
  465. X    (setq x (aref math-dummy-vars (+ first-var x -1)))
  466. X    (or (calc-var-value (nth 2 x)) x))
  467. X    (math-reject-arg x))
  468. )
  469. X
  470. (defun calcFunc-fitparam (x)
  471. X  (if (>= math-in-fit 2)
  472. X      (progn
  473. X    (setq x (aref math-dummy-vars (+ first-coef x -1)))
  474. X    (or (calc-var-value (nth 2 x)) x))
  475. X    (math-reject-arg x))
  476. )
  477. X
  478. (defun calcFunc-fitdummy (x)
  479. X  (if (= math-in-fit 3)
  480. X      (nth x new-coefs)
  481. X    (math-reject-arg x))
  482. )
  483. X
  484. (defun calcFunc-hasfitvars (expr)
  485. X  (if (Math-primp expr)
  486. X      0
  487. X    (if (eq (car expr) 'calcFunc-fitvar)
  488. X    (nth 1 expr)
  489. X      (apply 'max (mapcar 'calcFunc-hasfitvars (cdr expr)))))
  490. )
  491. X
  492. (defun calcFunc-hasfitparams (expr)
  493. X  (if (Math-primp expr)
  494. X      0
  495. X    (if (eq (car expr) 'calcFunc-fitparam)
  496. X    (nth 1 expr)
  497. X      (apply 'max (mapcar 'calcFunc-hasfitparams (cdr expr)))))
  498. )
  499. X
  500. X
  501. (defun math-all-vars-but (expr but)
  502. X  (let* ((vars (math-all-vars-in expr))
  503. X     (p but))
  504. X    (while p
  505. X      (setq vars (delq (assoc (car-safe p) vars) vars)
  506. X        p (cdr p)))
  507. X    (sort (mapcar 'car vars)
  508. X      (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
  509. )
  510. X
  511. (defun math-all-vars-in (expr)
  512. X  (let ((vars nil)
  513. X    found)
  514. X    (math-all-vars-rec expr)
  515. X    vars)
  516. )
  517. X
  518. (defun math-all-vars-rec (expr)
  519. X  (if (Math-primp expr)
  520. X      (if (eq (car-safe expr) 'var)
  521. X      (or (math-const-var expr)
  522. X          (if (setq found (assoc expr vars))
  523. X          (setcdr found (1+ (cdr found)))
  524. X        (setq vars (cons (cons expr 1) vars)))))
  525. X    (while (setq expr (cdr expr))
  526. X      (math-all-vars-rec (car expr))))
  527. )
  528. X
  529. X
  530. X
  531. X
  532. SHAR_EOF
  533. echo 'File calc-alg-3.el is complete' &&
  534. chmod 0644 calc-alg-3.el ||
  535. echo 'restore of calc-alg-3.el failed'
  536. Wc_c="`wc -c < 'calc-alg-3.el'`"
  537. test 56657 -eq "$Wc_c" ||
  538.     echo 'calc-alg-3.el: original size 56657, current size' "$Wc_c"
  539. rm -f _shar_wnt_.tmp
  540. fi
  541. # ============= calc-alg.el ==============
  542. if test -f 'calc-alg.el' -a X"$1" != X"-c"; then
  543.     echo 'x - skipping calc-alg.el (File already exists)'
  544.     rm -f _shar_wnt_.tmp
  545. else
  546. > _shar_wnt_.tmp
  547. echo 'x - extracting calc-alg.el (Text)'
  548. sed 's/^X//' << 'SHAR_EOF' > 'calc-alg.el' &&
  549. ;; Calculator for GNU Emacs, part II [calc-alg.el]
  550. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  551. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  552. X
  553. ;; This file is part of GNU Emacs.
  554. X
  555. ;; GNU Emacs is distributed in the hope that it will be useful,
  556. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  557. ;; accepts responsibility to anyone for the consequences of using it
  558. ;; or for whether it serves any particular purpose or works at all,
  559. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  560. ;; License for full details.
  561. X
  562. ;; Everyone is granted permission to copy, modify and redistribute
  563. ;; GNU Emacs, but only under the conditions described in the
  564. ;; GNU Emacs General Public License.   A copy of this license is
  565. ;; supposed to have been given to you along with GNU Emacs so you
  566. ;; can know your rights and responsibilities.  It should be in a
  567. ;; file named COPYING.  Among other things, the copyright notice
  568. ;; and this notice must be preserved on all copies.
  569. X
  570. X
  571. X
  572. ;; This file is autoloaded from calc-ext.el.
  573. (require 'calc-ext)
  574. X
  575. (require 'calc-macs)
  576. X
  577. (defun calc-Need-calc-alg () nil)
  578. X
  579. X
  580. ;;; Algebra commands.
  581. X
  582. (defun calc-alg-evaluate (arg)
  583. X  (interactive "p")
  584. X  (calc-slow-wrapper
  585. X   (calc-with-default-simplification
  586. X    (let ((math-simplify-only nil))
  587. X      (calc-modify-simplify-mode arg)
  588. X      (calc-enter-result 1 "dsmp" (calc-top 1)))))
  589. )
  590. X
  591. (defun calc-modify-simplify-mode (arg)
  592. X  (if (= (math-abs arg) 2)
  593. X      (setq calc-simplify-mode 'alg)
  594. X    (if (>= (math-abs arg) 3)
  595. X    (setq calc-simplify-mode 'ext)))
  596. X  (if (< arg 0)
  597. X      (setq calc-simplify-mode (list calc-simplify-mode)))
  598. )
  599. X
  600. (defun calc-simplify ()
  601. X  (interactive)
  602. X  (calc-slow-wrapper
  603. X   (calc-with-default-simplification
  604. X    (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1)))))
  605. )
  606. X
  607. (defun calc-simplify-extended ()
  608. X  (interactive)
  609. X  (calc-slow-wrapper
  610. X   (calc-with-default-simplification
  611. X    (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1)))))
  612. )
  613. X
  614. (defun calc-expand-formula (arg)
  615. X  (interactive "p")
  616. X  (calc-slow-wrapper
  617. X   (calc-with-default-simplification
  618. X    (let ((math-simplify-only nil))
  619. X      (calc-modify-simplify-mode arg)
  620. X      (calc-enter-result 1 "expf" 
  621. X             (if (> arg 0)
  622. X                 (let ((math-expand-formulas t))
  623. X                   (calc-top-n 1))
  624. X               (let ((top (calc-top-n 1)))
  625. X                 (or (math-expand-formula top)
  626. X                 top)))))))
  627. )
  628. X
  629. (defun calc-factor (arg)
  630. X  (interactive "P")
  631. X  (calc-slow-wrapper
  632. X   (calc-unary-op "fctr" (if (calc-is-hyperbolic)
  633. X                 'calcFunc-factors 'calcFunc-factor)
  634. X          arg))
  635. )
  636. X
  637. (defun calc-expand (n)
  638. X  (interactive "P")
  639. X  (calc-slow-wrapper
  640. X   (calc-enter-result 1 "expa"
  641. X              (append (list 'calcFunc-expand
  642. X                    (calc-top-n 1))
  643. X                  (and n (list (prefix-numeric-value n))))))
  644. )
  645. X
  646. (defun calc-collect (&optional var)
  647. X  (interactive "sCollect terms involving: ")
  648. X  (calc-slow-wrapper
  649. X   (if (or (equal var "") (equal var "$") (null var))
  650. X       (calc-enter-result 2 "clct" (cons 'calcFunc-collect
  651. X                     (calc-top-list-n 2)))
  652. X     (let ((var (math-read-expr var)))
  653. X       (if (eq (car-safe var) 'error)
  654. X       (error "Bad format in expression: %s" (nth 1 var)))
  655. X       (calc-enter-result 1 "clct" (list 'calcFunc-collect
  656. X                     (calc-top-n 1)
  657. X                     var)))))
  658. )
  659. X
  660. (defun calc-apart (arg)
  661. X  (interactive "P")
  662. X  (calc-slow-wrapper
  663. X   (calc-unary-op "aprt" 'calcFunc-apart arg))
  664. )
  665. X
  666. (defun calc-normalize-rat (arg)
  667. X  (interactive "P")
  668. X  (calc-slow-wrapper
  669. X   (calc-unary-op "nrat" 'calcFunc-nrat arg))
  670. )
  671. X
  672. (defun calc-poly-gcd (arg)
  673. X  (interactive "P")
  674. X  (calc-slow-wrapper
  675. X   (calc-binary-op "pgcd" 'calcFunc-pgcd arg))
  676. )
  677. X
  678. (defun calc-poly-div (arg)
  679. X  (interactive "P")
  680. X  (calc-slow-wrapper
  681. X   (setq calc-poly-div-remainder nil)
  682. X   (calc-binary-op "pdiv" 'calcFunc-pdiv arg)
  683. X   (if (and calc-poly-div-remainder (null arg))
  684. X       (progn
  685. X     (calc-clear-command-flag 'clear-message)
  686. X     (calc-record calc-poly-div-remainder "prem")
  687. X     (if (not (Math-zerop calc-poly-div-remainder))
  688. X         (message "(Remainder was %s)"
  689. X              (math-format-flat-expr calc-poly-div-remainder 0))
  690. X       (message "(No remainder)")))))
  691. )
  692. X
  693. (defun calc-poly-rem (arg)
  694. X  (interactive "P")
  695. X  (calc-slow-wrapper
  696. X   (calc-binary-op "prem" 'calcFunc-prem arg))
  697. )
  698. X
  699. (defun calc-poly-div-rem (arg)
  700. X  (interactive "P")
  701. X  (calc-slow-wrapper
  702. X   (if (calc-is-hyperbolic)
  703. X       (calc-binary-op "pdvr" 'calcFunc-pdivide arg)
  704. X     (calc-binary-op "pdvr" 'calcFunc-pdivrem arg)))
  705. )
  706. X
  707. (defun calc-substitute (&optional oldname newname)
  708. X  (interactive "sSubstitute old: ")
  709. X  (calc-slow-wrapper
  710. X   (let (old new (num 1) expr)
  711. X     (if (or (equal oldname "") (equal oldname "$") (null oldname))
  712. X     (setq new (calc-top-n 1)
  713. X           old (calc-top-n 2)
  714. X           expr (calc-top-n 3)
  715. X           num 3)
  716. X       (or newname
  717. X       (setq unread-command-char ?\C-a
  718. X         newname (read-string (concat "Substitute old: "
  719. X                          oldname
  720. X                          ", new: ")
  721. X                      oldname)))
  722. X       (if (or (equal newname "") (equal newname "$") (null newname))
  723. X       (setq new (calc-top-n 1)
  724. X         expr (calc-top-n 2)
  725. X         num 2)
  726. X     (setq new (if (stringp newname) (math-read-expr newname) newname))
  727. X     (if (eq (car-safe new) 'error)
  728. X         (error "Bad format in expression: %s" (nth 1 new)))
  729. X     (setq expr (calc-top-n 1)))
  730. X       (setq old (if (stringp oldname) (math-read-expr oldname) oldname))
  731. X       (if (eq (car-safe old) 'error)
  732. X       (error "Bad format in expression: %s" (nth 1 old)))
  733. X       (or (math-expr-contains expr old)
  734. X       (error "No occurrences found.")))
  735. X     (calc-enter-result num "sbst" (math-expr-subst expr old new))))
  736. )
  737. X
  738. X
  739. (defun calc-has-rules (name)
  740. X  (setq name (calc-var-value name))
  741. X  (and (consp name)
  742. X       (memq (car name) '(vec calcFunc-assign calcFunc-condition))
  743. X       (cdr name))
  744. )
  745. X
  746. (defun math-recompile-eval-rules ()
  747. X  (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules)
  748. X                   (math-compile-rewrites
  749. X                    '(var EvalRules var-EvalRules)))
  750. X    math-eval-rules-cache-other (assq nil math-eval-rules-cache)
  751. X    math-eval-rules-cache-tag (calc-var-value 'var-EvalRules))
  752. )
  753. X
  754. X
  755. ;;; Try to expand a formula according to its definition.
  756. (defun math-expand-formula (expr)
  757. X  (and (consp expr)
  758. X       (symbolp (car expr))
  759. X       (or (get (car expr) 'calc-user-defn)
  760. X       (get (car expr) 'math-expandable))
  761. X       (let ((res (let ((math-expand-formulas t))
  762. X            (apply (car expr) (cdr expr)))))
  763. X     (and (not (eq (car-safe res) (car expr)))
  764. X          res)))
  765. )
  766. X
  767. X
  768. X
  769. X
  770. ;;; True if A comes before B in a canonical ordering of expressions.  [P X X]
  771. (defun math-beforep (a b)   ; [Public]
  772. X  (cond ((and (Math-realp a) (Math-realp b))
  773. X     (let ((comp (math-compare a b)))
  774. X       (or (eq comp -1)
  775. X           (and (eq comp 0)
  776. X            (not (equal a b))
  777. X            (> (length (memq (car-safe a)
  778. X                     '(bigneg nil bigpos frac float)))
  779. X               (length (memq (car-safe b)
  780. X                     '(bigneg nil bigpos frac float))))))))
  781. X    ((equal b '(neg (var inf var-inf))) nil)
  782. X    ((equal a '(neg (var inf var-inf))) t)
  783. X    ((equal a '(var inf var-inf)) nil)
  784. X    ((equal b '(var inf var-inf)) t)
  785. X    ((Math-realp a)
  786. X     (if (and (eq (car-safe b) 'intv) (math-intv-constp b))
  787. X         (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b)))
  788. X         t
  789. X           nil)
  790. X       t))
  791. X    ((Math-realp b)
  792. X     (if (and (eq (car-safe a) 'intv) (math-intv-constp a))
  793. X         (if (math-beforep (nth 2 a) b)
  794. X         t
  795. X           nil)
  796. X       nil))
  797. X    ((and (eq (car a) 'intv) (eq (car b) 'intv)
  798. X          (math-intv-constp a) (math-intv-constp b))
  799. X     (let ((comp (math-compare (nth 2 a) (nth 2 b))))
  800. X       (cond ((eq comp -1) t)
  801. X         ((eq comp 1) nil)
  802. X         ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t)
  803. X         ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil)
  804. X         ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t)
  805. X         ((eq comp 1) nil)
  806. X         ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t)
  807. X         (t nil))))
  808. X    ((not (eq (not (Math-objectp a)) (not (Math-objectp b))))
  809. X     (Math-objectp a))
  810. X    ((eq (car a) 'var)
  811. X     (if (eq (car b) 'var)
  812. X         (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
  813. X       (not (Math-numberp b))))
  814. X    ((eq (car b) 'var) (Math-numberp a))
  815. X    ((eq (car a) (car b))
  816. X     (while (and (setq a (cdr a) b (cdr b)) a
  817. X             (equal (car a) (car b))))
  818. X     (and b
  819. X          (or (null a)
  820. X          (math-beforep (car a) (car b)))))
  821. X    (t (string-lessp (symbol-name (car a)) (symbol-name (car b)))))
  822. )
  823. X
  824. X
  825. (defun math-simplify-extended (a)
  826. X  (let ((math-living-dangerously t))
  827. X    (math-simplify a))
  828. )
  829. (fset 'calcFunc-esimplify (symbol-function 'math-simplify-extended))
  830. X
  831. (defun math-simplify (top-expr)
  832. X  (let ((math-simplifying t)
  833. X    (top-only (consp calc-simplify-mode))
  834. X    (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules)
  835. X                 '((var AlgSimpRules var-AlgSimpRules)))
  836. X                (and math-living-dangerously
  837. X                 (calc-has-rules 'var-ExtSimpRules)
  838. X                 '((var ExtSimpRules var-ExtSimpRules)))
  839. X                (and math-simplifying-units
  840. X                 (calc-has-rules 'var-UnitSimpRules)
  841. X                 '((var UnitSimpRules var-UnitSimpRules)))
  842. X                (and math-integrating
  843. X                 (calc-has-rules 'var-IntegSimpRules)
  844. X                 '((var IntegSimpRules var-IntegSimpRules)))))
  845. X    res)
  846. X    (if top-only
  847. X    (let ((r simp-rules))
  848. X      (setq res (math-simplify-step (math-normalize top-expr))
  849. X        calc-simplify-mode '(nil)
  850. X        top-expr (math-normalize res))
  851. X      (while r
  852. X        (setq top-expr (math-rewrite top-expr (car r)
  853. X                     '(neg (var inf var-inf)))
  854. X          r (cdr r))))
  855. X      (calc-with-default-simplification
  856. X       (while (let ((r simp-rules))
  857. X        (setq res (math-normalize top-expr))
  858. X        (while r
  859. X          (setq res (math-rewrite res (car r))
  860. X            r (cdr r)))
  861. X        (not (equal top-expr (setq res (math-simplify-step res)))))
  862. X     (setq top-expr res)))))
  863. X  top-expr
  864. )
  865. (fset 'calcFunc-simplify (symbol-function 'math-simplify))
  866. X
  867. ;;; The following has a "bug" in that if any recursive simplifications
  868. ;;; occur only the first handler will be tried; this doesn't really
  869. ;;; matter, since math-simplify-step is iterated to a fixed point anyway.
  870. (defun math-simplify-step (a)
  871. X  (if (Math-primp a)
  872. X      a
  873. X    (let ((aa (if (or top-only
  874. X              (memq (car a) '(calcFunc-quote calcFunc-condition
  875. X                             calcFunc-evalto)))
  876. X          a
  877. X        (cons (car a) (mapcar 'math-simplify-step (cdr a))))))
  878. X      (and (symbolp (car aa))
  879. X       (let ((handler (get (car aa) 'math-simplify)))
  880. X         (and handler
  881. X          (while (and handler
  882. X                  (equal (setq aa (or (funcall (car handler) aa)
  883. X                          aa))
  884. X                     a))
  885. X            (setq handler (cdr handler))))))
  886. X      aa))
  887. )
  888. X
  889. X
  890. (defun math-need-std-simps ()
  891. X  ;; Placeholder, to synchronize autoloading.
  892. )
  893. X
  894. (math-defsimplify (+ -)
  895. X  (math-simplify-plus))
  896. X
  897. (defun math-simplify-plus ()
  898. X  (cond ((and (memq (car-safe (nth 1 expr)) '(+ -))
  899. X          (Math-numberp (nth 2 (nth 1 expr)))
  900. X          (not (Math-numberp (nth 2 expr))))
  901. X     (let ((x (nth 2 expr))
  902. X           (op (car expr)))
  903. X       (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr)))
  904. X       (setcar expr (car (nth 1 expr)))
  905. X       (setcar (cdr (cdr (nth 1 expr))) x)
  906. X       (setcar (nth 1 expr) op)))
  907. X    ((and (eq (car expr) '+)
  908. X          (Math-numberp (nth 1 expr))
  909. X          (not (Math-numberp (nth 2 expr))))
  910. X     (let ((x (nth 2 expr)))
  911. X       (setcar (cdr (cdr expr)) (nth 1 expr))
  912. X       (setcar (cdr expr) x))))
  913. X  (let ((aa expr)
  914. X    aaa temp)
  915. X    (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
  916. X      (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr)
  917. X                       (eq (car aaa) '-) (eq (car expr) '-) t))
  918. X      (progn
  919. X        (setcar (cdr (cdr expr)) temp)
  920. X        (setcar expr '+)
  921. X        (setcar (cdr (cdr aaa)) 0)))
  922. X      (setq aa (nth 1 aa)))
  923. X    (if (setq temp (math-combine-sum aaa (nth 2 expr)
  924. X                     nil (eq (car expr) '-) t))
  925. X    (progn
  926. X      (setcar (cdr (cdr expr)) temp)
  927. X      (setcar expr '+)
  928. X      (setcar (cdr aa) 0)))
  929. X    expr)
  930. )
  931. X
  932. (math-defsimplify *
  933. X  (math-simplify-times))
  934. X
  935. (defun math-simplify-times ()
  936. X  (if (eq (car-safe (nth 2 expr)) '*)
  937. X      (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr))
  938. X       (or (math-known-scalarp (nth 1 expr) t)
  939. X           (math-known-scalarp (nth 1 (nth 2 expr)) t))
  940. X       (let ((x (nth 1 expr)))
  941. X         (setcar (cdr expr) (nth 1 (nth 2 expr)))
  942. X         (setcar (cdr (nth 2 expr)) x)))
  943. X    (and (math-beforep (nth 2 expr) (nth 1 expr))
  944. X     (or (math-known-scalarp (nth 1 expr) t)
  945. X         (math-known-scalarp (nth 2 expr) t))
  946. X     (let ((x (nth 2 expr)))
  947. X       (setcar (cdr (cdr expr)) (nth 1 expr))
  948. X       (setcar (cdr expr) x))))
  949. X  (let ((aa expr)
  950. X    aaa temp
  951. X    (safe t) (scalar (math-known-scalarp (nth 1 expr))))
  952. X    (if (and (Math-ratp (nth 1 expr))
  953. X         (setq temp (math-common-constant-factor (nth 2 expr))))
  954. X    (progn
  955. X      (setcar (cdr (cdr expr))
  956. X          (math-cancel-common-factor (nth 2 expr) temp))
  957. X      (setcar (cdr expr) (math-mul (nth 1 expr) temp))))
  958. X    (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*)
  959. X        safe)
  960. X      (if (setq temp (math-combine-prod (nth 1 expr) (nth 1 aaa) nil nil t))
  961. X      (progn
  962. X        (setcar (cdr expr) temp)
  963. X        (setcar (cdr aaa) 1)))
  964. X      (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t))
  965. X        aa (nth 2 aa)))
  966. X    (if (and (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t))
  967. X         safe)
  968. X    (progn
  969. X      (setcar (cdr expr) temp)
  970. X      (setcar (cdr (cdr aa)) 1)))
  971. X    (if (and (eq (car-safe (nth 1 expr)) 'frac)
  972. X         (memq (nth 1 (nth 1 expr)) '(1 -1)))
  973. X    (math-div (math-mul (nth 2 expr) (nth 1 (nth 1 expr)))
  974. X          (nth 2 (nth 1 expr)))
  975. X      expr))
  976. )
  977. X
  978. (math-defsimplify /
  979. X  (math-simplify-divide))
  980. X
  981. (defun math-simplify-divide ()
  982. X  (let ((np (cdr expr))
  983. X    (nover nil)
  984. X    (nn (and (or (eq (car expr) '/) (not (Math-realp (nth 2 expr))))
  985. X         (math-common-constant-factor (nth 2 expr))))
  986. X    n op)
  987. X    (if nn
  988. X    (progn
  989. X      (setq n (and (or (eq (car expr) '/) (not (Math-realp (nth 1 expr))))
  990. X               (math-common-constant-factor (nth 1 expr))))
  991. X      (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n))
  992. X          (progn
  993. X        (setcar (cdr expr) (math-mul (nth 2 nn) (nth 1 expr)))
  994. X        (setcar (cdr (cdr expr))
  995. X            (math-cancel-common-factor (nth 2 expr) nn))
  996. X        (if (and (math-negp nn)
  997. X             (setq op (assq (car expr) calc-tweak-eqn-table)))
  998. X            (setcar expr (nth 1 op))))
  999. X        (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
  1000. X        (progn
  1001. X          (setcar (cdr expr)
  1002. X              (math-cancel-common-factor (nth 1 expr) n))
  1003. X          (setcar (cdr (cdr expr))
  1004. X              (math-cancel-common-factor (nth 2 expr) n))
  1005. X          (if (and (math-negp n)
  1006. X               (setq op (assq (car expr) calc-tweak-eqn-table)))
  1007. X              (setcar expr (nth 1 op))))))))
  1008. X    (if (and (eq (car-safe (car np)) '/)
  1009. X         (math-known-scalarp (nth 2 expr) t))
  1010. X    (progn
  1011. X      (setq np (cdr (nth 1 expr)))
  1012. X      (while (eq (car-safe (setq n (car np))) '*)
  1013. X        (and (math-known-scalarp (nth 2 n) t)
  1014. X         (math-simplify-divisor (cdr n) (cdr (cdr expr)) nil t))
  1015. X        (setq np (cdr (cdr n))))
  1016. X      (math-simplify-divisor np (cdr (cdr expr)) nil t)
  1017. X      (setq nover t
  1018. X        np (cdr (cdr (nth 1 expr))))))
  1019. X    (while (eq (car-safe (setq n (car np))) '*)
  1020. X      (and (math-known-scalarp (nth 2 n) t)
  1021. X       (math-simplify-divisor (cdr n) (cdr (cdr expr)) nover t))
  1022. X      (setq np (cdr (cdr n))))
  1023. X    (math-simplify-divisor np (cdr (cdr expr)) nover t)
  1024. X    expr)
  1025. )
  1026. X
  1027. (defun math-simplify-divisor (np dp nover dover)
  1028. X  (cond ((eq (car-safe (car dp)) '/)
  1029. X     (math-simplify-divisor np (cdr (car dp)) nover dover)
  1030. X     (and (math-known-scalarp (nth 1 (car dp)) t)
  1031. X          (math-simplify-divisor np (cdr (cdr (car dp)))
  1032. X                     nover (not dover))))
  1033. X    ((or (or (eq (car expr) '/)
  1034. X         (let ((signs (math-possible-signs (car np))))
  1035. X           (or (memq signs '(1 4))
  1036. X               (and (memq (car expr) '(calcFunc-eq calcFunc-neq))
  1037. X                (eq signs 5))
  1038. X               math-living-dangerously)))
  1039. X         (math-numberp (car np)))
  1040. X     (let ((n (car np))
  1041. X           d dd temp op
  1042. X           (safe t) (scalar (math-known-scalarp n)))
  1043. X       (while (and (eq (car-safe (setq d (car dp))) '*)
  1044. X               safe)
  1045. X         (math-simplify-one-divisor np (cdr d))
  1046. X         (setq safe (or scalar (math-known-scalarp (nth 1 d) t))
  1047. X           dp (cdr (cdr d))))
  1048. X       (if safe
  1049. X           (math-simplify-one-divisor np dp)))))
  1050. )
  1051. X
  1052. (defun math-simplify-one-divisor (np dp)
  1053. X  (if (setq temp (math-combine-prod (car np) (car dp) nover dover t))
  1054. X      (progn
  1055. X    (and (not (memq (car expr) '(/ calcFunc-eq calcFunc-neq)))
  1056. X         (math-known-negp (car dp))
  1057. X         (setq op (assq (car expr) calc-tweak-eqn-table))
  1058. X         (setcar expr (nth 1 op)))
  1059. X    (setcar np (if nover (math-div 1 temp) temp))
  1060. X    (setcar dp 1))
  1061. X    (and dover (not nover) (eq (car expr) '/)
  1062. X     (eq (car-safe (car dp)) 'calcFunc-sqrt)
  1063. X     (Math-integerp (nth 1 (car dp)))
  1064. X     (progn
  1065. X       (setcar np (math-mul (car np)
  1066. X                (list 'calcFunc-sqrt (nth 1 (car dp)))))
  1067. X       (setcar dp (nth 1 (car dp))))))
  1068. )
  1069. X
  1070. (defun math-common-constant-factor (expr)
  1071. X  (if (Math-realp expr)
  1072. X      (if (Math-ratp expr)
  1073. X      (and (not (memq expr '(0 1 -1)))
  1074. X           (math-abs expr))
  1075. X    (if (math-ratp (setq expr (math-to-simple-fraction expr)))
  1076. X        (math-common-constant-factor expr)))
  1077. X    (if (memq (car expr) '(+ - cplx sdev))
  1078. X    (let ((f1 (math-common-constant-factor (nth 1 expr)))
  1079. X          (f2 (math-common-constant-factor (nth 2 expr))))
  1080. X      (and f1 f2
  1081. X           (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
  1082. X           f1))
  1083. X      (if (memq (car expr) '(* polar))
  1084. X      (math-common-constant-factor (nth 1 expr))
  1085. X    (if (eq (car expr) '/)
  1086. X        (or (math-common-constant-factor (nth 1 expr))
  1087. X        (and (Math-integerp (nth 2 expr))
  1088. X             (list 'frac 1 (math-abs (nth 2 expr)))))))))
  1089. )
  1090. X
  1091. (defun math-cancel-common-factor (expr val)
  1092. X  (if (memq (car-safe expr) '(+ - cplx sdev))
  1093. X      (progn
  1094. X    (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
  1095. X    (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
  1096. X    expr)
  1097. X    (if (eq (car-safe expr) '*)
  1098. X    (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr))
  1099. X      (math-div expr val)))
  1100. )
  1101. X
  1102. (defun math-frac-gcd (a b)
  1103. X  (if (Math-zerop a)
  1104. X      b
  1105. X    (if (Math-zerop b)
  1106. X    a
  1107. X      (if (and (Math-integerp a)
  1108. X           (Math-integerp b))
  1109. X      (math-gcd a b)
  1110. X    (and (Math-integerp a) (setq a (list 'frac a 1)))
  1111. X    (and (Math-integerp b) (setq b (list 'frac b 1)))
  1112. X    (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
  1113. X            (math-gcd (nth 2 a) (nth 2 b))))))
  1114. )
  1115. X
  1116. (math-defsimplify %
  1117. X  (math-simplify-mod))
  1118. X
  1119. (defun math-simplify-mod ()
  1120. X  (and (Math-realp (nth 2 expr))
  1121. X       (Math-posp (nth 2 expr))
  1122. X       (let ((lin (math-is-linear (nth 1 expr)))
  1123. X         t1 t2 t3)
  1124. X     (or (and lin
  1125. X          (or (math-negp (car lin))
  1126. X              (not (Math-lessp (car lin) (nth 2 expr))))
  1127. X          (list '%
  1128. X            (list '+
  1129. X                  (math-mul (nth 1 lin) (nth 2 lin))
  1130. X                  (math-mod (car lin) (nth 2 expr)))
  1131. X            (nth 2 expr)))
  1132. X         (and lin
  1133. X          (not (math-equal-int (nth 1 lin) 1))
  1134. X          (math-num-integerp (nth 1 lin))
  1135. X          (math-num-integerp (nth 2 expr))
  1136. X          (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 expr)))
  1137. X          (not (math-equal-int t1 1))
  1138. X          (list '*
  1139. X            t1
  1140. X            (list '%
  1141. X                  (list '+
  1142. X                    (math-mul (math-div (nth 1 lin) t1)
  1143. X                          (nth 2 lin))
  1144. X                    (let ((calc-prefer-frac t))
  1145. X                      (math-div (car lin) t1)))
  1146. X                  (math-div (nth 2 expr) t1))))
  1147. X         (and (math-equal-int (nth 2 expr) 1)
  1148. X          (math-known-integerp (if lin
  1149. X                       (math-mul (nth 1 lin) (nth 2 lin))
  1150. X                     (nth 1 expr)))
  1151. X          (if lin (math-mod (car lin) 1) 0)))))
  1152. )
  1153. X
  1154. (math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt
  1155. X                   calcFunc-gt calcFunc-leq calcFunc-geq)
  1156. X  (if (= (length expr) 3)
  1157. X      (math-simplify-ineq)))
  1158. X
  1159. (defun math-simplify-ineq ()
  1160. X  (let ((np (cdr expr))
  1161. X    n)
  1162. X    (while (memq (car-safe (setq n (car np))) '(+ -))
  1163. X      (math-simplify-add-term (cdr (cdr n)) (cdr (cdr expr))
  1164. X                  (eq (car n) '-) nil)
  1165. X      (setq np (cdr n)))
  1166. X    (math-simplify-add-term np (cdr (cdr expr)) nil (eq np (cdr expr)))
  1167. X    (math-simplify-divide)
  1168. X    (let ((signs (math-possible-signs (cons '- (cdr expr)))))
  1169. X      (or (cond ((eq (car expr) 'calcFunc-eq)
  1170. X         (or (and (eq signs 2) 1)
  1171. X             (and (memq signs '(1 4 5)) 0)))
  1172. X        ((eq (car expr) 'calcFunc-neq)
  1173. X         (or (and (eq signs 2) 0)
  1174. X             (and (memq signs '(1 4 5)) 1)))
  1175. X        ((eq (car expr) 'calcFunc-lt)
  1176. X         (or (and (eq signs 1) 1)
  1177. X             (and (memq signs '(2 4 6)) 0)))
  1178. X        ((eq (car expr) 'calcFunc-gt)
  1179. X         (or (and (eq signs 4) 1)
  1180. X             (and (memq signs '(1 2 3)) 0)))
  1181. X        ((eq (car expr) 'calcFunc-leq)
  1182. X         (or (and (eq signs 4) 0)
  1183. X             (and (memq signs '(1 2 3)) 1)))
  1184. X        ((eq (car expr) 'calcFunc-geq)
  1185. X         (or (and (eq signs 1) 0)
  1186. X             (and (memq signs '(2 4 6)) 1))))
  1187. X      expr)))
  1188. )
  1189. X
  1190. (defun math-simplify-add-term (np dp minus lplain)
  1191. X  (or (math-vectorp (car np))
  1192. X      (let ((rplain t)
  1193. X        n d dd temp)
  1194. X    (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -))
  1195. X      (setq rplain nil)
  1196. X      (if (setq temp (math-combine-sum n (nth 2 d)
  1197. X                       minus (eq (car d) '+) t))
  1198. X          (if (or lplain (eq (math-looks-negp temp) minus))
  1199. X          (progn
  1200. X            (setcar np (setq n (if minus (math-neg temp) temp)))
  1201. X            (setcar (cdr (cdr d)) 0))
  1202. X        (progn
  1203. X          (setcar np 0)
  1204. X          (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+)
  1205. X                            (math-neg temp)
  1206. X                          temp))))))
  1207. X      (setq dp (cdr d)))
  1208. X    (if (setq temp (math-combine-sum n d minus t t))
  1209. X        (if (or lplain
  1210. X            (and (not rplain)
  1211. X             (eq (math-looks-negp temp) minus)))
  1212. X        (progn
  1213. X          (setcar np (setq n (if minus (math-neg temp) temp)))
  1214. X          (setcar dp 0))
  1215. X          (progn
  1216. X        (setcar np 0)
  1217. X        (setcar dp (setq n (math-neg temp))))))))
  1218. )
  1219. X
  1220. (math-defsimplify calcFunc-sin
  1221. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
  1222. X       (nth 1 (nth 1 expr)))
  1223. X      (and (math-looks-negp (nth 1 expr))
  1224. X       (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr)))))
  1225. X      (and (eq calc-angle-mode 'rad)
  1226. X       (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
  1227. X         (and n
  1228. X          (math-known-sin (car n) (nth 1 n) 120 0))))
  1229. X      (and (eq calc-angle-mode 'deg)
  1230. X       (let ((n (math-integer-plus (nth 1 expr))))
  1231. X         (and n
  1232. X          (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0))))
  1233. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
  1234. X       (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
  1235. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
  1236. X       (math-div (nth 1 (nth 1 expr))
  1237. X             (list 'calcFunc-sqrt
  1238. X               (math-add 1 (math-sqr (nth 1 (nth 1 expr)))))))
  1239. X      (let ((m (math-should-expand-trig (nth 1 expr))))
  1240. X    (and m (integerp (car m))
  1241. X         (let ((n (car m)) (a (nth 1 m)))
  1242. X           (list '+
  1243. X             (list '* (list 'calcFunc-sin (list '* (1- n) a))
  1244. X               (list 'calcFunc-cos a))
  1245. X             (list '* (list 'calcFunc-cos (list '* (1- n) a))
  1246. X               (list 'calcFunc-sin a)))))))
  1247. )
  1248. X
  1249. (math-defsimplify calcFunc-cos
  1250. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
  1251. X       (nth 1 (nth 1 expr)))
  1252. X      (and (math-looks-negp (nth 1 expr))
  1253. X       (list 'calcFunc-cos (math-neg (nth 1 expr))))
  1254. X      (and (eq calc-angle-mode 'rad)
  1255. X       (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
  1256. X         (and n
  1257. X          (math-known-sin (car n) (nth 1 n) 120 300))))
  1258. X      (and (eq calc-angle-mode 'deg)
  1259. X       (let ((n (math-integer-plus (nth 1 expr))))
  1260. X         (and n
  1261. X          (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300))))
  1262. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
  1263. X       (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
  1264. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
  1265. X       (math-div 1
  1266. X             (list 'calcFunc-sqrt
  1267. X               (math-add 1 (math-sqr (nth 1 (nth 1 expr)))))))
  1268. X      (let ((m (math-should-expand-trig (nth 1 expr))))
  1269. X    (and m (integerp (car m))
  1270. X         (let ((n (car m)) (a (nth 1 m)))
  1271. X           (list '-
  1272. X             (list '* (list 'calcFunc-cos (list '* (1- n) a))
  1273. X               (list 'calcFunc-cos a))
  1274. X             (list '* (list 'calcFunc-sin (list '* (1- n) a))
  1275. X               (list 'calcFunc-sin a)))))))
  1276. )
  1277. X
  1278. (defun math-should-expand-trig (x &optional hyperbolic)
  1279. X  (let ((m (math-is-multiple x)))
  1280. X    (and math-living-dangerously
  1281. X     m (or (and (integerp (car m)) (> (car m) 1))
  1282. X           (equal (car m) '(frac 1 2)))
  1283. X     (or math-integrating
  1284. X         (memq (car-safe (nth 1 m))
  1285. X           (if hyperbolic
  1286. X               '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)
  1287. X             '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan)))
  1288. X         (and (eq (car-safe (nth 1 m)) 'calcFunc-ln)
  1289. X          (eq hyperbolic 'exp)))
  1290. X     m))
  1291. )
  1292. X
  1293. (defun math-known-sin (plus n mul off)
  1294. X  (setq n (math-mul n mul))
  1295. X  (and (math-num-integerp n)
  1296. X       (setq n (math-mod (math-add (math-trunc n) off) 240))
  1297. X       (if (>= n 120)
  1298. X       (and (setq n (math-known-sin plus (- n 120) 1 0))
  1299. X        (math-neg n))
  1300. X     (if (> n 60)
  1301. X         (setq n (- 120 n)))
  1302. X     (if (math-zerop plus)
  1303. X         (and (or calc-symbolic-mode
  1304. X              (memq n '(0 20 60)))
  1305. X          (cdr (assq n
  1306. X                 '( (0 . 0)
  1307. X                (10 . (/ (calcFunc-sqrt
  1308. X                      (- 2 (calcFunc-sqrt 3))) 2))
  1309. X                (12 . (/ (- (calcFunc-sqrt 5) 1) 4))
  1310. X                (15 . (/ (calcFunc-sqrt
  1311. X                      (- 2 (calcFunc-sqrt 2))) 2))
  1312. X                (20 . (/ 1 2))
  1313. X                (24 . (* (^ (/ 1 2) (/ 3 2))
  1314. X                     (calcFunc-sqrt
  1315. X                      (- 5 (calcFunc-sqrt 5)))))
  1316. X                (30 . (/ (calcFunc-sqrt 2) 2))
  1317. X                (36 . (/ (+ (calcFunc-sqrt 5) 1) 4))
  1318. X                (40 . (/ (calcFunc-sqrt 3) 2))
  1319. X                (45 . (/ (calcFunc-sqrt
  1320. X                      (+ 2 (calcFunc-sqrt 2))) 2))
  1321. X                (48 . (* (^ (/ 1 2) (/ 3 2))
  1322. X                     (calcFunc-sqrt
  1323. X                      (+ 5 (calcFunc-sqrt 5)))))
  1324. X                (50 . (/ (calcFunc-sqrt
  1325. X                      (+ 2 (calcFunc-sqrt 3))) 2))
  1326. X                (60 . 1)))))
  1327. X       (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus)))
  1328. X         ((eq n 60) (math-normalize (list 'calcFunc-cos plus)))
  1329. X         (t nil)))))
  1330. )
  1331. X
  1332. (math-defsimplify calcFunc-tan
  1333. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
  1334. X       (nth 1 (nth 1 expr)))
  1335. X      (and (math-looks-negp (nth 1 expr))
  1336. X       (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr)))))
  1337. X      (and (eq calc-angle-mode 'rad)
  1338. X       (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi))))
  1339. X         (and n
  1340. X          (math-known-tan (car n) (nth 1 n) 120))))
  1341. X      (and (eq calc-angle-mode 'deg)
  1342. X       (let ((n (math-integer-plus (nth 1 expr))))
  1343. X         (and n
  1344. X          (math-known-tan (car n) (nth 1 n) '(frac 2 3)))))
  1345. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
  1346. X       (math-div (nth 1 (nth 1 expr))
  1347. X             (list 'calcFunc-sqrt
  1348. X               (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
  1349. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
  1350. X       (math-div (list 'calcFunc-sqrt
  1351. X               (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
  1352. X             (nth 1 (nth 1 expr))))
  1353. X      (let ((m (math-should-expand-trig (nth 1 expr))))
  1354. X    (and m
  1355. X         (if (equal (car m) '(frac 1 2))
  1356. X         (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m)))
  1357. X               (list 'calcFunc-sin (nth 1 m)))
  1358. X           (math-div (list 'calcFunc-sin (nth 1 expr))
  1359. X             (list 'calcFunc-cos (nth 1 expr)))))))
  1360. )
  1361. X
  1362. (defun math-known-tan (plus n mul)
  1363. X  (setq n (math-mul n mul))
  1364. X  (and (math-num-integerp n)
  1365. X       (setq n (math-mod (math-trunc n) 120))
  1366. X       (if (> n 60)
  1367. X       (and (setq n (math-known-tan plus (- 120 n) 1))
  1368. X        (math-neg n))
  1369. X     (if (math-zerop plus)
  1370. X         (and (or calc-symbolic-mode
  1371. X              (memq n '(0 30 60)))
  1372. X          (cdr (assq n '( (0 . 0)
  1373. X                  (10 . (- 2 (calcFunc-sqrt 3)))
  1374. X                  (12 . (calcFunc-sqrt
  1375. X                     (- 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
  1376. X                  (15 . (- (calcFunc-sqrt 2) 1))
  1377. X                  (20 . (/ (calcFunc-sqrt 3) 3))
  1378. X                  (24 . (calcFunc-sqrt
  1379. X                     (- 5 (* 2 (calcFunc-sqrt 5)))))
  1380. X                  (30 . 1)
  1381. X                  (36 . (calcFunc-sqrt
  1382. X                     (+ 1 (* (/ 2 5) (calcFunc-sqrt 5)))))
  1383. X                  (40 . (calcFunc-sqrt 3))
  1384. X                  (45 . (+ (calcFunc-sqrt 2) 1))
  1385. X                  (48 . (calcFunc-sqrt
  1386. X                     (+ 5 (* 2 (calcFunc-sqrt 5)))))
  1387. X                  (50 . (+ 2 (calcFunc-sqrt 3)))
  1388. X                  (60 . (var uinf var-uinf))))))
  1389. X       (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus)))
  1390. X         ((eq n 60) (math-normalize (list '/ -1
  1391. X                          (list 'calcFunc-tan plus))))
  1392. X         (t nil)))))
  1393. )
  1394. X
  1395. (math-defsimplify calcFunc-sinh
  1396. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
  1397. X       (nth 1 (nth 1 expr)))
  1398. X      (and (math-looks-negp (nth 1 expr))
  1399. X       (math-neg (list 'calcFunc-sinh (math-neg (nth 1 expr)))))
  1400. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
  1401. X       math-living-dangerously
  1402. X       (list 'calcFunc-sqrt (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)))
  1403. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
  1404. X       math-living-dangerously
  1405. X       (math-div (nth 1 (nth 1 expr))
  1406. X             (list 'calcFunc-sqrt
  1407. X               (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
  1408. X      (let ((m (math-should-expand-trig (nth 1 expr) t)))
  1409. X    (and m (integerp (car m))
  1410. X         (let ((n (car m)) (a (nth 1 m)))
  1411. X           (if (> n 1)
  1412. X           (list '+
  1413. X             (list '* (list 'calcFunc-sinh (list '* (1- n) a))
  1414. X                   (list 'calcFunc-cosh a))
  1415. X             (list '* (list 'calcFunc-cosh (list '* (1- n) a))
  1416. X                   (list 'calcFunc-sinh a))))))))
  1417. )
  1418. X
  1419. (math-defsimplify calcFunc-cosh
  1420. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
  1421. X       (nth 1 (nth 1 expr)))
  1422. X      (and (math-looks-negp (nth 1 expr))
  1423. X       (list 'calcFunc-cosh (math-neg (nth 1 expr))))
  1424. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
  1425. X       math-living-dangerously
  1426. X       (list 'calcFunc-sqrt (math-add (math-sqr (nth 1 (nth 1 expr))) 1)))
  1427. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
  1428. X       math-living-dangerously
  1429. X       (math-div 1
  1430. X             (list 'calcFunc-sqrt
  1431. X               (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
  1432. X      (let ((m (math-should-expand-trig (nth 1 expr) t)))
  1433. X    (and m (integerp (car m))
  1434. X         (let ((n (car m)) (a (nth 1 m)))
  1435. X           (if (> n 1)
  1436. X           (list '+
  1437. X             (list '* (list 'calcFunc-cosh (list '* (1- n) a))
  1438. X                   (list 'calcFunc-cosh a))
  1439. X             (list '* (list 'calcFunc-sinh (list '* (1- n) a))
  1440. X                   (list 'calcFunc-sinh a))))))))
  1441. )
  1442. X
  1443. (math-defsimplify calcFunc-tanh
  1444. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
  1445. X       (nth 1 (nth 1 expr)))
  1446. X      (and (math-looks-negp (nth 1 expr))
  1447. X       (math-neg (list 'calcFunc-tanh (math-neg (nth 1 expr)))))
  1448. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
  1449. X       math-living-dangerously
  1450. X       (math-div (nth 1 (nth 1 expr))
  1451. X             (list 'calcFunc-sqrt
  1452. X               (math-add (math-sqr (nth 1 (nth 1 expr))) 1))))
  1453. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
  1454. X       math-living-dangerously
  1455. X       (math-div (list 'calcFunc-sqrt
  1456. X               (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))
  1457. X             (nth 1 (nth 1 expr))))
  1458. X      (let ((m (math-should-expand-trig (nth 1 expr) t)))
  1459. X    (and m
  1460. X         (if (equal (car m) '(frac 1 2))
  1461. X         (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1)
  1462. X               (list 'calcFunc-sinh (nth 1 m)))
  1463. X           (math-div (list 'calcFunc-sinh (nth 1 expr))
  1464. X             (list 'calcFunc-cosh (nth 1 expr)))))))
  1465. )
  1466. X
  1467. (math-defsimplify calcFunc-arcsin
  1468. X  (or (and (math-looks-negp (nth 1 expr))
  1469. X       (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr)))))
  1470. X      (and (eq (nth 1 expr) 1)
  1471. X       (math-quarter-circle t))
  1472. X      (and (equal (nth 1 expr) '(frac 1 2))
  1473. X       (math-div (math-half-circle t) 6))
  1474. X      (and math-living-dangerously
  1475. X       (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
  1476. X       (nth 1 (nth 1 expr)))
  1477. X      (and math-living-dangerously
  1478. X       (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
  1479. X       (math-sub (math-quarter-circle t)
  1480. X             (nth 1 (nth 1 expr)))))
  1481. )
  1482. X
  1483. (math-defsimplify calcFunc-arccos
  1484. X  (or (and (eq (nth 1 expr) 0)
  1485. X       (math-quarter-circle t))
  1486. X      (and (eq (nth 1 expr) -1)
  1487. X       (math-half-circle t))
  1488. X      (and (equal (nth 1 expr) '(frac 1 2))
  1489. X       (math-div (math-half-circle t) 3))
  1490. X      (and (equal (nth 1 expr) '(frac -1 2))
  1491. X       (math-div (math-mul (math-half-circle t) 2) 3))
  1492. X      (and math-living-dangerously
  1493. X       (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
  1494. X       (nth 1 (nth 1 expr)))
  1495. X      (and math-living-dangerously
  1496. X       (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
  1497. X       (math-sub (math-quarter-circle t)
  1498. X             (nth 1 (nth 1 expr)))))
  1499. )
  1500. X
  1501. (math-defsimplify calcFunc-arctan
  1502. X  (or (and (math-looks-negp (nth 1 expr))
  1503. X       (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr)))))
  1504. X      (and (eq (nth 1 expr) 1)
  1505. X       (math-div (math-half-circle t) 4))
  1506. X      (and math-living-dangerously
  1507. X       (eq (car-safe (nth 1 expr)) 'calcFunc-tan)
  1508. X       (nth 1 (nth 1 expr))))
  1509. )
  1510. X
  1511. (math-defsimplify calcFunc-arcsinh
  1512. X  (or (and (math-looks-negp (nth 1 expr))
  1513. X       (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 expr)))))
  1514. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-sinh)
  1515. X       (or math-living-dangerously
  1516. X           (math-known-realp (nth 1 (nth 1 expr))))
  1517. X       (nth 1 (nth 1 expr))))
  1518. )
  1519. X
  1520. (math-defsimplify calcFunc-arccosh
  1521. X  (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
  1522. X       (or math-living-dangerously
  1523. X       (math-known-realp (nth 1 (nth 1 expr))))
  1524. X       (nth 1 (nth 1 expr)))
  1525. )
  1526. X
  1527. (math-defsimplify calcFunc-arctanh
  1528. X  (or (and (math-looks-negp (nth 1 expr))
  1529. X       (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 expr)))))
  1530. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-tanh)
  1531. X       (or math-living-dangerously
  1532. X           (math-known-realp (nth 1 (nth 1 expr))))
  1533. X       (nth 1 (nth 1 expr))))
  1534. )
  1535. X
  1536. (math-defsimplify calcFunc-sqrt
  1537. X  (math-simplify-sqrt)
  1538. )
  1539. X
  1540. (defun math-simplify-sqrt ()
  1541. X  (or (and (eq (car-safe (nth 1 expr)) 'frac)
  1542. X       (math-div (list 'calcFunc-sqrt (math-mul (nth 1 (nth 1 expr))
  1543. X                            (nth 2 (nth 1 expr))))
  1544. X             (nth 2 (nth 1 expr))))
  1545. X      (let ((fac (if (math-objectp (nth 1 expr))
  1546. X             (math-squared-factor (nth 1 expr))
  1547. X           (math-common-constant-factor (nth 1 expr)))))
  1548. X    (and fac (not (eq fac 1))
  1549. X         (math-mul (math-normalize (list 'calcFunc-sqrt fac))
  1550. X               (math-normalize
  1551. X            (list 'calcFunc-sqrt
  1552. X                  (math-cancel-common-factor (nth 1 expr) fac))))))
  1553. X      (and math-living-dangerously
  1554. X       (or (and (eq (car-safe (nth 1 expr)) '-)
  1555. X            (math-equal-int (nth 1 (nth 1 expr)) 1)
  1556. X            (eq (car-safe (nth 2 (nth 1 expr))) '^)
  1557. X            (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2)
  1558. X            (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr))))
  1559. X                 'calcFunc-sin)
  1560. X                 (list 'calcFunc-cos
  1561. X                   (nth 1 (nth 1 (nth 2 (nth 1 expr))))))
  1562. X            (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr))))
  1563. X                 'calcFunc-cos)
  1564. X                 (list 'calcFunc-sin
  1565. X                   (nth 1 (nth 1 (nth 2 (nth 1 expr))))))))
  1566. X           (and (eq (car-safe (nth 1 expr)) '-)
  1567. X            (math-equal-int (nth 2 (nth 1 expr)) 1)
  1568. X            (eq (car-safe (nth 1 (nth 1 expr))) '^)
  1569. X            (math-equal-int (nth 2 (nth 1 (nth 1 expr))) 2)
  1570. X            (and (eq (car-safe (nth 1 (nth 1 (nth 1 expr))))
  1571. X                 'calcFunc-cosh)
  1572. X             (list 'calcFunc-sinh
  1573. X                   (nth 1 (nth 1 (nth 1 (nth 1 expr)))))))
  1574. X           (and (eq (car-safe (nth 1 expr)) '+)
  1575. X            (let ((a (nth 1 (nth 1 expr)))
  1576. X              (b (nth 2 (nth 1 expr))))
  1577. X              (and (or (and (math-equal-int a 1)
  1578. X                    (setq a b b (nth 1 (nth 1 expr))))
  1579. X                   (math-equal-int b 1))
  1580. X               (eq (car-safe a) '^)
  1581. X               (math-equal-int (nth 2 a) 2)
  1582. X               (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh)
  1583. X                    (list 'calcFunc-cosh (nth 1 (nth 1 a))))
  1584. X                   (and (eq (car-safe (nth 1 a)) 'calcFunc-tan)
  1585. X                    (list '/ 1 (list 'calcFunc-cos
  1586. X                             (nth 1 (nth 1 a)))))))))
  1587. X           (and (eq (car-safe (nth 1 expr)) '^)
  1588. X            (list '^
  1589. X              (nth 1 (nth 1 expr))
  1590. X              (math-div (nth 2 (nth 1 expr)) 2)))
  1591. X           (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
  1592. X            (list '^ (nth 1 (nth 1 expr)) (math-div 1 4)))
  1593. X           (and (memq (car-safe (nth 1 expr)) '(* /))
  1594. X            (list (car (nth 1 expr))
  1595. X              (list 'calcFunc-sqrt (nth 1 (nth 1 expr)))
  1596. X              (list 'calcFunc-sqrt (nth 2 (nth 1 expr)))))
  1597. X           (and (memq (car-safe (nth 1 expr)) '(+ -))
  1598. X            (not (math-any-floats (nth 1 expr)))
  1599. X            (let ((f (calcFunc-factors (calcFunc-expand
  1600. X                        (nth 1 expr)))))
  1601. X              (and (math-vectorp f)
  1602. X               (or (> (length f) 2)
  1603. X                   (> (nth 2 (nth 1 f)) 1))
  1604. X               (let ((out 1) (rest 1) (sums 1) fac pow)
  1605. X                 (while (setq f (cdr f))
  1606. X                   (setq fac (nth 1 (car f))
  1607. X                     pow (nth 2 (car f)))
  1608. X                   (if (> pow 1)
  1609. X                   (setq out (math-mul out (math-pow
  1610. X                                fac (/ pow 2)))
  1611. X                     pow (% pow 2)))
  1612. X                   (if (> pow 0)
  1613. X                   (if (memq (car-safe fac) '(+ -))
  1614. X                       (setq sums (math-mul-thru sums fac))
  1615. X                     (setq rest (math-mul rest fac)))))
  1616. X                 (and (not (and (eq out 1) (memq rest '(1 -1))))
  1617. X                  (math-mul
  1618. X                   out
  1619. X                   (list 'calcFunc-sqrt
  1620. X                     (math-mul sums rest)))))))))))
  1621. )
  1622. X
  1623. ;;; Rather than factoring x into primes, just check for the first ten primes.
  1624. (defun math-squared-factor (x)
  1625. X  (if (Math-integerp x)
  1626. X      (let ((prsqr '(4 9 25 49 121 169 289 361 529 841))
  1627. X        (fac 1)
  1628. X        res)
  1629. X    (while prsqr
  1630. X      (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0)
  1631. X          (setq x (car res)
  1632. X            fac (math-mul fac (car prsqr)))
  1633. X        (setq prsqr (cdr prsqr))))
  1634. X    fac))
  1635. )
  1636. X
  1637. (math-defsimplify calcFunc-exp
  1638. X  (math-simplify-exp (nth 1 expr))
  1639. )
  1640. X
  1641. (defun math-simplify-exp (x)
  1642. X  (or (and (eq (car-safe x) 'calcFunc-ln)
  1643. X       (nth 1 x))
  1644. X      (and math-living-dangerously
  1645. X       (or (and (eq (car-safe x) 'calcFunc-arcsinh)
  1646. X            (math-add (nth 1 x)
  1647. X                  (list 'calcFunc-sqrt
  1648. X                    (math-add (math-sqr (nth 1 x)) 1))))
  1649. X           (and (eq (car-safe x) 'calcFunc-arccosh)
  1650. X            (math-add (nth 1 x)
  1651. X                  (list 'calcFunc-sqrt
  1652. X                    (math-sub (math-sqr (nth 1 x)) 1))))
  1653. X           (and (eq (car-safe x) 'calcFunc-arctanh)
  1654. X            (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x)))
  1655. X                  (list 'calcFunc-sqrt (math-sub 1 (nth 1 x)))))
  1656. X           (let ((m (math-should-expand-trig x 'exp)))
  1657. X         (and m (integerp (car m))
  1658. X              (list '^ (list 'calcFunc-exp (nth 1 m)) (car m))))))
  1659. X      (and calc-symbolic-mode
  1660. X       (math-known-imagp x)
  1661. X       (let* ((ip (calcFunc-im x))
  1662. X          (n (math-linear-in ip '(var pi var-pi)))
  1663. X          s c)
  1664. X         (and n
  1665. X          (setq s (math-known-sin (car n) (nth 1 n) 120 0))
  1666. X          (setq c (math-known-sin (car n) (nth 1 n) 120 300))
  1667. X          (list '+ c (list '* s '(var i var-i)))))))
  1668. )
  1669. X
  1670. (math-defsimplify calcFunc-ln
  1671. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
  1672. X       (or math-living-dangerously
  1673. X           (math-known-realp (nth 1 (nth 1 expr))))
  1674. X       (nth 1 (nth 1 expr)))
  1675. X      (and (eq (car-safe (nth 1 expr)) '^)
  1676. X       (equal (nth 1 (nth 1 expr)) '(var e var-e))
  1677. X       (or math-living-dangerously
  1678. X           (math-known-realp (nth 2 (nth 1 expr))))
  1679. X       (nth 2 (nth 1 expr)))
  1680. X      (and calc-symbolic-mode
  1681. X       (math-known-negp (nth 1 expr))
  1682. X       (math-add (list 'calcFunc-ln (math-neg (nth 1 expr)))
  1683. X             '(var pi var-pi)))
  1684. X      (and calc-symbolic-mode
  1685. X       (math-known-imagp (nth 1 expr))
  1686. X       (let* ((ip (calcFunc-im (nth 1 expr)))
  1687. X          (ips (math-possible-signs ip)))
  1688. X         (or (and (memq ips '(4 6))
  1689. X              (math-add (list 'calcFunc-ln ip)
  1690. X                '(/ (* (var pi var-pi) (var i var-i)) 2)))
  1691. X         (and (memq ips '(1 3))
  1692. X              (math-sub (list 'calcFunc-ln (math-neg ip))
  1693. X                '(/ (* (var pi var-pi) (var i var-i)) 2)))))))
  1694. )
  1695. X
  1696. (math-defsimplify ^
  1697. X  (math-simplify-pow))
  1698. X
  1699. (defun math-simplify-pow ()
  1700. X  (or (and math-living-dangerously
  1701. X       (or (and (eq (car-safe (nth 1 expr)) '^)
  1702. X            (list '^
  1703. X              (nth 1 (nth 1 expr))
  1704. X              (math-mul (nth 2 expr) (nth 2 (nth 1 expr)))))
  1705. X           (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
  1706. X            (list '^
  1707. X              (nth 1 (nth 1 expr))
  1708. X              (math-div (nth 2 expr) 2)))
  1709. X           (and (memq (car-safe (nth 1 expr)) '(* /))
  1710. X            (list (car (nth 1 expr))
  1711. X              (list '^ (nth 1 (nth 1 expr)) (nth 2 expr))
  1712. X              (list '^ (nth 2 (nth 1 expr)) (nth 2 expr))))))
  1713. X      (and (math-equal-int (nth 1 expr) 10)
  1714. X       (eq (car-safe (nth 2 expr)) 'calcFunc-log10)
  1715. X       (nth 1 (nth 2 expr)))
  1716. X      (and (equal (nth 1 expr) '(var e var-e))
  1717. X       (math-simplify-exp (nth 2 expr)))
  1718. X      (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
  1719. X       (not math-integrating)
  1720. X       (list 'calcFunc-exp (math-mul (nth 1 (nth 1 expr)) (nth 2 expr))))
  1721. X      (and (equal (nth 1 expr) '(var i var-i))
  1722. X       (math-imaginary-i)
  1723. X       (math-num-integerp (nth 2 expr))
  1724. X       (let ((x (math-mod (math-trunc (nth 2 expr)) 4)))
  1725. X         (cond ((eq x 0) 1)
  1726. SHAR_EOF
  1727. true || echo 'restore of calc-alg.el failed'
  1728. fi
  1729. echo 'End of  part 7'
  1730. echo 'File calc-alg.el is continued in part 8'
  1731. echo 8 > _shar_seq_.tmp
  1732. exit 0
  1733. exit 0 # Just in case...
  1734. -- 
  1735. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1736. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1737. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1738. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1739.