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