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