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