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