home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume24 / gnucalc / part11 < prev    next >
Encoding:
Text File  |  1991-10-29  |  55.3 KB  |  1,728 lines

  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i059:  gnucalc - GNU Emacs Calculator, v2.00, Part11/56
  4. Message-ID: <1991Oct29.230052.20207@sparky.imd.sterling.com>
  5. X-Md4-Signature: 8f16bacf000fd51d6517bfc244c8f8fa
  6. Date: Tue, 29 Oct 1991 23:00:52 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 59
  11. Archive-name: gnucalc/part11
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # this is Part.11 (part 11 of a multipart archive)
  18. # do not concatenate these parts, unpack them in order with /bin/sh
  19. # file calc-comb.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" != 11; 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-comb.el'
  35. else
  36. echo 'x - continuing file calc-comb.el'
  37. sed 's/^X//' << 'SHAR_EOF' >> 'calc-comb.el' &&
  38. X     3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907
  39. X     3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013
  40. X     4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129
  41. X     4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243
  42. X     4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363
  43. X     4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493
  44. X     4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621
  45. X     4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729
  46. X     4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871
  47. X     4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973
  48. X     4987 4993 4999 5003])
  49. X
  50. X
  51. X
  52. X
  53. SHAR_EOF
  54. echo 'File calc-comb.el is complete' &&
  55. chmod 0644 calc-comb.el ||
  56. echo 'restore of calc-comb.el failed'
  57. Wc_c="`wc -c < 'calc-comb.el'`"
  58. test 33469 -eq "$Wc_c" ||
  59.     echo 'calc-comb.el: original size 33469, current size' "$Wc_c"
  60. rm -f _shar_wnt_.tmp
  61. fi
  62. # ============= calc-comp.el ==============
  63. if test -f 'calc-comp.el' -a X"$1" != X"-c"; then
  64.     echo 'x - skipping calc-comp.el (File already exists)'
  65.     rm -f _shar_wnt_.tmp
  66. else
  67. > _shar_wnt_.tmp
  68. echo 'x - extracting calc-comp.el (Text)'
  69. sed 's/^X//' << 'SHAR_EOF' > 'calc-comp.el' &&
  70. ;; Calculator for GNU Emacs, part II [calc-comp.el]
  71. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  72. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  73. X
  74. ;; This file is part of GNU Emacs.
  75. X
  76. ;; GNU Emacs is distributed in the hope that it will be useful,
  77. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  78. ;; accepts responsibility to anyone for the consequences of using it
  79. ;; or for whether it serves any particular purpose or works at all,
  80. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  81. ;; License for full details.
  82. X
  83. ;; Everyone is granted permission to copy, modify and redistribute
  84. ;; GNU Emacs, but only under the conditions described in the
  85. ;; GNU Emacs General Public License.   A copy of this license is
  86. ;; supposed to have been given to you along with GNU Emacs so you
  87. ;; can know your rights and responsibilities.  It should be in a
  88. ;; file named COPYING.  Among other things, the copyright notice
  89. ;; and this notice must be preserved on all copies.
  90. X
  91. X
  92. X
  93. ;; This file is autoloaded from calc-ext.el.
  94. (require 'calc-ext)
  95. X
  96. (require 'calc-macs)
  97. X
  98. (defun calc-Need-calc-comp () nil)
  99. X
  100. X
  101. ;;; A "composition" has one of the following forms:
  102. ;;;
  103. ;;;    "string"              A literal string
  104. ;;;
  105. ;;;    (horiz C1 C2 ...)     Horizontally abutted sub-compositions
  106. ;;;
  107. ;;;    (set LEVEL OFF)       Set left margin + offset for line-break level
  108. ;;;    (break LEVEL)         A potential line-break point
  109. ;;;
  110. ;;;    (vleft N C1 C2 ...)   Vertically stacked, left-justified sub-comps
  111. ;;;    (vcent N C1 C2 ...)   Vertically stacked, centered sub-comps
  112. ;;;    (vright N C1 C2 ...)  Vertically stacked, right-justified sub-comps
  113. ;;;                          N specifies baseline of the stack, 0=top line.
  114. ;;;
  115. ;;;    (supscr C1 C2)        Composition C1 with superscript C2
  116. ;;;    (subscr C1 C2)        Composition C1 with subscript C2
  117. ;;;    (rule X)              Horizontal line of X, full width of enclosing comp
  118. ;;;
  119. ;;;    (tag X C)             Composition C corresponds to sub-expression X
  120. X
  121. (defun math-compose-expr (a prec)
  122. X  (let ((math-compose-level (1+ math-compose-level)))
  123. X    (cond
  124. X     ((or (and (eq a math-comp-selected) a)
  125. X      (and math-comp-tagged
  126. X           (not (eq math-comp-tagged a))))
  127. X      (let ((math-comp-selected nil))
  128. X    (and math-comp-tagged (setq math-comp-tagged a))
  129. X    (list 'tag a (math-compose-expr a prec))))
  130. X     ((math-scalarp a)
  131. X      (if (or (eq (car-safe a) 'frac)
  132. X          (and (nth 1 calc-frac-format) (Math-integerp a)))
  133. X      (if (memq calc-language '(tex eqn math))
  134. X          (let ((aa (math-adjust-fraction a))
  135. X            (calc-frac-format nil))
  136. X        (math-compose-expr (list '/ (nth 1 aa) (nth 2 aa)) prec))
  137. X        (if (and (eq calc-language 'big)
  138. X             (= (length (car calc-frac-format)) 1))
  139. X        (let* ((aa (math-adjust-fraction a))
  140. X               (calc-frac-format nil)
  141. X               (math-radix-explicit-format nil)
  142. X               (c (list 'horiz
  143. X                (if (math-negp (nth 1 aa))
  144. X                    "- " "")
  145. X                (list 'vcent 1
  146. X                      (math-format-number
  147. X                       (math-abs (nth 1 aa)))
  148. X                      '(rule ?-)
  149. X                      (math-format-number (nth 2 aa))))))
  150. X          (if (= calc-number-radix 10)
  151. X              c
  152. X            (list 'horiz "(" c
  153. X              (list 'subscr ")"
  154. X                (int-to-string calc-number-radix)))))
  155. X          (math-format-number a)))
  156. X    (if (not (eq calc-language 'big))
  157. X        (math-format-number a prec)
  158. X      (if (memq (car-safe a) '(cplx polar))
  159. X          (if (math-zerop (nth 2 a))
  160. X          (math-compose-expr (nth 1 a) prec)
  161. X        (list 'horiz "("
  162. X              (math-compose-expr (nth 1 a) 0)
  163. X              (if (eq (car a) 'cplx) ", " "; ")
  164. X              (math-compose-expr (nth 2 a) 0) ")"))
  165. X        (if (or (= calc-number-radix 10)
  166. X            (not (Math-realp a))
  167. X            (and calc-group-digits
  168. X             (not (assoc calc-group-char '((",") (" "))))))
  169. X        (math-format-number a prec)
  170. X          (let ((s (math-format-number a prec))
  171. X            (c nil))
  172. X        (while (string-match (if (> calc-number-radix 14)
  173. X                     "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
  174. X                       "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
  175. X                     s)
  176. X          (setq c (nconc c (list (substring s 0 (match-beginning 0))
  177. X                     (list 'subscr
  178. X                           (math-match-substring s 2)
  179. X                           (math-match-substring s 1))))
  180. X            s (substring s (match-end 0))))
  181. X        (if (string-match
  182. X             "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
  183. X            (setq s (list 'horiz
  184. X                  (substring s 0 (match-beginning 0)) " "
  185. X                  (list 'supscr
  186. X                    (math-match-substring s 1)
  187. X                    (math-match-substring s 2))
  188. X                  (math-match-substring s 3))))
  189. X        (if c (cons 'horiz (nconc c (list s))) s)))))))
  190. X     ((not (consp a)) (concat "'" (prin1-to-string a)))
  191. X     ((and (get (car a) 'math-compose-forms)
  192. X       (not (eq calc-language 'unform))
  193. X       (let ((comps (get (car a) 'math-compose-forms))
  194. X         temp temp2)
  195. X         (or (and (setq temp (assq calc-language comps))
  196. X              (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
  197. X                   (setq temp (apply (cdr temp2) (cdr a)))
  198. X                   (math-compose-expr temp prec))
  199. X              (and (setq temp2 (assq nil (cdr temp)))
  200. X                   (funcall (cdr temp2) a))))
  201. X         (and (setq temp (assq nil comps))
  202. X              (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
  203. X                   (setq temp (apply (cdr temp2) (cdr a)))
  204. X                   (math-compose-expr temp prec))
  205. X              (and (setq temp2 (assq nil (cdr temp)))
  206. X                   (funcall (cdr temp2) a))))))))
  207. X     ((eq (car a) 'vec)
  208. X      (let* ((left-bracket (if calc-vector-brackets
  209. X                   (substring calc-vector-brackets 0 1) ""))
  210. X         (right-bracket (if calc-vector-brackets
  211. X                (substring calc-vector-brackets 1 2) ""))
  212. X         (inner-brackets (memq 'R calc-matrix-brackets))
  213. X         (outer-brackets (memq 'O calc-matrix-brackets))
  214. X         (row-commas (memq 'C calc-matrix-brackets))
  215. X         (comma-spc (or calc-vector-commas " "))
  216. X         (comma (or calc-vector-commas ""))
  217. X         (vector-prec (if (or (and calc-vector-commas (nth 2 a))
  218. X                  (memq 'P calc-matrix-brackets)) 0 1000))
  219. X         (just (cond ((eq calc-matrix-just 'right) 'vright)
  220. X             ((eq calc-matrix-just 'center) 'vcent)
  221. X             (t 'vleft)))
  222. X         (break calc-break-vectors))
  223. X    (if (and (memq calc-language '(nil big))
  224. X         (not calc-break-vectors)
  225. X         (math-matrixp a) (not (math-matrixp (nth 1 a)))
  226. X         (or calc-full-vectors
  227. X             (and (< (length a) 7) (< (length (nth 1 a)) 7))
  228. X             (progn (setq break t) nil)))
  229. X        (if (progn
  230. X          (setq vector-prec (if (or (and calc-vector-commas
  231. X                         (nth 2 (nth 1 a)))
  232. X                        (memq 'P calc-matrix-brackets))
  233. X                    0 1000))
  234. X          (= (length a) 2))
  235. X        (list 'horiz
  236. X              (concat left-bracket left-bracket " ")
  237. X              (math-compose-vector (cdr (nth 1 a)) (concat comma " ")
  238. X                       vector-prec)
  239. X              (concat " " right-bracket right-bracket))
  240. X          (let* ((rows (1- (length a)))
  241. X             (cols (1- (length (nth 1 a))))
  242. X             (base (/ (1- rows) 2))
  243. X             (calc-language 'flat))
  244. X        (append '(horiz)
  245. X            (list (append '(vleft)
  246. X                      (list base)
  247. X                      (list (concat (and outer-brackets
  248. X                             (concat left-bracket
  249. X                                 " "))
  250. X                            (and inner-brackets
  251. X                             (concat left-bracket
  252. X                                 " "))))
  253. X                      (make-list (1- rows)
  254. X                         (concat (and outer-brackets
  255. X                                  "  ")
  256. X                             (and inner-brackets
  257. X                                  (concat
  258. X                                   left-bracket
  259. X                                   " "))))))
  260. X            (math-compose-matrix (cdr a) 1 cols base)
  261. X            (list (append '(vleft)
  262. X                      (list base)
  263. X                      (make-list (1- rows)
  264. X                         (if inner-brackets
  265. X                             (concat " "
  266. X                                 right-bracket
  267. X                                 (and row-commas
  268. X                                  comma))
  269. X                           (if (and outer-brackets
  270. X                                row-commas)
  271. X                               ";" "")))
  272. X                      (list (concat
  273. X                         (and inner-brackets
  274. X                          (concat " "
  275. X                              right-bracket))
  276. X                         (and outer-brackets
  277. X                          (concat
  278. X                           " "
  279. X                           right-bracket)))))))))
  280. X      (if (and calc-display-strings
  281. X           (cdr a)
  282. X           (math-vector-is-string a))
  283. X          (math-vector-to-string a t)
  284. X        (if (and break (cdr a)
  285. X             (not (eq calc-language 'flat)))
  286. X        (let* ((full (or calc-full-vectors (< (length a) 7)))
  287. X               (rows (if full (1- (length a)) 5))
  288. X               (base (/ (1- rows) 2))
  289. X               (just 'vleft)
  290. X               (calc-break-vectors nil))
  291. X          (list 'horiz
  292. X            (cons 'vleft (cons base
  293. X                       (math-compose-rows
  294. X                        (cdr a)
  295. X                        (if full rows 3) t)))))
  296. X          (if (or calc-full-vectors (< (length a) 7))
  297. X          (if (and (eq calc-language 'tex)
  298. X               (math-matrixp a))
  299. X              (append '(horiz "\\matrix{ ")
  300. X                  (math-compose-tex-matrix (cdr a))
  301. X                  '(" }"))
  302. X            (if (and (eq calc-language 'eqn)
  303. X                 (math-matrixp a))
  304. X            (append '(horiz "matrix { ")
  305. X                (math-compose-eqn-matrix
  306. X                 (cdr (math-transpose a)))
  307. X                '("}"))
  308. X              (if (and (eq calc-language 'maple)
  309. X                   (math-matrixp a))
  310. X              (list 'horiz
  311. X                "matrix("
  312. X                left-bracket
  313. X                (math-compose-vector (cdr a) (concat comma " ")
  314. X                             vector-prec)
  315. X                right-bracket
  316. X                ")")
  317. X            (list 'horiz
  318. X                  left-bracket
  319. X                  (math-compose-vector (cdr a) (concat comma " ")
  320. X                           vector-prec)
  321. X                  right-bracket))))
  322. X        (list 'horiz
  323. X              left-bracket
  324. X              (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
  325. X                       (concat comma " ") vector-prec)
  326. X              comma (if (eq calc-language 'tex) " \\ldots" " ...")
  327. X              comma " "
  328. X              (list 'break math-compose-level)
  329. X              (math-compose-expr (nth (1- (length a)) a)
  330. X                     (if (equal comma "") 1000 0))
  331. X              right-bracket)))))))
  332. X     ((eq (car a) 'incomplete)
  333. X      (if (cdr (cdr a))
  334. X      (cond ((eq (nth 1 a) 'vec)
  335. X         (list 'horiz "["
  336. X               (math-compose-vector (cdr (cdr a)) ", " 0)
  337. X               " ..."))
  338. X        ((eq (nth 1 a) 'cplx)
  339. X         (list 'horiz "("
  340. X               (math-compose-vector (cdr (cdr a)) ", " 0)
  341. X               ", ..."))
  342. X        ((eq (nth 1 a) 'polar)
  343. X         (list 'horiz "("
  344. X               (math-compose-vector (cdr (cdr a)) "; " 0)
  345. X               "; ..."))
  346. X        ((eq (nth 1 a) 'intv)
  347. X         (list 'horiz
  348. X               (if (memq (nth 2 a) '(0 1)) "(" "[")
  349. X               (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
  350. X               " .. ..."))
  351. X        (t (format "%s" a)))
  352. X    (cond ((eq (nth 1 a) 'vec) "[ ...")
  353. X          ((eq (nth 1 a) 'intv)
  354. X           (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
  355. X          (t "( ..."))))
  356. X     ((eq (car a) 'var)
  357. X      (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
  358. X    (if v
  359. X        (symbol-name (car v))
  360. X      (if (and (eq calc-language 'tex)
  361. X           calc-language-option
  362. X           (not (= calc-language-option 0))
  363. X           (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
  364. X                 (symbol-name (nth 1 a))))
  365. X          (format "\\hbox{%s}" (symbol-name (nth 1 a)))
  366. X        (if (and math-compose-hash-args
  367. X             (let ((p calc-arg-values))
  368. X               (setq v 1)
  369. X               (while (and p (not (equal (car p) a)))
  370. X             (setq p (and (eq math-compose-hash-args t) (cdr p))
  371. X                   v (1+ v)))
  372. X               p))
  373. X        (if (eq math-compose-hash-args 1)
  374. X            "#"
  375. X          (format "#%d" v))
  376. X          (if (memq calc-language '(c fortran pascal maple))
  377. X          (math-to-underscores (symbol-name (nth 1 a)))
  378. X        (if (and (eq calc-language 'eqn)
  379. X             (string-match ".'\\'" (symbol-name (nth 2 a))))
  380. X            (math-compose-expr
  381. X             (list 'calcFunc-Prime
  382. X               (list
  383. X                'var
  384. X                (intern (substring (symbol-name (nth 1 a)) 0 -1))
  385. X                (intern (substring (symbol-name (nth 2 a)) 0 -1))))
  386. X             prec)
  387. X          (symbol-name (nth 1 a)))))))))
  388. X     ((eq (car a) 'intv)
  389. X      (list 'horiz
  390. X        (if (eq calc-language 'maple) ""
  391. X          (if (memq (nth 1 a) '(0 1)) "(" "["))
  392. X        (math-compose-expr (nth 2 a) 0)
  393. X        (if (eq calc-language 'tex) " \\ldots "
  394. X          (if (eq calc-language 'eqn) " ... " " .. "))
  395. X        (math-compose-expr (nth 3 a) 0)
  396. X        (if (eq calc-language 'maple) ""
  397. X          (if (memq (nth 1 a) '(0 2)) ")" "]"))))
  398. X     ((eq (car a) 'date)
  399. X      (if (eq (car calc-date-format) 'X)
  400. X      (math-format-date a)
  401. X    (concat "<" (math-format-date a) ">")))
  402. X     ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a))
  403. X       (memq calc-language '(c pascal fortran maple)))
  404. X      (list 'horiz
  405. X        (math-compose-expr (nth 1 a) 1000)
  406. X        (if (eq calc-language 'fortran) "(" "[")
  407. X        (math-compose-vector (cdr (cdr a)) ", " 0)
  408. X        (if (eq calc-language 'fortran) ")" "]")))
  409. X     ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
  410. X       (eq calc-language 'big))
  411. X      (let* ((a1 (math-compose-expr (nth 1 a) 1000))
  412. X         (calc-language 'flat)
  413. X         (a2 (math-compose-expr (nth 2 a) 0)))
  414. X    (if (or (eq (car-safe a1) 'subscr)
  415. X        (and (eq (car-safe a1) 'tag)
  416. X             (eq (car-safe (nth 2 a1)) 'subscr)))
  417. X        (list 'subscr
  418. X          (nth 1 a1)
  419. X          (list 'horiz
  420. X            (nth 2 a1)
  421. X            ", "
  422. X            a2))
  423. X      (list 'subscr a1 a2))))
  424. X     ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
  425. X       (eq calc-language 'math))
  426. X      (list 'horiz
  427. X        (math-compose-expr (nth 1 a) 1000)
  428. X        "[["
  429. X        (math-compose-expr (nth 2 a) 0)
  430. X        "]]"))
  431. X     ((and (eq (car a) 'calcFunc-sqrt)
  432. X       (eq calc-language 'tex))
  433. X      (list 'horiz
  434. X        "\\sqrt{"
  435. X        (math-compose-expr (nth 1 a) 0)
  436. X        "}"))
  437. X     ((and nil (eq (car a) 'calcFunc-sqrt)
  438. X       (eq calc-language 'eqn))
  439. X      (list 'horiz
  440. X        "sqrt {"
  441. X        (math-compose-expr (nth 1 a) -1)
  442. X        "}"))
  443. X     ((and (eq (car a) '^)
  444. X       (eq calc-language 'big))
  445. X      (list 'supscr
  446. X        (if (or (math-looks-negp (nth 1 a))
  447. X            (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
  448. X            (and (eq (car-safe (nth 1 a)) 'cplx)
  449. X             (math-negp (nth 1 (nth 1 a)))
  450. X             (eq (nth 2 (nth 1 a)) 0)))
  451. X        (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
  452. X          (math-compose-expr (nth 1 a) 201))
  453. X        (let ((calc-language 'flat))
  454. X          (math-compose-expr (nth 2 a) 0))))
  455. X     ((and (eq (car a) '/)
  456. X       (eq calc-language 'big))
  457. X      (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
  458. X                     'flat 'big)))
  459. X          (math-compose-expr (nth 1 a) 0)))
  460. X        (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
  461. X                     'flat 'big)))
  462. X          (math-compose-expr (nth 2 a) 0))))
  463. X    (list 'vcent
  464. X          (math-comp-height a1)
  465. X          a1 '(rule ?-) a2)))
  466. X     ((and (memq (car a) '(calcFunc-sum calcFunc-prod))
  467. X       (eq calc-language 'tex)
  468. X       (= (length a) 5))
  469. X      (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod")
  470. X        "_{" (math-compose-expr (nth 2 a) 0)
  471. X        "=" (math-compose-expr (nth 3 a) 0)
  472. X        "}^{" (math-compose-expr (nth 4 a) 0)
  473. X        "}{" (math-compose-expr (nth 1 a) 0) "}"))
  474. X     ((and (eq (car a) 'calcFunc-lambda)
  475. X       (> (length a) 2)
  476. X       (memq calc-language '(nil flat big)))
  477. X      (let ((p (cdr a))
  478. X        (ap calc-arg-values)
  479. X        (math-compose-hash-args (if (= (length a) 3) 1 t)))
  480. X    (while (and (cdr p) (equal (car p) (car ap)))
  481. X      (setq p (cdr p) ap (cdr ap)))
  482. X    (append '(horiz "<")
  483. X        (if (cdr p)
  484. X            (list (math-compose-vector
  485. X               (nreverse (cdr (reverse (cdr a)))) ", " 0)
  486. X              " : ")
  487. X          nil)
  488. X        (list (math-compose-expr (nth (1- (length a)) a) 0)
  489. X              ">"))))
  490. X     ((and (eq (car a) 'calcFunc-string)
  491. X       (= (length a) 2)
  492. X       (math-vectorp (nth 1 a))
  493. X       (math-vector-is-string (nth 1 a)))
  494. X      (if (eq calc-language 'unform)
  495. X      (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
  496. X    (math-vector-to-string (nth 1 a) nil)))
  497. X     ((and (eq (car a) 'calcFunc-bstring)
  498. X       (= (length a) 2)
  499. X       (math-vectorp (nth 1 a))
  500. X       (math-vector-is-string (nth 1 a)))
  501. X      (if (eq calc-language 'unform)
  502. X      (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
  503. X    (let ((c nil)
  504. X          (s (math-vector-to-string (nth 1 a) nil))
  505. X          p)
  506. X      (while (string-match "[^ ] +[^ ]" s)
  507. X        (setq p (1- (match-end 0))
  508. X          c (cons (list 'break math-compose-level)
  509. X              (cons (substring s 0 p)
  510. X                c))
  511. X          s (substring s p)))
  512. X      (setq c (nreverse (cons s c)))
  513. X      (or (= prec -123)
  514. X          (setq c (cons (list 'set math-compose-level 2) c)))
  515. X      (cons 'horiz c))))
  516. X     ((and (eq (car a) 'calcFunc-cprec)
  517. X       (not (eq calc-language 'unform))
  518. X       (= (length a) 3)
  519. X       (integerp (nth 2 a)))
  520. X      (let ((c (math-compose-expr (nth 1 a) -1)))
  521. X    (if (> prec (nth 2 a))
  522. X        (if (eq calc-language 'tex)
  523. X        (list 'horiz "\\left( " c " \\right)")
  524. X          (if (eq calc-language 'eqn)
  525. X          (list 'horiz "{left ( " c " right )}")
  526. X        (list 'horiz "(" c ")")))
  527. X      c)))
  528. X     ((and (eq (car a) 'calcFunc-choriz)
  529. X       (not (eq calc-language 'unform))
  530. X       (memq (length a) '(2 3 4))
  531. X       (math-vectorp (nth 1 a))
  532. X       (if (integerp (nth 2 a))
  533. X           (or (null (nth 3 a))
  534. X           (and (math-vectorp (nth 3 a))
  535. X            (math-vector-is-string (nth 3 a))))
  536. X         (or (null (nth 2 a))
  537. X         (and (math-vectorp (nth 2 a))
  538. X              (math-vector-is-string (nth 2 a))))))
  539. X      (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
  540. X         (sep (nth (if cprec 3 2) a))
  541. X         (bprec nil))
  542. X    (if sep
  543. X        (math-compose-vector (cdr (nth 1 a))
  544. X                 (math-vector-to-string sep nil)
  545. X                 (or cprec prec))
  546. X      (cons 'horiz (mapcar (function
  547. X                (lambda (x)
  548. X                  (if (eq (car-safe x) 'calcFunc-bstring)
  549. X                      (prog1
  550. X                      (math-compose-expr
  551. X                       x (or bprec cprec prec))
  552. X                    (setq bprec -123))
  553. X                    (math-compose-expr x (or cprec prec)))))
  554. X                   (cdr (nth 1 a)))))))
  555. X     ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
  556. X       (not (eq calc-language 'unform))
  557. X       (memq (length a) '(2 3))
  558. X       (math-vectorp (nth 1 a))
  559. X       (or (null (nth 2 a))
  560. X           (integerp (nth 2 a))))
  561. X      (let* ((base 0)
  562. X         (v 0)
  563. X         (prec (or (nth 2 a) prec))
  564. X         (c (mapcar (function
  565. X             (lambda (x)
  566. X               (let ((b nil) (cc nil) a d)
  567. X                 (if (and (memq (car-safe x) '(calcFunc-cbase
  568. X                               calcFunc-ctbase
  569. X                               calcFunc-cbbase))
  570. X                      (memq (length x) '(1 2)))
  571. X                 (setq b (car x)
  572. X                       x (nth 1 x)))
  573. X                 (if (and (eq (car-safe x) 'calcFunc-crule)
  574. X                      (memq (length x) '(1 2))
  575. X                      (or (null (nth 1 x))
  576. X                      (and (math-vectorp (nth 1 x))
  577. X                           (= (length (nth 1 x)) 2)
  578. X                           (math-vector-is-string
  579. X                        (nth 1 x)))
  580. X                      (and (natnump (nth 1 x))
  581. X                           (<= (nth 1 x) 255))))
  582. X                 (setq cc (list
  583. X                       'rule
  584. X                       (if (math-vectorp (nth 1 x))
  585. X                           (aref (math-vector-to-string
  586. X                              (nth 1 x) nil) 0)
  587. X                         (or (nth 1 x) ?-))))
  588. X                   (or (and (memq (car-safe x) '(calcFunc-cvspace
  589. X                                 calcFunc-ctspace
  590. X                                 calcFunc-cbspace))
  591. X                    (memq (length x) '(2 3))
  592. X                    (eq (nth 1 x) 0))
  593. X                   (null x)
  594. X                   (setq cc (math-compose-expr x prec))))
  595. X                 (setq a (if cc (math-comp-ascent cc) 0)
  596. X                   d (if cc (math-comp-descent cc) 0))
  597. X                 (if (eq b 'calcFunc-cbase)
  598. X                 (setq base (+ v a -1))
  599. X                   (if (eq b 'calcFunc-ctbase)
  600. X                   (setq base v)
  601. X                 (if (eq b 'calcFunc-cbbase)
  602. X                     (setq base (+ v a d -1)))))
  603. X                 (setq v (+ v a d))
  604. X                 cc)))
  605. X            (cdr (nth 1 a)))))
  606. X    (setq c (delq nil c))
  607. X    (if c
  608. X        (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
  609. X            (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
  610. X          (cons base c))
  611. X      " ")))
  612. X     ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
  613. X       (not (eq calc-language 'unform))
  614. X       (memq (length a) '(3 4))
  615. X       (or (null (nth 3 a))
  616. X           (integerp (nth 3 a))))
  617. X      (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
  618. X        (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
  619. X        (math-compose-expr (nth 2 a) 0)))
  620. X     ((and (eq (car a) 'calcFunc-cflat)
  621. X       (not (eq calc-language 'unform))
  622. X       (memq (length a) '(2 3))
  623. X       (or (null (nth 2 a))
  624. X           (integerp (nth 2 a))))
  625. X      (let ((calc-language (if (memq calc-language '(nil big))
  626. X                   'flat calc-language)))
  627. X    (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
  628. X     ((and (eq (car a) 'calcFunc-cspace)
  629. X       (memq (length a) '(2 3))
  630. X       (natnump (nth 1 a)))
  631. X      (if (nth 2 a)
  632. X      (cons 'horiz (make-list (nth 1 a)
  633. X                  (if (and (math-vectorp (nth 2 a))
  634. X                       (math-vector-is-string (nth 2 a)))
  635. X                      (math-vector-to-string (nth 2 a) nil)
  636. X                    (math-compose-expr (nth 2 a) 0))))
  637. X    (make-string (nth 1 a) ?\ )))
  638. X     ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
  639. X       (memq (length a) '(2 3))
  640. X       (natnump (nth 1 a)))
  641. X      (if (= (nth 1 a) 0)
  642. X      ""
  643. X    (let* ((c (if (nth 2 a)
  644. X              (if (and (math-vectorp (nth 2 a))
  645. X                   (math-vector-is-string (nth 2 a)))
  646. X              (math-vector-to-string (nth 2 a) nil)
  647. X            (math-compose-expr (nth 2 a) 0))
  648. X            " "))
  649. X           (ca (math-comp-ascent c))
  650. X           (cd (math-comp-descent c)))
  651. X      (cons 'vleft
  652. X        (cons (if (eq (car a) 'calcFunc-ctspace)
  653. X              (1- ca)
  654. X            (if (eq (car a) 'calcFunc-cbspace)
  655. X                (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
  656. X              (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
  657. X              (make-list (nth 1 a) c))))))
  658. X     ((and (eq (car a) 'calcFunc-evalto)
  659. X       (setq calc-any-evaltos t)
  660. X       (memq calc-language '(tex eqn))
  661. X       (= math-compose-level (if math-comp-tagged 2 1))
  662. X       (= (length a) 3))
  663. X      (list 'horiz
  664. X        (if (eq calc-language 'tex) "\\evalto " "evalto ")
  665. X        (math-compose-expr (nth 1 a) 0)
  666. X        (if (eq calc-language 'tex) " \\to " " -> ")
  667. X        (math-compose-expr (nth 2 a) 0)))
  668. X     (t
  669. X      (let ((op (and (not (eq calc-language 'unform))
  670. X             (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
  671. X             (assoc "?" math-expr-opers)
  672. X               (math-assq2 (car a) math-expr-opers)))))
  673. X    (cond ((and op
  674. X            (or (= (length a) 3) (eq (car a) 'calcFunc-if))
  675. X            (/= (nth 3 op) -1))
  676. X           (cond
  677. X        ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
  678. X         (if (and (eq calc-language 'tex)
  679. X              (not (math-tex-expr-is-flat a)))
  680. X             (if (eq (car-safe a) '/)
  681. X             (list 'horiz "{" (math-compose-expr a -1) "}")
  682. X               (list 'horiz "\\left( "
  683. X                 (math-compose-expr a -1)
  684. X                 " \\right)"))
  685. X           (if (eq calc-language 'eqn)
  686. X               (if (or (eq (car-safe a) '/)
  687. X                   (= (/ prec 100) 9))
  688. X               (list 'horiz "{" (math-compose-expr a -1) "}")
  689. X             (if (math-tex-expr-is-flat a)
  690. X                 (list 'horiz "( " (math-compose-expr a -1) " )")
  691. X               (list 'horiz "{left ( "
  692. X                 (math-compose-expr a -1)
  693. X                 " right )}")))
  694. X             (list 'horiz "(" (math-compose-expr a 0) ")"))))
  695. X        ((and (eq calc-language 'tex)
  696. X              (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
  697. X              (>= prec 0))
  698. X         (list 'horiz "{" (math-compose-expr a -1) "}"))
  699. X        ((eq (car a) 'calcFunc-if)
  700. X         (list 'horiz
  701. X               (math-compose-expr (nth 1 a) (nth 2 op))
  702. X               " ? "
  703. X               (math-compose-expr (nth 2 a) 0)
  704. X               " : "
  705. X               (math-compose-expr (nth 3 a) (nth 3 op))))
  706. X        (t
  707. X         (let* ((math-comp-tagged (and math-comp-tagged
  708. X                           (not (math-primp a))
  709. X                           math-comp-tagged))
  710. X            (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
  711. X                    (progn
  712. X                      (setq math-compose-level
  713. X                        (1- math-compose-level))
  714. X                      nil)
  715. X                  math-compose-level))
  716. X            (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
  717. X            (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
  718. X           (and (equal (car op) "^")
  719. X            (eq (math-comp-first-char lhs) ?-)
  720. X            (setq lhs (list 'horiz "(" lhs ")")))
  721. X           (and (eq calc-language 'tex)
  722. X            (or (equal (car op) "^") (equal (car op) "_"))
  723. X            (not (and (stringp rhs) (= (length rhs) 1)))
  724. X            (setq rhs (list 'horiz "{" rhs "}")))
  725. X           (or (and (eq (car a) '*)
  726. X                (or (null calc-language)
  727. X                (assoc "2x" math-expr-opers))
  728. X                (let* ((prevt (math-prod-last-term (nth 1 a)))
  729. X                   (nextt (math-prod-first-term (nth 2 a)))
  730. X                   (prevc (or (math-comp-last-char lhs)
  731. X                          (and (memq (car-safe prevt)
  732. X                             '(^ calcFunc-subscr
  733. X                                 calcFunc-sqrt
  734. X                                 frac))
  735. X                           (eq calc-language 'big)
  736. X                           ?0)))
  737. X                   (nextc (or (math-comp-first-char rhs)
  738. X                          (and (memq (car-safe nextt)
  739. X                             '(calcFunc-sqrt
  740. X                               calcFunc-sum
  741. X                               calcFunc-prod
  742. X                               calcFunc-integ))
  743. X                           (eq calc-language 'big)
  744. X                           ?0))))
  745. X                  (and prevc nextc
  746. X                   (or (and (>= nextc ?a) (<= nextc ?z))
  747. X                       (and (>= nextc ?A) (<= nextc ?Z))
  748. X                       (and (>= nextc ?0) (<= nextc ?9))
  749. X                       (memq nextc '(?. ?_ ?#
  750. X                            ?\( ?\[ ?\{))
  751. X                       (and (eq nextc ?\\)
  752. X                        (not (string-match
  753. X                          "\\`\\\\left("
  754. X                          (math-comp-first-string
  755. X                           rhs)))))
  756. X                   (not (and (eq (car-safe prevt) 'var)
  757. X                         (eq nextc ?\()))
  758. X                   (list 'horiz
  759. X                     (list 'set setlev 1)
  760. X                     lhs
  761. X                     (list 'break math-compose-level)
  762. X                     " "
  763. X                     rhs))))
  764. X               (list 'horiz
  765. X                 (list 'set setlev 1)
  766. X                 lhs
  767. X                 (list 'break math-compose-level)
  768. X                 (if (or (equal (car op) "^")
  769. X                     (equal (car op) "_")
  770. X                     (equal (car op) "**")
  771. X                     (and (equal (car op) "*")
  772. X                      (math-comp-last-char lhs)
  773. X                      (math-comp-first-char rhs)))
  774. X                 (car op)
  775. X                   (if (and (eq calc-language 'big)
  776. X                    (equal (car op) "=>"))
  777. X                   "  =>  "
  778. X                 (concat " " (car op) " ")))
  779. X                 rhs))))))
  780. X          ((and op (= (length a) 2) (= (nth 3 op) -1))
  781. X           (cond
  782. X        ((or (> prec (or (nth 4 op) (nth 2 op)))
  783. X             (and (not (eq (assoc (car op) math-expr-opers) op))
  784. X              (> prec 0)))   ; don't write x% + y
  785. X         (if (and (eq calc-language 'tex)
  786. X              (not (math-tex-expr-is-flat a)))
  787. X             (list 'horiz "\\left( "
  788. X               (math-compose-expr a -1)
  789. X               " \\right)")
  790. X           (if (eq calc-language 'eqn)
  791. X               (if (= (/ prec 100) 9)
  792. X               (list 'horiz "{" (math-compose-expr a -1) "}")
  793. X             (if (math-tex-expr-is-flat a)
  794. X                 (list 'horiz "{( " (math-compose-expr a -1) " )}")
  795. X               (list 'horiz "{left ( "
  796. X                 (math-compose-expr a -1)
  797. X                 " right )}")))
  798. X             (list 'horiz "(" (math-compose-expr a 0) ")"))))
  799. X        (t
  800. X         (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
  801. X         (list 'horiz
  802. X               lhs
  803. X               (if (or (> (length (car op)) 1)
  804. X                   (not (math-comp-is-flat lhs)))
  805. X               (concat " " (car op))
  806. X             (car op)))))))
  807. X          ((and op (= (length a) 2) (= (nth 2 op) -1))
  808. X           (cond
  809. X        ((eq (nth 3 op) 0)
  810. X         (let ((lr (and (eq calc-language 'tex)
  811. X                (not (math-tex-expr-is-flat (nth 1 a))))))
  812. X           (list 'horiz
  813. X             (if lr "\\left" "")
  814. X             (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
  815. X                 (substring (car op) 1)
  816. X               (car op))
  817. X             (if (or lr (> (length (car op)) 2)) " " "")
  818. X             (math-compose-expr (nth 1 a) -1)
  819. X             (if (or lr (> (length (car op)) 2)) " " "")
  820. X             (if lr "\\right" "")
  821. X             (car (nth 1 (memq op math-expr-opers))))))
  822. X        ((> prec (or (nth 4 op) (nth 3 op)))
  823. X         (if (and (eq calc-language 'tex)
  824. X              (not (math-tex-expr-is-flat a)))
  825. X             (list 'horiz "\\left( "
  826. X               (math-compose-expr a -1)
  827. X               " \\right)")
  828. X           (if (eq calc-language 'eqn)
  829. X               (if (= (/ prec 100) 9)
  830. X               (list 'horiz "{" (math-compose-expr a -1) "}")
  831. X             (if (math-tex-expr-is-flat a)
  832. X                 (list 'horiz "{( " (math-compose-expr a -1) " )}")
  833. X               (list 'horiz "{left ( "
  834. X                 (math-compose-expr a -1)
  835. X                 " right )}")))
  836. X             (list 'horiz "(" (math-compose-expr a 0) ")"))))
  837. X        (t
  838. X         (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
  839. X           (list 'horiz
  840. X             (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
  841. X                              (car op))
  842. X                    (substring (car op) 1)
  843. X                      (car op))))
  844. X               (if (or (> (length ops) 1)
  845. X                   (not (math-comp-is-flat rhs)))
  846. X                   (concat ops " ")
  847. X                 ops))
  848. X             rhs)))))
  849. X          ((and (eq calc-language 'big)
  850. X            (setq op (get (car a) 'math-compose-big))
  851. X            (funcall op a prec)))
  852. X          ((and (setq op (assq calc-language
  853. X                   '( ( nil . math-compose-normal )
  854. X                      ( flat . math-compose-normal )
  855. X                      ( big . math-compose-normal )
  856. X                      ( c . math-compose-c )
  857. X                      ( pascal . math-compose-pascal )
  858. X                      ( fortran . math-compose-fortran )
  859. X                      ( tex . math-compose-tex )
  860. X                      ( eqn . math-compose-eqn )
  861. X                      ( math . math-compose-math )
  862. X                      ( maple . math-compose-maple ))))
  863. X            (setq op (get (car a) (cdr op)))
  864. X            (funcall op a prec)))
  865. X          (t
  866. X           (let* ((func (car a))
  867. X              (func2 (assq func '(( mod . calcFunc-makemod )
  868. X                      ( sdev . calcFunc-sdev )
  869. X                      ( + . calcFunc-add )
  870. X                      ( - . calcFunc-sub )
  871. X                      ( * . calcFunc-mul )
  872. X                      ( / . calcFunc-div )
  873. X                      ( % . calcFunc-mod )
  874. X                      ( ^ . calcFunc-pow )
  875. X                      ( neg . calcFunc-neg )
  876. X                      ( | . calcFunc-vconcat ))))
  877. X              left right args)
  878. X         (if func2
  879. X             (setq func (cdr func2)))
  880. X         (if (setq func2 (rassq func math-expr-function-mapping))
  881. X             (setq func (car func2)))
  882. X         (setq func (math-remove-dashes
  883. X                 (if (string-match
  884. X                  "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
  885. X                  (symbol-name func))
  886. X                 (math-match-substring (symbol-name func) 1)
  887. X                   (symbol-name func))))
  888. X         (if (and (eq calc-language 'tex)
  889. X              calc-language-option
  890. X              (not (= calc-language-option 0))
  891. X              (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func))
  892. X             (if (< (prefix-numeric-value calc-language-option) 0)
  893. X             (setq func (format "\\%s" func))
  894. X               (setq func (format "\\hbox{%s}" func))))
  895. X         (if (and (eq calc-language 'eqn)
  896. X              (string-match "[^']'+\\'" func))
  897. X             (let ((n (- (length func) (match-beginning 0) 1)))
  898. X               (setq func (substring func 0 (- n)))
  899. X               (while (>= (setq n (1- n)) 0)
  900. X             (setq func (concat func " prime")))))
  901. X         (cond ((and (eq calc-language 'tex)
  902. X                 (or (> (length a) 2)
  903. X                 (not (math-tex-expr-is-flat (nth 1 a)))))
  904. X            (setq left "\\left( "
  905. X                  right " \\right)"))
  906. X               ((and (eq calc-language 'eqn)
  907. X                 (or (> (length a) 2)
  908. X                 (not (math-tex-expr-is-flat (nth 1 a)))))
  909. X            (setq left "{left ( "
  910. X                  right " right )}"))
  911. X               ((and (or (and (eq calc-language 'tex)
  912. X                      (eq (aref func 0) ?\\))
  913. X                 (and (eq calc-language 'eqn)
  914. X                      (memq (car a) math-eqn-special-funcs)))
  915. X                 (not (string-match "\\hbox{" func))
  916. X                 (= (length a) 2)
  917. X                 (or (Math-realp (nth 1 a))
  918. X                 (memq (car (nth 1 a)) '(var *))))
  919. X            (setq left (if (eq calc-language 'eqn) "~{" "{")
  920. X                  right "}"))
  921. X               ((eq calc-language 'eqn)
  922. X            (setq left " ( "
  923. X                  right " )"))
  924. X               (t (setq left calc-function-open
  925. X                right calc-function-close)))
  926. X         (list 'horiz func left
  927. X               (math-compose-vector (cdr a)
  928. X                        (if (eq calc-language 'eqn)
  929. X                        " , " ", ")
  930. X                        0)
  931. X               right))))))))
  932. )
  933. X
  934. (defconst math-eqn-special-funcs
  935. X  '( calcFunc-log
  936. X     calcFunc-ln calcFunc-exp
  937. X     calcFunc-sin calcFunc-cos calcFunc-tan
  938. X     calcFunc-sinh calcFunc-cosh calcFunc-tanh
  939. X     calcFunc-arcsin calcFunc-arccos calcFunc-arctan
  940. X     calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
  941. ))
  942. X
  943. X
  944. (defun math-prod-first-term (x)
  945. X  (while (eq (car-safe x) '*)
  946. X    (setq x (nth 1 x)))
  947. X  x
  948. )
  949. X
  950. (defun math-prod-last-term (x)
  951. X  (while (eq (car-safe x) '*)
  952. X    (setq x (nth 2 x)))
  953. X  x
  954. )
  955. X
  956. (defun math-compose-vector (a sep prec)
  957. X  (if a
  958. X      (cons 'horiz
  959. X        (cons (list 'set math-compose-level)
  960. X          (let ((c (list (math-compose-expr (car a) prec))))
  961. X            (while (setq a (cdr a))
  962. X              (setq c (cons (if (eq (car-safe (car a))
  963. X                        'calcFunc-bstring)
  964. X                    (let ((math-compose-level
  965. X                           (1- math-compose-level)))
  966. X                      (math-compose-expr (car a) -123))
  967. X                      (math-compose-expr (car a) prec))
  968. X                    (cons (list 'break math-compose-level)
  969. X                      (cons sep c)))))
  970. X            (nreverse c))))
  971. X    "")
  972. )
  973. X
  974. (defun math-compose-matrix (a col cols base)
  975. X  (math-compose-matrix-step a col)
  976. )
  977. X
  978. (defun math-compose-matrix-step (a col)
  979. X  (if (= col cols)
  980. X      (list (cons just
  981. X          (cons base
  982. X            (mapcar (function (lambda (r)
  983. X                        (math-compose-expr
  984. X                         (nth col r)
  985. X                         vector-prec)))
  986. X                a))))
  987. X    (cons (cons just
  988. X        (cons base
  989. X              (mapcar (function
  990. X                   (lambda (r) (list 'horiz
  991. X                         (math-compose-expr
  992. X                          (nth col r)
  993. X                          vector-prec)
  994. X                         (concat comma-spc " "))))
  995. X                  a)))
  996. X      (math-compose-matrix-step a (1+ col))))
  997. )
  998. X
  999. (defun math-compose-rows (a count first)
  1000. X  (if (cdr a)
  1001. X      (if (<= count 0)
  1002. X      (if (< count 0)
  1003. X          (math-compose-rows (cdr a) -1 nil)
  1004. X        (cons (concat (if (eq calc-language 'tex) "  \\ldots" "  ...")
  1005. X              comma)
  1006. X          (math-compose-rows (cdr a) -1 nil)))
  1007. X    (cons (list 'horiz
  1008. X            (if first (concat left-bracket " ") "  ")
  1009. X            (math-compose-expr (car a) vector-prec)
  1010. X            comma)
  1011. X          (math-compose-rows (cdr a) (1- count) nil)))
  1012. X    (list (list 'horiz
  1013. X        (if first (concat left-bracket " ") "  ")
  1014. X        (math-compose-expr (car a) vector-prec)
  1015. X        (concat " " right-bracket))))
  1016. )
  1017. X
  1018. (defun math-compose-tex-matrix (a)
  1019. X  (if (cdr a)
  1020. X      (cons (math-compose-vector (cdr (car a)) " & " 0)
  1021. X        (cons " \\\\ "
  1022. X          (math-compose-tex-matrix (cdr a))))
  1023. X    (list (math-compose-vector (cdr (car a)) " & " 0)))
  1024. )
  1025. X
  1026. (defun math-compose-eqn-matrix (a)
  1027. X  (if a
  1028. X      (cons
  1029. X       (cond ((eq calc-matrix-just 'right) "rcol ")
  1030. X         ((eq calc-matrix-just 'center) "ccol ")
  1031. X         (t "lcol "))
  1032. X       (cons
  1033. X    (list 'break math-compose-level)
  1034. X    (cons
  1035. X     "{ "
  1036. X     (cons
  1037. X      (let ((math-compose-level (1+ math-compose-level)))
  1038. X        (math-compose-vector (cdr (car a)) " above " 1000))
  1039. X      (cons
  1040. X       " } "
  1041. X       (math-compose-eqn-matrix (cdr a)))))))
  1042. X    nil)
  1043. )
  1044. X
  1045. (defun math-vector-is-string (a)
  1046. X  (while (and (setq a (cdr a))
  1047. X          (or (and (natnump (car a))
  1048. X               (<= (car a) 255))
  1049. X          (and (eq (car-safe (car a)) 'cplx)
  1050. X               (natnump (nth 1 (car a)))
  1051. X               (eq (nth 2 (car a)) 0)
  1052. X               (<= (nth 1 (car a)) 255)))))
  1053. X  (null a)
  1054. )
  1055. X
  1056. (defun math-vector-to-string (a &optional quoted)
  1057. X  (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
  1058. X              (cdr a))))
  1059. X  (if (string-match "[\000-\037\177\\\"]" a)
  1060. X      (let ((p 0)
  1061. X        (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
  1062. X        (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
  1063. X        (fmt (if quoted "\\^%c" "^%c"))
  1064. X        new)
  1065. X    (while (setq p (string-match pat a p))
  1066. X      (if (setq new (assq (aref a p) codes))
  1067. X          (setq a (concat (substring a 0 p)
  1068. X                  (cdr new)
  1069. X                  (substring a (1+ p)))
  1070. X            p (+ p (length (cdr new))))
  1071. X        (setq a (concat (substring a 0 p)
  1072. X                (format fmt (+ (aref a p) 64))
  1073. X                (substring a (1+ p)))
  1074. X          p (+ p 2))))))
  1075. X  (if quoted
  1076. X      (concat "\"" a "\"")
  1077. X    a)
  1078. )
  1079. (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
  1080. X                     ( ?\\ . "\\\\" )
  1081. X                     ( ?\a . "\\a" )
  1082. X                     ( ?\b . "\\b" )
  1083. X                     ( ?\e . "\\e" )
  1084. X                     ( ?\f . "\\f" )
  1085. X                     ( ?\n . "\\n" )
  1086. X                     ( ?\r . "\\r" )
  1087. X                     ( ?\t . "\\t" )
  1088. X                     ( ?\^? . "\\^?" )
  1089. ))
  1090. X
  1091. (defun math-to-underscores (x)
  1092. X  (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
  1093. X      (math-to-underscores
  1094. X       (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
  1095. X    x)
  1096. )
  1097. X
  1098. (defun math-tex-expr-is-flat (a)
  1099. X  (or (Math-integerp a)
  1100. X      (memq (car a) '(float var))
  1101. X      (and (memq (car a) '(+ - * neg))
  1102. X       (progn
  1103. X         (while (and (setq a (cdr a))
  1104. X             (math-tex-expr-is-flat (car a))))
  1105. X         (null a)))
  1106. X      (and (memq (car a) '(^ calcFunc-subscr))
  1107. X       (math-tex-expr-is-flat (nth 1 a))))
  1108. )
  1109. X
  1110. (put 'calcFunc-log 'math-compose-big 'math-compose-log)
  1111. (defun math-compose-log (a prec)
  1112. X  (and (= (length a) 3)
  1113. X       (list 'horiz
  1114. X         (list 'subscr "log"
  1115. X           (let ((calc-language 'flat))
  1116. X             (math-compose-expr (nth 2 a) 1000)))
  1117. X         "("
  1118. X         (math-compose-expr (nth 1 a) 1000)
  1119. X         ")"))
  1120. )
  1121. X
  1122. (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
  1123. (defun math-compose-log10 (a prec)
  1124. X  (and (= (length a) 2)
  1125. X       (list 'horiz
  1126. X         (list 'subscr "log" "10")
  1127. X         "("
  1128. X         (math-compose-expr (nth 1 a) 1000)
  1129. X         ")"))
  1130. )
  1131. X
  1132. (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
  1133. (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
  1134. (defun math-compose-deriv (a prec)
  1135. X  (and (= (length a) 3)
  1136. X       (math-compose-expr (list '/
  1137. X                (list 'calcFunc-choriz
  1138. X                      (list 'vec
  1139. X                        '(calcFunc-string (vec ?d))
  1140. X                        (nth 1 a)))
  1141. X                (list 'calcFunc-choriz
  1142. X                      (list 'vec
  1143. X                        '(calcFunc-string (vec ?d))
  1144. X                        (nth 2 a))))
  1145. X              prec))
  1146. )
  1147. X
  1148. (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
  1149. (defun math-compose-sqrt (a prec)
  1150. X  (and (= (length a) 2)
  1151. X       (let* ((c (math-compose-expr (nth 1 a) 0))
  1152. X          (a (math-comp-ascent c))
  1153. X          (d (math-comp-descent c))
  1154. X          (h (+ a d))
  1155. X          (w (math-comp-width c)))
  1156. X     (list 'vleft
  1157. X           a
  1158. X           (concat (if (= h 1) " " "  ")
  1159. X               (make-string (+ w 2) ?\_))
  1160. X           (list 'horiz
  1161. X             (if (= h 1)
  1162. X             "V"
  1163. X               (append (list 'vleft (1- a))
  1164. X                   (make-list (1- h) " |")
  1165. X                   '("\\|")))
  1166. X             " "
  1167. X             c))))
  1168. )
  1169. X
  1170. (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
  1171. (defun math-compose-choose (a prec)
  1172. X  (let ((a1 (math-compose-expr (nth 1 a) 0))
  1173. X    (a2 (math-compose-expr (nth 2 a) 0)))
  1174. X    (list 'horiz
  1175. X      "("
  1176. X      (list 'vcent
  1177. X        (math-comp-height a1)
  1178. X        a1 " " a2)
  1179. X      ")"))
  1180. )
  1181. X
  1182. (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
  1183. (defun math-compose-integ (a prec)
  1184. X  (and (memq (length a) '(3 5))
  1185. X       (eq (car-safe (nth 2 a)) 'var)
  1186. X       (let* ((parens (and (>= prec 196) (/= prec 1000)))
  1187. X          (var (math-compose-expr (nth 2 a) 0))
  1188. X          (over (and (eq (car-safe (nth 2 a)) 'var)
  1189. X             (or (and (eq (car-safe (nth 1 a)) '/)
  1190. X                  (math-numberp (nth 1 (nth 1 a))))
  1191. X                 (and (eq (car-safe (nth 1 a)) '^)
  1192. X                  (math-looks-negp (nth 2 (nth 1 a)))))))
  1193. X          (expr (math-compose-expr (if over
  1194. X                       (math-mul (nth 1 a)
  1195. X                             (math-build-var-name
  1196. X                              (format
  1197. X                               "d%s"
  1198. X                               (nth 1 (nth 2 a)))))
  1199. X                     (nth 1 a)) 185))
  1200. X          (calc-language 'flat)
  1201. X          (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
  1202. X          (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
  1203. X     (list 'horiz
  1204. X           (if parens "(" "")
  1205. X           (append (list 'vcent (if high 3 2))
  1206. X               (and high (list (list 'horiz "  " high)))
  1207. X               '("  /"
  1208. X             " | "
  1209. X             " | "
  1210. X             " | "
  1211. X             "/  ")
  1212. X               (and low (list (list 'horiz low "  "))))
  1213. X           expr
  1214. X           (if over
  1215. X           ""
  1216. X         (list 'horiz " d" var))
  1217. X           (if parens ")" ""))))
  1218. )
  1219. X
  1220. (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
  1221. (defun math-compose-sum (a prec)
  1222. X  (and (memq (length a) '(3 5 6))
  1223. X       (let* ((expr (math-compose-expr (nth 1 a) 185))
  1224. X          (calc-language 'flat)
  1225. X          (var (math-compose-expr (nth 2 a) 0))
  1226. X          (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
  1227. X          (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
  1228. X     (list 'horiz
  1229. X           (if (memq prec '(180 201)) "(" "")
  1230. X           (append (list 'vcent (if high 3 2))
  1231. X               (and high (list high))
  1232. X               '("---- "
  1233. X             "\\    "
  1234. X             " >   "
  1235. X             "/    "
  1236. X             "---- ")
  1237. X               (if low
  1238. X               (list (list 'horiz var " = " low))
  1239. X             (list var)))
  1240. X           (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
  1241. X           " " "")
  1242. X           expr
  1243. X           (if (memq prec '(180 201)) ")" ""))))
  1244. )
  1245. X
  1246. (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
  1247. (defun math-compose-prod (a prec)
  1248. X  (and (memq (length a) '(3 5 6))
  1249. X       (let* ((expr (math-compose-expr (nth 1 a) 198))
  1250. X          (calc-language 'flat)
  1251. X          (var (math-compose-expr (nth 2 a) 0))
  1252. X          (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
  1253. X          (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
  1254. X     (list 'horiz
  1255. X           (if (memq prec '(196 201)) "(" "")
  1256. X           (append (list 'vcent (if high 3 2))
  1257. X               (and high (list high))
  1258. X               '("----- "
  1259. X             " | |  "
  1260. X             " | |  "
  1261. X             " | |  ")
  1262. X               (if low
  1263. X               (list (list 'horiz var " = " low))
  1264. X             (list var)))
  1265. X           (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
  1266. X           " " "")
  1267. X           expr
  1268. X           (if (memq prec '(196 201)) ")" ""))))
  1269. )
  1270. X
  1271. X
  1272. (defun math-stack-value-offset-fancy ()
  1273. X  (let ((cwid (+ (math-comp-width c))))
  1274. X    (cond ((eq calc-display-just 'right)
  1275. X       (if calc-display-origin
  1276. X           (setq wid (max calc-display-origin 5))
  1277. X         (if (integerp calc-line-breaking)
  1278. X         (setq wid calc-line-breaking)))
  1279. X       (setq off (- wid cwid
  1280. X            (max (- (length calc-right-label)
  1281. X                (if (and (integerp calc-line-breaking)
  1282. X                     calc-display-origin)
  1283. X                    (max (- calc-line-breaking
  1284. X                        calc-display-origin)
  1285. X                     0)
  1286. X                  0))
  1287. X                 0))))
  1288. X      (t
  1289. X       (if calc-display-origin
  1290. X           (progn
  1291. X         (setq off (- calc-display-origin (/ cwid 2)))
  1292. X         (if (integerp calc-line-breaking)
  1293. X             (setq off (min off (- calc-line-breaking cwid
  1294. X                       (length calc-right-label)))))
  1295. X         (if (>= off 0)
  1296. X             (setq wid (max wid (+ off cwid)))))
  1297. X         (if (integerp calc-line-breaking)
  1298. X         (setq wid calc-line-breaking))
  1299. X         (setq off (/ (- wid cwid) 2)))))
  1300. X    (and (integerp calc-line-breaking)
  1301. X     (or (< off 0)
  1302. X         (and calc-display-origin
  1303. X          (> calc-line-breaking calc-display-origin)))
  1304. X     (setq wid calc-line-breaking)))
  1305. )
  1306. X
  1307. X
  1308. X
  1309. ;;; Convert a composition to string form, with embedded \n's if necessary.
  1310. X
  1311. (defun math-composition-to-string (c &optional width)
  1312. X  (or width (setq width (calc-window-width)))
  1313. X  (if calc-display-raw
  1314. X      (math-comp-to-string-raw c 0)
  1315. X    (if (math-comp-is-flat c)
  1316. X    (math-comp-to-string-flat c width)
  1317. X      (math-vert-comp-to-string
  1318. X       (math-comp-simplify c width))))
  1319. )
  1320. X
  1321. (defun math-comp-is-flat (c)     ; check if c's height is 1.
  1322. X  (cond ((not (consp c)) t)
  1323. X    ((memq (car c) '(set break)) t)
  1324. X    ((eq (car c) 'horiz)
  1325. X     (while (and (setq c (cdr c))
  1326. X             (math-comp-is-flat (car c))))
  1327. X     (null c))
  1328. X    ((memq (car c) '(vleft vcent vright))
  1329. X     (and (= (length c) 3)
  1330. X          (= (nth 1 c) 0)
  1331. X          (math-comp-is-flat (nth 2 c))))
  1332. X    ((eq (car c) 'tag)
  1333. X     (math-comp-is-flat (nth 2 c)))
  1334. X    (t nil))
  1335. )
  1336. X
  1337. X
  1338. ;;; Convert a one-line composition to a string.  Break into multiple
  1339. ;;; lines if necessary, choosing break points according to the structure
  1340. ;;; of the formula.
  1341. X
  1342. (defun math-comp-to-string-flat (c full-width)
  1343. X  (if math-comp-sel-hpos
  1344. X      (let ((comp-pos 0))
  1345. X    (math-comp-sel-flat-term c))
  1346. X    (let ((comp-buf "")
  1347. X      (comp-word "")
  1348. X      (comp-pos 0)
  1349. X      (comp-margin 0)
  1350. X      (comp-highlight (and math-comp-selected calc-show-selections))
  1351. X      (comp-level -1))
  1352. X      (math-comp-to-string-flat-term '(set -1 0))
  1353. X      (math-comp-to-string-flat-term c)
  1354. X      (math-comp-to-string-flat-term '(break -1))
  1355. X      (let ((str (aref math-comp-buf-string 0))
  1356. X        (prefix ""))
  1357. X    (and (> (length str) 0) (= (aref str 0) ? )
  1358. X         (> (length comp-buf) 0)
  1359. X         (let ((k (length comp-buf)))
  1360. X           (while (not (= (aref comp-buf (setq k (1- k))) ?\n)))
  1361. X           (aset comp-buf k ? )
  1362. X           (if (and (< (1+ k) (length comp-buf))
  1363. X            (= (aref comp-buf (1+ k)) ? ))
  1364. X           (progn
  1365. X             (aset comp-buf (1+ k) ?\n)
  1366. X             (setq prefix " "))
  1367. X         (setq prefix "\n"))))
  1368. X    (concat comp-buf prefix str))))
  1369. )
  1370. (setq math-comp-buf-string (make-vector 10 ""))
  1371. (setq math-comp-buf-margin (make-vector 10 0))
  1372. (setq math-comp-buf-level (make-vector 10 0))
  1373. X
  1374. (defun math-comp-to-string-flat-term (c)
  1375. X  (cond ((not (consp c))
  1376. X     (if comp-highlight
  1377. X         (setq c (math-comp-highlight-string c)))
  1378. X     (setq comp-word (if (= (length comp-word) 0) c (concat comp-word c))
  1379. X           comp-pos (+ comp-pos (length c))))
  1380. X
  1381. X    ((eq (car c) 'horiz)
  1382. X     (while (setq c (cdr c))
  1383. X       (math-comp-to-string-flat-term (car c))))
  1384. X
  1385. X    ((eq (car c) 'set)
  1386. X     (if (nth 1 c)
  1387. X         (progn
  1388. X           (setq comp-level (1+ comp-level))
  1389. X           (if (>= comp-level (length math-comp-buf-string))
  1390. X           (setq math-comp-buf-string (vconcat math-comp-buf-string
  1391. X                               math-comp-buf-string)
  1392. X             math-comp-buf-margin (vconcat math-comp-buf-margin
  1393. X                               math-comp-buf-margin)
  1394. X             math-comp-buf-level (vconcat math-comp-buf-level
  1395. X                              math-comp-buf-level)))
  1396. X           (aset math-comp-buf-string comp-level "")
  1397. X           (aset math-comp-buf-margin comp-level (+ comp-pos
  1398. X                            (or (nth 2 c) 0)))
  1399. X           (aset math-comp-buf-level comp-level (nth 1 c)))))
  1400. X
  1401. X    ((eq (car c) 'break)
  1402. X     (if (not calc-line-breaking)
  1403. X         (setq comp-buf (concat comp-buf comp-word)
  1404. X           comp-word "")
  1405. X       (let ((i 0) str)
  1406. X         (if (and (> comp-pos full-width)
  1407. X              (progn
  1408. X            (while (progn
  1409. X                 (setq str (aref math-comp-buf-string i))
  1410. X                 (and (= (length str) 0) (< i comp-level)))
  1411. X              (setq i (1+ i)))
  1412. X            (or (> (length str) 0) (> (length comp-buf) 0))))
  1413. X         (let ((prefix "") mrg wid)
  1414. X           (setq mrg (aref math-comp-buf-margin i))
  1415. X           (if (> mrg 12)  ; indenting too far, go back to far left
  1416. X               (let ((j i) (new (if calc-line-numbering 5 1)))
  1417. X             (while (<= j comp-level)
  1418. X               (aset math-comp-buf-margin j
  1419. X                 (+ (aref math-comp-buf-margin j) (- new mrg)))
  1420. X               (setq j (1+ j)))
  1421. X             (setq mrg new)))
  1422. X           (setq wid (+ (length str) comp-margin))
  1423. X           (and (> (length str) 0) (= (aref str 0) ? )
  1424. X            (> (length comp-buf) 0)
  1425. X            (let ((k (length comp-buf)))
  1426. X              (while (not (= (aref comp-buf (setq k (1- k))) ?\n)))
  1427. X              (aset comp-buf k ? )
  1428. X              (if (and (< (1+ k) (length comp-buf))
  1429. X                   (= (aref comp-buf (1+ k)) ? ))
  1430. X                  (progn
  1431. X                (aset comp-buf (1+ k) ?\n)
  1432. X                (setq prefix " "))
  1433. X                (setq prefix "\n"))))
  1434. X           (setq comp-buf (concat comp-buf prefix str "\n"
  1435. X                      (make-string mrg ? ))
  1436. X             comp-pos (+ comp-pos (- mrg wid))
  1437. X             comp-margin mrg)
  1438. X           (aset math-comp-buf-string i "")
  1439. X           (while (<= (setq i (1+ i)) comp-level)
  1440. X             (if (> (aref math-comp-buf-margin i) wid)
  1441. X             (aset math-comp-buf-margin i
  1442. X                   (+ (aref math-comp-buf-margin i)
  1443. X                  (- mrg wid))))))))
  1444. X       (if (and (= (nth 1 c) (aref math-comp-buf-level comp-level))
  1445. X            (< comp-pos (+ (aref math-comp-buf-margin comp-level) 2)))
  1446. X           ()  ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
  1447. X         (let ((str (aref math-comp-buf-string comp-level)))
  1448. X           (setq str (if (= (length str) 0)
  1449. X                 comp-word
  1450. X               (concat str comp-word))
  1451. X             comp-word "")
  1452. X           (while (< (nth 1 c) (aref math-comp-buf-level comp-level))
  1453. X         (setq comp-level (1- comp-level))
  1454. X         (or (= (length (aref math-comp-buf-string comp-level)) 0)
  1455. X             (setq str (concat (aref math-comp-buf-string comp-level)
  1456. X                       str))))
  1457. X           (aset math-comp-buf-string comp-level str)))))
  1458. X
  1459. X    ((eq (car c) 'tag)
  1460. X     (cond ((eq (nth 1 c) math-comp-selected)
  1461. X        (let ((comp-highlight (not calc-show-selections)))
  1462. X          (math-comp-to-string-flat-term (nth 2 c))))
  1463. X           ((eq (nth 1 c) t)
  1464. X        (let ((comp-highlight nil))
  1465. X          (math-comp-to-string-flat-term (nth 2 c))))
  1466. X           (t (math-comp-to-string-flat-term (nth 2 c)))))
  1467. X
  1468. X    (t (math-comp-to-string-flat-term (nth 2 c))))
  1469. )
  1470. X
  1471. (defun math-comp-highlight-string (s)
  1472. X  (setq s (copy-sequence s))
  1473. X  (let ((i (length s)))
  1474. X    (while (>= (setq i (1- i)) 0)
  1475. X      (or (memq (aref s i) '(32 ?\n))
  1476. X      (aset s i (if calc-show-selections ?\. ?\#)))))
  1477. X  s
  1478. )
  1479. X
  1480. (defun math-comp-sel-flat-term (c)
  1481. X  (cond ((not (consp c))
  1482. X     (setq comp-pos (+ comp-pos (length c))))
  1483. X    ((memq (car c) '(set break)))
  1484. X    ((eq (car c) 'horiz)
  1485. X     (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
  1486. X       (math-comp-sel-flat-term (car c))))
  1487. X    ((eq (car c) 'tag)
  1488. X     (if (<= comp-pos math-comp-sel-cpos)
  1489. X         (progn
  1490. X           (math-comp-sel-flat-term (nth 2 c))
  1491. X           (if (> comp-pos math-comp-sel-cpos)
  1492. X           (setq math-comp-sel-tag c
  1493. X             math-comp-sel-cpos 1000000)))
  1494. X       (math-comp-sel-flat-term (nth 2 c))))
  1495. X    (t (math-comp-sel-flat-term (nth 2 c))))
  1496. )
  1497. X
  1498. X
  1499. ;;; Simplify a composition to a canonical form consisting of
  1500. ;;;   (vleft n "string" "string" "string" ...)
  1501. ;;; where 0 <= n < number-of-strings.
  1502. X
  1503. (defun math-comp-simplify (c full-width)
  1504. X  (let ((comp-buf (list ""))
  1505. X    (comp-base 0)
  1506. X    (comp-height 1)
  1507. X    (comp-hpos 0)
  1508. X    (comp-vpos 0)
  1509. X    (comp-highlight (and math-comp-selected calc-show-selections))
  1510. X    (comp-tag nil))
  1511. X    (math-comp-simplify-term c)
  1512. X    (cons 'vleft (cons comp-base comp-buf)))
  1513. )
  1514. X
  1515. (defun math-comp-add-string (s h v)
  1516. X  (and (> (length s) 0)
  1517. X       (let ((vv (+ v comp-base)))
  1518. X     (if math-comp-sel-hpos
  1519. X         (math-comp-add-string-sel h vv (length s) 1)
  1520. X       (if (< vv 0)
  1521. X           (setq comp-buf (nconc (make-list (- vv) "") comp-buf)
  1522. X             comp-base (- v)
  1523. X             comp-height (- comp-height vv)
  1524. X             vv 0)
  1525. X         (if (>= vv comp-height)
  1526. X         (setq comp-buf (nconc comp-buf
  1527. X                       (make-list (1+ (- vv comp-height)) ""))
  1528. X               comp-height (1+ vv))))
  1529. X       (let ((str (nthcdr vv comp-buf)))
  1530. X         (setcar str (concat (car str)
  1531. X                 (make-string (- h (length (car str))) 32)
  1532. X                 (if comp-highlight
  1533. X                     (math-comp-highlight-string s)
  1534. X                   s)))))))
  1535. )
  1536. X
  1537. (defun math-comp-add-string-sel (x y w h)
  1538. X  (if (and (<= y math-comp-sel-vpos)
  1539. X       (> (+ y h) math-comp-sel-vpos)
  1540. X       (<= x math-comp-sel-hpos)
  1541. X       (> (+ x w) math-comp-sel-hpos))
  1542. X      (setq math-comp-sel-tag comp-tag
  1543. X        math-comp-sel-vpos 10000))
  1544. )
  1545. X
  1546. (defun math-comp-simplify-term (c)
  1547. X  (cond ((stringp c)
  1548. X     (math-comp-add-string c comp-hpos comp-vpos)
  1549. X     (setq comp-hpos (+ comp-hpos (length c))))
  1550. X    ((memq (car c) '(set break))
  1551. X     nil)
  1552. X    ((eq (car c) 'horiz)
  1553. X     (while (setq c (cdr c))
  1554. X       (math-comp-simplify-term (car c))))
  1555. X    ((memq (car c) '(vleft vcent vright))
  1556. X     (let* ((comp-vpos (+ (- comp-vpos (nth 1 c))
  1557. X                  (1- (math-comp-ascent (nth 2 c)))))
  1558. X        (widths (mapcar 'math-comp-width (cdr (cdr c))))
  1559. X        (maxwid (apply 'max widths))
  1560. X        (bias (cond ((eq (car c) 'vleft) 0)
  1561. X                ((eq (car c) 'vcent) 1)
  1562. X                (t 2))))
  1563. X       (setq c (cdr c))
  1564. X       (while (setq c (cdr c))
  1565. X         (if (eq (car-safe (car c)) 'rule)
  1566. X         (math-comp-add-string (make-string maxwid (nth 1 (car c)))
  1567. X                       comp-hpos comp-vpos)
  1568. X           (let ((comp-hpos (+ comp-hpos (/ (* bias (- maxwid
  1569. X                               (car widths)))
  1570. X                        2))))
  1571. X         (math-comp-simplify-term (car c))))
  1572. X         (and (cdr c)
  1573. X          (setq comp-vpos (+ comp-vpos
  1574. X                     (+ (math-comp-descent (car c))
  1575. X                    (math-comp-ascent (nth 1 c))))
  1576. X            widths (cdr widths))))
  1577. X       (setq comp-hpos (+ comp-hpos maxwid))))
  1578. X    ((eq (car c) 'supscr)
  1579. X     (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
  1580. X        (desc (math-comp-descent (nth 2 c)))
  1581. X        (oldh (prog1
  1582. X              comp-hpos
  1583. X            (math-comp-simplify-term (nth 1 c))))
  1584. X        (comp-vpos (- comp-vpos (+ asc desc))))
  1585. X       (math-comp-simplify-term (nth 2 c))
  1586. X       (if math-comp-sel-hpos
  1587. X           (math-comp-add-string-sel oldh
  1588. X                     (- comp-vpos
  1589. X                        -1
  1590. X                        (math-comp-ascent (nth 2 c)))
  1591. X                     (- comp-hpos oldh)
  1592. X                     (math-comp-height c)))))
  1593. X    ((eq (car c) 'subscr)
  1594. X     (let* ((asc (math-comp-ascent (nth 2 c)))
  1595. X        (desc (math-comp-descent (nth 1 c)))
  1596. X        (oldv comp-vpos)
  1597. X        (oldh (prog1
  1598. X              comp-hpos
  1599. X            (math-comp-simplify-term (nth 1 c))))
  1600. X        (comp-vpos (+ comp-vpos (+ asc desc))))
  1601. X       (math-comp-simplify-term (nth 2 c))
  1602. X       (if math-comp-sel-hpos
  1603. X           (math-comp-add-string-sel oldh oldv
  1604. X                     (- comp-hpos oldh)
  1605. X                     (math-comp-height c)))))
  1606. X    ((eq (car c) 'tag)
  1607. X     (cond ((eq (nth 1 c) math-comp-selected)
  1608. X        (let ((comp-highlight (not calc-show-selections)))
  1609. X          (math-comp-simplify-term (nth 2 c))))
  1610. X           ((eq (nth 1 c) t)
  1611. X        (let ((comp-highlight nil))
  1612. X          (math-comp-simplify-term (nth 2 c))))
  1613. X           (t (let ((comp-tag c))
  1614. X            (math-comp-simplify-term (nth 2 c)))))))
  1615. )
  1616. X
  1617. X
  1618. ;;; Measuring a composition.
  1619. X
  1620. (defun math-comp-first-char (c)
  1621. X  (cond ((stringp c)
  1622. X     (and (> (length c) 0)
  1623. X          (elt c 0)))
  1624. X    ((memq (car c) '(horiz subscr supscr))
  1625. X     (while (and (setq c (cdr c))
  1626. X             (math-comp-is-null (car c))))
  1627. X     (and c (math-comp-first-char (car c))))
  1628. X    ((eq (car c) 'tag)
  1629. X     (math-comp-first-char (nth 2 c))))
  1630. )
  1631. X
  1632. (defun math-comp-first-string (c)
  1633. X  (cond ((stringp c)
  1634. X     (and (> (length c) 0)
  1635. X          c))
  1636. X    ((eq (car c) 'horiz)
  1637. X     (while (and (setq c (cdr c))
  1638. X             (math-comp-is-null (car c))))
  1639. X     (and c (math-comp-first-string (car c))))
  1640. X    ((eq (car c) 'tag)
  1641. X     (math-comp-first-string (nth 2 c))))
  1642. )
  1643. X
  1644. (defun math-comp-last-char (c)
  1645. X  (cond ((stringp c)
  1646. X     (and (> (length c) 0)
  1647. X          (elt c (1- (length c)))))
  1648. X    ((eq (car c) 'horiz)
  1649. X     (let ((c (reverse (cdr c))))
  1650. X       (while (and c (math-comp-is-null (car c)))
  1651. X         (setq c (cdr c)))
  1652. X       (and c (math-comp-last-char (car c)))))
  1653. X    ((eq (car c) 'tag)
  1654. X     (math-comp-last-char (nth 2 c))))
  1655. )
  1656. X
  1657. (defun math-comp-is-null (c)
  1658. X  (cond ((stringp c) (= (length c) 0))
  1659. X    ((memq (car c) '(horiz subscr supscr))
  1660. X     (while (and (setq c (cdr c))
  1661. X             (math-comp-is-null (car c))))
  1662. X     (null c))
  1663. X    ((eq (car c) 'tag)
  1664. X     (math-comp-is-null (nth 2 c)))
  1665. X    ((memq (car c) '(set break)) t))
  1666. )
  1667. X
  1668. (defun math-comp-width (c)
  1669. X  (cond ((not (consp c)) (length c))
  1670. X    ((memq (car c) '(horiz subscr supscr))
  1671. X     (let ((accum 0))
  1672. X       (while (setq c (cdr c))
  1673. X         (setq accum (+ accum (math-comp-width (car c)))))
  1674. X       accum))
  1675. X    ((memq (car c) '(vcent vleft vright))
  1676. X     (setq c (cdr c))
  1677. X     (let ((accum 0))
  1678. X       (while (setq c (cdr c))
  1679. X         (setq accum (max accum (math-comp-width (car c)))))
  1680. X       accum))
  1681. X    ((eq (car c) 'tag)
  1682. X     (math-comp-width (nth 2 c)))
  1683. X    (t 0))
  1684. )
  1685. X
  1686. (defun math-comp-height (c)
  1687. X  (if (stringp c)
  1688. X      1
  1689. X    (+ (math-comp-ascent c) (math-comp-descent c)))
  1690. )
  1691. X
  1692. (defun math-comp-ascent (c)
  1693. X  (cond ((not (consp c)) 1)
  1694. X    ((eq (car c) 'horiz)
  1695. X     (let ((accum 0))
  1696. X       (while (setq c (cdr c))
  1697. X         (setq accum (max accum (math-comp-ascent (car c)))))
  1698. X       accum))
  1699. X    ((memq (car c) '(vcent vleft vright))
  1700. X     (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
  1701. X    ((eq (car c) 'supscr)
  1702. X     (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
  1703. X    ((eq (car c) 'subscr)
  1704. X     (math-comp-ascent (nth 1 c)))
  1705. X    ((eq (car c) 'tag)
  1706. X     (math-comp-ascent (nth 2 c)))
  1707. X    (t 1))
  1708. )
  1709. X
  1710. (defun math-comp-descent (c)
  1711. X  (cond ((not (consp c)) 0)
  1712. X    ((eq (car c) 'horiz)
  1713. X     (let ((accum 0))
  1714. X       (while (setq c (cdr c))
  1715. SHAR_EOF
  1716. true || echo 'restore of calc-comp.el failed'
  1717. fi
  1718. echo 'End of  part 11'
  1719. echo 'File calc-comp.el is continued in part 12'
  1720. echo 12 > _shar_seq_.tmp
  1721. exit 0
  1722. exit 0 # Just in case...
  1723. -- 
  1724. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1725. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1726. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1727. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1728.