1 ;;; calccomp.el --- composition functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <belanger@truman.edu>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY. No author or distributor
13 ;; accepts responsibility to anyone for the consequences of using it
14 ;; or for whether it serves any particular purpose or works at all,
15 ;; unless he says so in writing. Refer to the GNU Emacs General Public
16 ;; License for full details.
18 ;; Everyone is granted permission to copy, modify and redistribute
19 ;; GNU Emacs, but only under the conditions described in the
20 ;; GNU Emacs General Public License. A copy of this license is
21 ;; supposed to have been given to you along with GNU Emacs so you
22 ;; can know your rights and responsibilities. It should be in a
23 ;; file named COPYING. Among other things, the copyright notice
24 ;; and this notice must be preserved on all copies.
30 ;; This file is autoloaded from calc-ext.el.
35 (defconst math-eqn-special-funcs
37 calcFunc-ln calcFunc-exp
38 calcFunc-sin calcFunc-cos calcFunc-tan
39 calcFunc-sec calcFunc-csc calcFunc-cot
40 calcFunc-sinh calcFunc-cosh calcFunc-tanh
41 calcFunc-sech calcFunc-csch calcFunc-coth
42 calcFunc-arcsin calcFunc-arccos calcFunc-arctan
43 calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
))
45 ;;; A "composition" has one of the following forms:
47 ;;; "string" A literal string
49 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
51 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
52 ;;; (break LEVEL) A potential line-break point
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.
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
63 ;;; (tag X C) Composition C corresponds to sub-expression X
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
)
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
74 (defvar math-comp-vector-prec
)
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
)
84 (defun math-compose-expr (a prec
)
85 (let ((math-compose-level (1+ math-compose-level
))
88 ((or (and (eq a math-comp-selected
) a
)
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
)))
96 ((setq spfn
(assq (car-safe a
) math-expr-special-function-mapping
))
97 (setq spfn
(cdr spfn
))
98 (funcall (car spfn
) a spfn
))
100 (if (or (eq (car-safe a
) 'frac
)
101 (and (nth 1 calc-frac-format
) (Math-integerp a
)))
102 (if (memq calc-language
'(tex latex eqn math maple c fortran pascal
))
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
))
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
)
116 (if (math-negp (nth 1 aa
))
120 (math-abs (nth 1 aa
)))
122 (math-format-number (nth 2 aa
))))))
123 (if (= calc-number-radix
10)
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
)
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)
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
))
145 (while (string-match (if (> calc-number-radix
14)
146 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
147 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
149 (setq c
(nconc c
(list (substring s
0 (match-beginning 0))
151 (math-match-substring s
2)
152 (math-match-substring s
1))))
153 s
(substring s
(match-end 0))))
155 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s
)
157 (substring s
0 (match-beginning 0)) " "
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
))
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
))))))))
180 (let* ((math-comp-left-bracket (if calc-vector-brackets
181 (substring calc-vector-brackets
0 1) ""))
182 (math-comp-right-bracket (if calc-vector-brackets
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
))
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
190 (math-vector-no-parens a
))
191 (memq 'P calc-matrix-brackets
)) 0 1000))
192 (math-comp-just (cond ((eq calc-matrix-just
'right
) 'vright
)
193 ((eq calc-matrix-just
'center
) 'vcent
)
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
)))
203 (setq math-comp-vector-prec
(if (or (and calc-vector-commas
204 (math-vector-no-parens
206 (memq 'P calc-matrix-brackets
))
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
))
214 (let* ((rows (1- (length a
)))
215 (cols (1- (length (nth 1 a
))))
216 (base (/ (1- rows
) 2))
217 (calc-language 'flat
))
219 (list (append '(vleft)
221 (list (concat (and outer-brackets
222 (concat math-comp-left-bracket
225 (concat math-comp-left-bracket
228 (concat (and outer-brackets
232 math-comp-left-bracket
234 (math-compose-matrix (cdr a
) 1 cols base
)
235 (list (append '(vleft)
240 math-comp-right-bracket
243 (if (and outer-brackets
249 math-comp-right-bracket
))
253 math-comp-right-bracket
)))))))))
254 (if (and calc-display-strings
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))
263 (calc-break-vectors nil
))
265 (cons 'vleft
(cons base
268 (if full rows
3) t
)))))
269 (if (or calc-full-vectors
(< (length a
) 7))
270 (if (and (eq calc-language
'tex
)
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
))
279 (append '(horiz "\\matrix{ ")
280 (math-compose-tex-matrix (cdr a
))
282 (if (and (eq calc-language
'latex
)
284 (if (and (integerp calc-language-option
)
285 (or (= calc-language-option
0)
286 (> calc-language-option
1)
287 (< calc-language-option -
1)))
288 (append '(vleft 0 "\\begin{pmatrix}")
289 (math-compose-tex-matrix (cdr a
))
291 (append '(horiz "\\begin{pmatrix} ")
292 (math-compose-tex-matrix (cdr a
))
293 '(" \\end{pmatrix}")))
294 (if (and (eq calc-language
'eqn
)
296 (append '(horiz "matrix { ")
297 (math-compose-eqn-matrix
298 (cdr (math-transpose a
)))
300 (if (and (eq calc-language
'maple
)
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
311 math-comp-left-bracket
312 (math-compose-vector (cdr a
)
313 (concat math-comp-comma
" ")
314 math-comp-vector-prec
)
315 math-comp-right-bracket
)))))
317 math-comp-left-bracket
318 (math-compose-vector (list (nth 1 a
) (nth 2 a
) (nth 3 a
))
319 (concat math-comp-comma
" ")
320 math-comp-vector-prec
)
321 math-comp-comma
(if (memq calc-language
'(tex latex
))
324 (list 'break math-compose-level
)
325 (math-compose-expr (nth (1- (length a
)) a
)
326 (if (equal math-comp-comma
"") 1000 0))
327 math-comp-right-bracket
)))))))
328 ((eq (car a
) 'incomplete
)
330 (cond ((eq (nth 1 a
) 'vec
)
332 (math-compose-vector (cdr (cdr a
)) ", " 0)
334 ((eq (nth 1 a
) 'cplx
)
336 (math-compose-vector (cdr (cdr a
)) ", " 0)
338 ((eq (nth 1 a
) 'polar
)
340 (math-compose-vector (cdr (cdr a
)) "; " 0)
342 ((eq (nth 1 a
) 'intv
)
344 (if (memq (nth 2 a
) '(0 1)) "(" "[")
345 (math-compose-vector (cdr (cdr (cdr a
))) " .. " 0)
348 (cond ((eq (nth 1 a
) 'vec
) "[ ...")
349 ((eq (nth 1 a
) 'intv
)
350 (if (memq (nth 2 a
) '(0 1)) "( ..." "[ ..."))
353 (let ((v (rassq (nth 2 a
) math-expr-variable-mapping
)))
355 (symbol-name (car v
))
356 (if (and (memq calc-language
'(tex latex
))
358 (not (= calc-language-option
0))
359 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
360 (symbol-name (nth 1 a
))))
361 (if (eq calc-language
'latex
)
362 (format "\\text{%s}" (symbol-name (nth 1 a
)))
363 (format "\\hbox{%s}" (symbol-name (nth 1 a
))))
364 (if (and math-compose-hash-args
365 (let ((p calc-arg-values
))
367 (while (and p
(not (equal (car p
) a
)))
368 (setq p
(and (eq math-compose-hash-args t
) (cdr p
))
371 (if (eq math-compose-hash-args
1)
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
))))
379 (list 'calcFunc-Prime
382 (intern (substring (symbol-name (nth 1 a
)) 0 -
1))
383 (intern (substring (symbol-name (nth 2 a
)) 0 -
1))))
385 (symbol-name (nth 1 a
)))))))))
388 (if (eq calc-language
'maple
) ""
389 (if (memq (nth 1 a
) '(0 1)) "(" "["))
390 (math-compose-expr (nth 2 a
) 0)
391 (if (memq calc-language
'(tex latex
)) " \\ldots "
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)) ")" "]"))))
397 (if (eq (car calc-date-format
) 'X
)
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
)
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
))))
427 (list 'subscr a1 a2
))))
428 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
429 (eq calc-language
'math
))
431 (math-compose-expr (nth 1 a
) 1000)
433 (math-compose-expr (nth 2 a
) 0)
435 ((and (eq (car a
) 'calcFunc-sqrt
)
436 (memq calc-language
'(tex latex
)))
439 (math-compose-expr (nth 1 a
) 0)
441 ((and nil
(eq (car a
) 'calcFunc-sqrt
)
442 (eq calc-language
'eqn
))
445 (math-compose-expr (nth 1 a
) -
1)
447 ((and (eq (car a
) '^
)
448 (eq calc-language
'big
))
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
))
464 (math-compose-expr (nth 1 a
) 0)))
465 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a
)) '(/ frac
))
467 (math-compose-expr (nth 2 a
) 0))))
469 (math-comp-height a1
)
471 ((and (memq (car a
) '(calcFunc-sum calcFunc-prod
))
472 (memq calc-language
'(tex latex
))
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
)
481 (memq calc-language
'(nil flat big
)))
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
)))
489 (list (math-compose-vector
490 (nreverse (cdr (reverse (cdr a
)))) ", " 0)
493 (list (math-compose-expr (nth (1- (length a
)) a
) 0)
495 ((and (eq (car a
) 'calcFunc-string
)
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
)
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
) ")")
509 (s (math-vector-to-string (nth 1 a
) nil
))
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
)
517 (setq c
(nreverse (cons s c
)))
519 (setq c
(cons (list 'set math-compose-level
2) c
)))
521 ((and (eq (car a
) 'calcFunc-cprec
)
522 (not (eq calc-language
'unform
))
524 (integerp (nth 2 a
)))
525 (let ((c (math-compose-expr (nth 1 a
) -
1)))
526 (if (> prec
(nth 2 a
))
527 (if (memq calc-language
'(tex latex
))
528 (list 'horiz
"\\left( " c
" \\right)")
529 (if (eq calc-language
'eqn
)
530 (list 'horiz
"{left ( " c
" right )}")
531 (list 'horiz
"(" 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
))
539 (and (math-vectorp (nth 3 a
))
540 (math-vector-is-string (nth 3 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
))
548 (math-compose-vector (cdr (nth 1 a
))
549 (math-vector-to-string sep nil
)
551 (cons 'horiz
(mapcar (function
553 (if (eq (car-safe x
) 'calcFunc-bstring
)
556 x
(or bprec cprec prec
))
558 (math-compose-expr x
(or cprec prec
)))))
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
))
565 (integerp (nth 2 a
))))
568 (prec (or (nth 2 a
) prec
))
571 (let ((b nil
) (cc nil
) a d
)
572 (if (and (memq (car-safe x
) '(calcFunc-cbase
575 (memq (length x
) '(1 2)))
578 (if (and (eq (car-safe x
) 'calcFunc-crule
)
579 (memq (length x
) '(1 2))
581 (and (math-vectorp (nth 1 x
))
582 (= (length (nth 1 x
)) 2)
583 (math-vector-is-string
585 (and (natnump (nth 1 x
))
586 (<= (nth 1 x
) 255))))
589 (if (math-vectorp (nth 1 x
))
590 (aref (math-vector-to-string
593 (or (and (memq (car-safe x
) '(calcFunc-cvspace
596 (memq (length x
) '(2 3))
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
)
606 (if (eq b
'calcFunc-cbbase
)
607 (setq base
(+ v a d -
1)))))
611 (setq c
(delq nil c
))
613 (cons (if (eq (car a
) 'calcFunc-cvert
) 'vcent
614 (if (eq (car a
) 'calcFunc-clvert
) 'vleft
'vright
))
617 ((and (memq (car a
) '(calcFunc-csup calcFunc-csub
))
618 (not (eq calc-language
'unform
))
619 (memq (length a
) '(3 4))
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))
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))
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))
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))
654 (ca (math-comp-ascent c
))
655 (cd (math-comp-descent c
)))
657 (cons (if (eq (car a
) 'calcFunc-ctspace
)
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
)
665 (memq calc-language
'(tex latex eqn
))
666 (= math-compose-level
(if math-comp-tagged
2 1))
669 (if (memq calc-language
'(tex latex
)) "\\evalto " "evalto ")
670 (math-compose-expr (nth 1 a
) 0)
671 (if (memq calc-language
'(tex latex
)) " \\to " " -> ")
672 (math-compose-expr (nth 2 a
) 0)))
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
)))))
679 (or (= (length a
) 3) (eq (car a
) 'calcFunc-if
))
682 ((> prec
(or (nth 4 op
) (min (nth 2 op
) (nth 3 op
))))
683 (if (and (memq calc-language
'(tex latex
))
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)
690 (if (eq calc-language
'eqn
)
691 (if (or (eq (car-safe a
) '/)
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)
699 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
700 ((and (memq calc-language
'(tex latex
))
701 (memq (car a
) '(/ calcFunc-choose calcFunc-evalto
))
703 (list 'horiz
"{" (math-compose-expr a -
1) "}"))
704 ((eq (car a
) 'calcFunc-if
)
706 (math-compose-expr (nth 1 a
) (nth 2 op
))
708 (math-compose-expr (nth 2 a
) 0)
710 (math-compose-expr (nth 3 a
) (nth 3 op
))))
712 (let* ((math-comp-tagged (and math-comp-tagged
715 (setlev (if (= prec
(min (nth 2 op
) (nth 3 op
)))
717 (setq math-compose-level
718 (1- 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
")")))
726 (and (memq calc-language
'(tex latex
))
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
)
740 (eq calc-language
'big
)
742 (nextc (or (math-comp-first-char rhs
)
743 (and (memq (car-safe nextt
)
748 (eq calc-language
'big
)
751 (or (and (>= nextc ?a
) (<= nextc ?z
))
752 (and (>= nextc ?A
) (<= nextc ?Z
))
753 (and (>= nextc ?
0) (<= nextc ?
9))
754 (memq nextc
'(?. ?_ ?
#
759 (math-comp-first-string
761 (not (and (eq (car-safe prevt
) 'var
)
766 (list 'break math-compose-level
)
772 (list 'break math-compose-level
)
773 (if (or (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
))))
783 (if (and (eq calc-language
'big
)
784 (equal (car op
) "=>"))
786 (concat " " (car op
) " ")))
788 ((and op
(= (length a
) 2) (= (nth 3 op
) -
1))
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
793 (if (and (memq calc-language
'(tex latex
))
794 (not (math-tex-expr-is-flat a
)))
795 (list 'horiz
"\\left( "
796 (math-compose-expr a -
1)
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)
806 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
808 (let ((lhs (math-compose-expr (nth 1 a
) (nth 2 op
))))
811 (if (or (> (length (car op
)) 1)
812 (not (math-comp-is-flat lhs
)))
813 (concat " " (car op
))
815 ((and op
(= (length a
) 2) (= (nth 2 op
) -
1))
818 (let ((lr (and (memq calc-language
'(tex latex
))
819 (not (math-tex-expr-is-flat (nth 1 a
))))))
822 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op
))
823 (substring (car op
) 1)
825 (if (or lr
(> (length (car op
)) 2)) " " "")
826 (math-compose-expr (nth 1 a
) -
1)
827 (if (or lr
(> (length (car op
)) 2)) " " "")
829 (car (nth 1 (memq op math-expr-opers
))))))
830 ((> prec
(or (nth 4 op
) (nth 3 op
)))
831 (if (and (memq calc-language
'(tex latex
))
832 (not (math-tex-expr-is-flat a
)))
833 (list 'horiz
"\\left( "
834 (math-compose-expr a -
1)
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)
844 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
846 (let ((rhs (math-compose-expr (nth 1 a
) (nth 3 op
))))
848 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
850 (substring (car op
) 1)
852 (if (or (> (length ops
) 1)
853 (not (math-comp-is-flat 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
)
868 ( latex . math-compose-latex
)
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
)))
875 (let* ((func (car a
))
876 (func2 (assq func
'(( mod . calcFunc-makemod
)
877 ( sdev . calcFunc-sdev
)
884 ( neg . calcFunc-neg
)
885 ( | . calcFunc-vconcat
))))
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
893 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
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
)))
899 (if (and (memq calc-language
'(tex latex
))
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
))
905 (setq func
(if (eq calc-language
'latex
)
906 (format "\\text{%s}" func
)
907 (format "\\hbox{%s}" func
)))))
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")))))
914 (cond ((and (memq calc-language
'(tex latex
))
916 (not (math-tex-expr-is-flat (nth 1 a
)))))
917 (setq left
"\\left( "
919 ((and (eq calc-language
'eqn
)
921 (not (math-tex-expr-is-flat (nth 1 a
)))))
922 (setq left
"{left ( "
924 ((and (or (and (memq calc-language
'(tex latex
))
925 (eq (aref func
0) ?
\\))
926 (and (eq calc-language
'eqn
)
927 (memq (car a
) math-eqn-special-funcs
)))
929 (string-match "\\hbox{" func
)
930 (string-match "\\text{" func
)))
932 (or (Math-realp (nth 1 a
))
933 (memq (car (nth 1 a
)) '(var *))))
934 (setq left
(if (eq calc-language
'eqn
) "~{" "{")
936 ((eq calc-language
'eqn
)
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
)
949 (defun math-prod-first-term (x)
950 (while (eq (car-safe x
) '*)
954 (defun math-prod-last-term (x)
955 (while (eq (car-safe x
) '*)
959 (defun math-compose-vector (a sep prec
)
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
))
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
)
976 (defun math-vector-no-parens (a)
978 (not (eq (car-safe (nth 1 a
)) '*))))
980 (defun math-compose-matrix (a col cols base
)
983 (while (<= (setq col
(1+ col
)) cols
)
984 (setq res
(cons (cons math-comp-just
991 math-comp-vector-prec
)
995 math-comp-comma-spc
" ")))))
1000 (defun math-compose-rows (a count first
)
1004 (math-compose-rows (cdr a
) -
1 nil
)
1005 (cons (concat (if (memq calc-language
'(tex latex
)) " \\ldots" " ...")
1007 (math-compose-rows (cdr a
) -
1 nil
)))
1009 (if first
(concat math-comp-left-bracket
" ") " ")
1010 (math-compose-expr (car a
) math-comp-vector-prec
)
1012 (math-compose-rows (cdr a
) (1- count
) nil
)))
1014 (if first
(concat math-comp-left-bracket
" ") " ")
1015 (math-compose-expr (car a
) math-comp-vector-prec
)
1016 (concat " " math-comp-right-bracket
)))))
1018 (defun math-compose-tex-matrix (a)
1020 (cons (append (math-compose-vector (cdr (car a
)) " & " 0) '(" \\\\ "))
1021 (math-compose-tex-matrix (cdr a
)))
1022 (list (math-compose-vector (cdr (car a
)) " & " 0))))
1024 (defun math-compose-eqn-matrix (a)
1027 (cond ((eq calc-matrix-just
'right
) "rcol ")
1028 ((eq calc-matrix-just
'center
) "ccol ")
1031 (list 'break math-compose-level
)
1035 (let ((math-compose-level (1+ math-compose-level
)))
1036 (math-compose-vector (cdr (car a
)) " above " 1000))
1039 (math-compose-eqn-matrix (cdr a
)))))))
1042 (defun math-vector-is-string (a)
1043 (while (and (setq a
(cdr a
))
1044 (or (and (natnump (car a
))
1046 (and (eq (car-safe (car a
)) 'cplx
)
1047 (natnump (nth 1 (car a
)))
1048 (eq (nth 2 (car a
)) 0)
1049 (<= (nth 1 (car a
)) 255)))))
1052 (defconst math-vector-to-string-chars
'( ( ?
\" .
"\\\"" )
1063 (defun math-vector-to-string (a &optional quoted
)
1064 (setq a
(concat (mapcar (function (lambda (x) (if (consp x
) (nth 1 x
) x
)))
1066 (if (string-match "[\000-\037\177\\\"]" a
)
1068 (pat (if quoted
"[\000-\037\177\\\"]" "[\000-\037\177]"))
1069 (codes (if quoted math-vector-to-string-chars
'((?\^? .
"^?"))))
1070 (fmt (if quoted
"\\^%c" "^%c"))
1072 (while (setq p
(string-match pat a p
))
1073 (if (setq new
(assq (aref a p
) codes
))
1074 (setq a
(concat (substring a
0 p
)
1076 (substring a
(1+ p
)))
1077 p
(+ p
(length (cdr new
))))
1078 (setq a
(concat (substring a
0 p
)
1079 (format fmt
(+ (aref a p
) 64))
1080 (substring a
(1+ p
)))
1083 (concat "\"" a
"\"")
1087 (defun math-to-underscores (x)
1088 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x
)
1089 (math-to-underscores
1090 (concat (math-match-substring x
1) "_" (math-match-substring x
2)))
1093 (defun math-tex-expr-is-flat (a)
1094 (or (Math-integerp a
)
1095 (memq (car a
) '(float var
))
1096 (and (memq (car a
) '(+ -
* neg
))
1098 (while (and (setq a
(cdr a
))
1099 (math-tex-expr-is-flat (car a
))))
1101 (and (memq (car a
) '(^ calcFunc-subscr
))
1102 (math-tex-expr-is-flat (nth 1 a
)))))
1104 (put 'calcFunc-log
'math-compose-big
'math-compose-log
)
1105 (defun math-compose-log (a prec
)
1106 (and (= (length a
) 3)
1109 (let ((calc-language 'flat
))
1110 (math-compose-expr (nth 2 a
) 1000)))
1112 (math-compose-expr (nth 1 a
) 1000)
1115 (put 'calcFunc-log10
'math-compose-big
'math-compose-log10
)
1116 (defun math-compose-log10 (a prec
)
1117 (and (= (length a
) 2)
1119 (list 'subscr
"log" "10")
1121 (math-compose-expr (nth 1 a
) 1000)
1124 (put 'calcFunc-deriv
'math-compose-big
'math-compose-deriv
)
1125 (put 'calcFunc-tderiv
'math-compose-big
'math-compose-deriv
)
1126 (defun math-compose-deriv (a prec
)
1127 (when (= (length a
) 3)
1128 (math-compose-expr (list '/
1129 (list 'calcFunc-choriz
1131 '(calcFunc-string (vec ?d
))
1133 (list 'calcFunc-choriz
1135 '(calcFunc-string (vec ?d
))
1139 (put 'calcFunc-sqrt
'math-compose-big
'math-compose-sqrt
)
1140 (defun math-compose-sqrt (a prec
)
1141 (when (= (length a
) 2)
1142 (let* ((c (math-compose-expr (nth 1 a
) 0))
1143 (a (math-comp-ascent c
))
1144 (d (math-comp-descent c
))
1146 (w (math-comp-width c
)))
1149 (concat (if (= h
1) " " " ")
1150 (make-string (+ w
2) ?\_
))
1154 (append (list 'vleft
(1- a
))
1155 (make-list (1- h
) " |")
1160 (put 'calcFunc-choose
'math-compose-big
'math-compose-choose
)
1161 (defun math-compose-choose (a prec
)
1162 (let ((a1 (math-compose-expr (nth 1 a
) 0))
1163 (a2 (math-compose-expr (nth 2 a
) 0)))
1167 (math-comp-height a1
)
1171 (put 'calcFunc-integ
'math-compose-big
'math-compose-integ
)
1172 (defun math-compose-integ (a prec
)
1173 (and (memq (length a
) '(3 5))
1174 (eq (car-safe (nth 2 a
)) 'var
)
1175 (let* ((parens (and (>= prec
196) (/= prec
1000)))
1176 (var (math-compose-expr (nth 2 a
) 0))
1177 (over (and (eq (car-safe (nth 2 a
)) 'var
)
1178 (or (and (eq (car-safe (nth 1 a
)) '/)
1179 (math-numberp (nth 1 (nth 1 a
))))
1180 (and (eq (car-safe (nth 1 a
)) '^
)
1181 (math-looks-negp (nth 2 (nth 1 a
)))))))
1182 (expr (math-compose-expr (if over
1184 (math-build-var-name
1187 (nth 1 (nth 2 a
)))))
1189 (calc-language 'flat
)
1190 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1191 (high (and (nth 4 a
) (math-compose-expr (nth 4 a
) 0))))
1194 (append (list 'vcent
(if high
3 2))
1195 (and high
(list (list 'horiz
" " high
)))
1201 (and low
(list (list 'horiz low
" "))))
1205 (list 'horiz
" d" var
))
1206 (if parens
")" "")))))
1208 (put 'calcFunc-sum
'math-compose-big
'math-compose-sum
)
1209 (defun math-compose-sum (a prec
)
1210 (and (memq (length a
) '(3 5 6))
1211 (let* ((expr (math-compose-expr (nth 1 a
) 185))
1212 (calc-language 'flat
)
1213 (var (math-compose-expr (nth 2 a
) 0))
1214 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1215 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1217 (if (memq prec
'(180 201)) "(" "")
1218 (append (list 'vcent
(if high
3 2))
1219 (and high
(list high
))
1226 (list (list 'horiz var
" = " low
))
1228 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1231 (if (memq prec
'(180 201)) ")" "")))))
1233 (put 'calcFunc-prod
'math-compose-big
'math-compose-prod
)
1234 (defun math-compose-prod (a prec
)
1235 (and (memq (length a
) '(3 5 6))
1236 (let* ((expr (math-compose-expr (nth 1 a
) 198))
1237 (calc-language 'flat
)
1238 (var (math-compose-expr (nth 2 a
) 0))
1239 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1240 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1242 (if (memq prec
'(196 201)) "(" "")
1243 (append (list 'vcent
(if high
3 2))
1244 (and high
(list high
))
1250 (list (list 'horiz var
" = " low
))
1252 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1255 (if (memq prec
'(196 201)) ")" "")))))
1257 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1258 ;; to math-stack-value-offset in calc.el, but are used by
1259 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1261 (defvar math-svo-wid
)
1262 (defvar math-svo-off
)
1264 (defun math-stack-value-offset-fancy ()
1265 (let ((cwid (+ (math-comp-width math-svo-c
))))
1266 (cond ((eq calc-display-just
'right
)
1267 (if calc-display-origin
1268 (setq math-svo-wid
(max calc-display-origin
5))
1269 (if (integerp calc-line-breaking
)
1270 (setq math-svo-wid calc-line-breaking
)))
1271 (setq math-svo-off
(- math-svo-wid cwid
1272 (max (- (length calc-right-label
)
1273 (if (and (integerp calc-line-breaking
)
1274 calc-display-origin
)
1275 (max (- calc-line-breaking
1276 calc-display-origin
)
1281 (if calc-display-origin
1283 (setq math-svo-off
(- calc-display-origin
(/ cwid
2)))
1284 (if (integerp calc-line-breaking
)
1285 (setq math-svo-off
(min math-svo-off
(- calc-line-breaking cwid
1286 (length calc-right-label
)))))
1287 (if (>= math-svo-off
0)
1288 (setq math-svo-wid
(max math-svo-wid
(+ math-svo-off cwid
)))))
1289 (if (integerp calc-line-breaking
)
1290 (setq math-svo-wid calc-line-breaking
))
1291 (setq math-svo-off
(/ (- math-svo-wid cwid
) 2)))))
1292 (and (integerp calc-line-breaking
)
1293 (or (< math-svo-off
0)
1294 (and calc-display-origin
1295 (> calc-line-breaking calc-display-origin
)))
1296 (setq math-svo-wid calc-line-breaking
))))
1299 ;;; Convert a composition to string form, with embedded \n's if necessary.
1301 (defun math-composition-to-string (c &optional width
)
1302 (or width
(setq width
(calc-window-width)))
1303 (if calc-display-raw
1304 (math-comp-to-string-raw c
0)
1305 (if (math-comp-is-flat c
)
1306 (math-comp-to-string-flat c width
)
1307 (math-vert-comp-to-string
1308 (math-comp-simplify c width
)))))
1310 (defvar math-comp-buf-string
(make-vector 10 ""))
1311 (defvar math-comp-buf-margin
(make-vector 10 0))
1312 (defvar math-comp-buf-level
(make-vector 10 0))
1313 (defun math-comp-is-flat (c) ; check if c's height is 1.
1314 (cond ((not (consp c
)) t
)
1315 ((memq (car c
) '(set break
)) t
)
1316 ((eq (car c
) 'horiz
)
1317 (while (and (setq c
(cdr c
))
1318 (math-comp-is-flat (car c
))))
1320 ((memq (car c
) '(vleft vcent vright
))
1321 (and (= (length c
) 3)
1323 (math-comp-is-flat (nth 2 c
))))
1325 (math-comp-is-flat (nth 2 c
)))
1329 ;;; Convert a one-line composition to a string. Break into multiple
1330 ;;; lines if necessary, choosing break points according to the structure
1333 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1334 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1335 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1336 ;; which is called by math-comp-to-string-flat.
1337 ;; math-comp-highlight and math-comp-buf are also local to
1338 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1339 ;; by math-comp-add-string.
1340 (defvar math-comp-full-width
)
1341 (defvar math-comp-highlight
)
1342 (defvar math-comp-word
)
1343 (defvar math-comp-level
)
1344 (defvar math-comp-margin
)
1345 (defvar math-comp-buf
)
1346 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1347 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1348 ;; which are called by math-comp-to-string-flat.
1349 (defvar math-comp-pos
)
1351 (defun math-comp-to-string-flat (c math-comp-full-width
)
1352 (if math-comp-sel-hpos
1353 (let ((math-comp-pos 0))
1354 (math-comp-sel-flat-term c
))
1355 (let ((math-comp-buf "")
1358 (math-comp-margin 0)
1359 (math-comp-highlight (and math-comp-selected calc-show-selections
))
1360 (math-comp-level -
1))
1361 (math-comp-to-string-flat-term '(set -
1 0))
1362 (math-comp-to-string-flat-term c
)
1363 (math-comp-to-string-flat-term '(break -
1))
1364 (let ((str (aref math-comp-buf-string
0))
1366 (and (> (length str
) 0) (= (aref str
0) ?
)
1367 (> (length math-comp-buf
) 0)
1368 (let ((k (length math-comp-buf
)))
1369 (while (not (= (aref math-comp-buf
(setq k
(1- k
))) ?
\n)))
1370 (aset math-comp-buf k ?
)
1371 (if (and (< (1+ k
) (length math-comp-buf
))
1372 (= (aref math-comp-buf
(1+ k
)) ?
))
1374 (aset math-comp-buf
(1+ k
) ?
\n)
1376 (setq prefix
"\n"))))
1377 (concat math-comp-buf prefix str
)))))
1379 (defun math-comp-to-string-flat-term (c)
1380 (cond ((not (consp c
))
1381 (if math-comp-highlight
1382 (setq c
(math-comp-highlight-string c
)))
1383 (setq math-comp-word
(if (= (length math-comp-word
) 0) c
1384 (concat math-comp-word c
))
1385 math-comp-pos
(+ math-comp-pos
(length c
))))
1387 ((eq (car c
) 'horiz
)
1388 (while (setq c
(cdr c
))
1389 (math-comp-to-string-flat-term (car c
))))
1394 (setq math-comp-level
(1+ math-comp-level
))
1395 (if (>= math-comp-level
(length math-comp-buf-string
))
1396 (setq math-comp-buf-string
(vconcat math-comp-buf-string
1397 math-comp-buf-string
)
1398 math-comp-buf-margin
(vconcat math-comp-buf-margin
1399 math-comp-buf-margin
)
1400 math-comp-buf-level
(vconcat math-comp-buf-level
1401 math-comp-buf-level
)))
1402 (aset math-comp-buf-string math-comp-level
"")
1403 (aset math-comp-buf-margin math-comp-level
(+ math-comp-pos
1405 (aset math-comp-buf-level math-comp-level
(nth 1 c
)))))
1407 ((eq (car c
) 'break
)
1408 (if (not calc-line-breaking
)
1409 (setq math-comp-buf
(concat math-comp-buf math-comp-word
)
1412 (if (and (> math-comp-pos math-comp-full-width
)
1415 (setq str
(aref math-comp-buf-string i
))
1416 (and (= (length str
) 0) (< i math-comp-level
)))
1418 (or (> (length str
) 0) (> (length math-comp-buf
) 0))))
1419 (let ((prefix "") mrg wid
)
1420 (setq mrg
(aref math-comp-buf-margin i
))
1421 (if (> mrg
12) ; indenting too far, go back to far left
1422 (let ((j i
) (new (if calc-line-numbering
5 1)))
1423 '(while (<= j math-comp-level
)
1424 (aset math-comp-buf-margin j
1425 (+ (aref math-comp-buf-margin j
) (- new mrg
)))
1428 (setq wid
(+ (length str
) math-comp-margin
))
1429 (and (> (length str
) 0) (= (aref str
0) ?
)
1430 (> (length math-comp-buf
) 0)
1431 (let ((k (length math-comp-buf
)))
1432 (while (not (= (aref math-comp-buf
(setq k
(1- k
))) ?
\n)))
1433 (aset math-comp-buf k ?
)
1434 (if (and (< (1+ k
) (length math-comp-buf
))
1435 (= (aref math-comp-buf
(1+ k
)) ?
))
1437 (aset math-comp-buf
(1+ k
) ?
\n)
1439 (setq prefix
"\n"))))
1440 (setq math-comp-buf
(concat math-comp-buf prefix str
"\n"
1441 (make-string mrg ?
))
1442 math-comp-pos
(+ math-comp-pos
(- mrg wid
))
1443 math-comp-margin mrg
)
1444 (aset math-comp-buf-string i
"")
1445 (while (<= (setq i
(1+ i
)) math-comp-level
)
1446 (if (> (aref math-comp-buf-margin i
) wid
)
1447 (aset math-comp-buf-margin i
1448 (+ (aref math-comp-buf-margin i
)
1450 (if (and (= (nth 1 c
) (aref math-comp-buf-level math-comp-level
))
1451 (< math-comp-pos
(+ (aref math-comp-buf-margin math-comp-level
) 2)))
1452 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1453 (let ((str (aref math-comp-buf-string math-comp-level
)))
1454 (setq str
(if (= (length str
) 0)
1456 (concat str math-comp-word
))
1458 (while (< (nth 1 c
) (aref math-comp-buf-level math-comp-level
))
1459 (setq math-comp-level
(1- math-comp-level
))
1460 (or (= (length (aref math-comp-buf-string math-comp-level
)) 0)
1461 (setq str
(concat (aref math-comp-buf-string math-comp-level
)
1463 (aset math-comp-buf-string math-comp-level str
)))))
1466 (cond ((eq (nth 1 c
) math-comp-selected
)
1467 (let ((math-comp-highlight (not calc-show-selections
)))
1468 (math-comp-to-string-flat-term (nth 2 c
))))
1470 (let ((math-comp-highlight nil
))
1471 (math-comp-to-string-flat-term (nth 2 c
))))
1472 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1474 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1476 (defun math-comp-highlight-string (s)
1477 (setq s
(copy-sequence s
))
1478 (let ((i (length s
)))
1479 (while (>= (setq i
(1- i
)) 0)
1480 (or (memq (aref s i
) '(32 ?
\n))
1481 (aset s i
(if calc-show-selections ?\. ?\
#)))))
1485 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1486 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1487 ;; math-comp-add-string-sel, which are called (indirectly) by
1488 ;; calc-find-selected-part.
1489 (defvar math-comp-sel-tag
)
1491 (defun math-comp-sel-flat-term (c)
1492 (cond ((not (consp c
))
1493 (setq math-comp-pos
(+ math-comp-pos
(length c
))))
1494 ((memq (car c
) '(set break
)))
1495 ((eq (car c
) 'horiz
)
1496 (while (and (setq c
(cdr c
)) (< math-comp-sel-cpos
1000000))
1497 (math-comp-sel-flat-term (car c
))))
1499 (if (<= math-comp-pos math-comp-sel-cpos
)
1501 (math-comp-sel-flat-term (nth 2 c
))
1502 (if (> math-comp-pos math-comp-sel-cpos
)
1503 (setq math-comp-sel-tag c
1504 math-comp-sel-cpos
1000000)))
1505 (math-comp-sel-flat-term (nth 2 c
))))
1506 (t (math-comp-sel-flat-term (nth 2 c
)))))
1509 ;;; Simplify a composition to a canonical form consisting of
1510 ;;; (vleft n "string" "string" "string" ...)
1511 ;;; where 0 <= n < number-of-strings.
1513 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1514 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1515 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1516 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1517 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1518 ;; math-comp-simplify.
1519 (defvar math-comp-base
)
1520 (defvar math-comp-hgt
)
1521 (defvar math-comp-tag
)
1522 (defvar math-comp-hpos
)
1523 (defvar math-comp-vpos
)
1525 (defun math-comp-simplify (c full-width
)
1526 (let ((math-comp-buf (list ""))
1531 (math-comp-highlight (and math-comp-selected calc-show-selections
))
1532 (math-comp-tag nil
))
1533 (math-comp-simplify-term c
)
1534 (cons 'vleft
(cons math-comp-base math-comp-buf
))))
1536 (defun math-comp-add-string (s h v
)
1537 (and (> (length s
) 0)
1538 (let ((vv (+ v math-comp-base
)))
1539 (if math-comp-sel-hpos
1540 (math-comp-add-string-sel h vv
(length s
) 1)
1542 (setq math-comp-buf
(nconc (make-list (- vv
) "") math-comp-buf
)
1543 math-comp-base
(- v
)
1544 math-comp-hgt
(- math-comp-hgt vv
)
1546 (if (>= vv math-comp-hgt
)
1547 (setq math-comp-buf
(nconc math-comp-buf
1548 (make-list (1+ (- vv math-comp-hgt
)) ""))
1549 math-comp-hgt
(1+ vv
))))
1550 (let ((str (nthcdr vv math-comp-buf
)))
1551 (setcar str
(concat (car str
)
1552 (make-string (- h
(length (car str
))) 32)
1553 (if math-comp-highlight
1554 (math-comp-highlight-string s
)
1557 (defun math-comp-add-string-sel (x y w h
)
1558 (if (and (<= y math-comp-sel-vpos
)
1559 (> (+ y h
) math-comp-sel-vpos
)
1560 (<= x math-comp-sel-hpos
)
1561 (> (+ x w
) math-comp-sel-hpos
))
1562 (setq math-comp-sel-tag math-comp-tag
1563 math-comp-sel-vpos
10000)))
1565 (defun math-comp-simplify-term (c)
1567 (math-comp-add-string c math-comp-hpos math-comp-vpos
)
1568 (setq math-comp-hpos
(+ math-comp-hpos
(length c
))))
1569 ((memq (car c
) '(set break
))
1571 ((eq (car c
) 'horiz
)
1572 (while (setq c
(cdr c
))
1573 (math-comp-simplify-term (car c
))))
1574 ((memq (car c
) '(vleft vcent vright
))
1575 (let* ((math-comp-vpos (+ (- math-comp-vpos
(nth 1 c
))
1576 (1- (math-comp-ascent (nth 2 c
)))))
1577 (widths (mapcar 'math-comp-width
(cdr (cdr c
))))
1578 (maxwid (apply 'max widths
))
1579 (bias (cond ((eq (car c
) 'vleft
) 0)
1580 ((eq (car c
) 'vcent
) 1)
1583 (while (setq c
(cdr c
))
1584 (if (eq (car-safe (car c
)) 'rule
)
1585 (math-comp-add-string (make-string maxwid
(nth 1 (car c
)))
1586 math-comp-hpos math-comp-vpos
)
1587 (let ((math-comp-hpos (+ math-comp-hpos
(/ (* bias
(- maxwid
1590 (math-comp-simplify-term (car c
))))
1592 (setq math-comp-vpos
(+ math-comp-vpos
1593 (+ (math-comp-descent (car c
))
1594 (math-comp-ascent (nth 1 c
))))
1595 widths
(cdr widths
))))
1596 (setq math-comp-hpos
(+ math-comp-hpos maxwid
))))
1597 ((eq (car c
) 'supscr
)
1598 (let* ((asc (or 1 (math-comp-ascent (nth 1 c
))))
1599 (desc (math-comp-descent (nth 2 c
)))
1602 (math-comp-simplify-term (nth 1 c
))))
1603 (math-comp-vpos (- math-comp-vpos
(+ asc desc
))))
1604 (math-comp-simplify-term (nth 2 c
))
1605 (if math-comp-sel-hpos
1606 (math-comp-add-string-sel oldh
1609 (math-comp-ascent (nth 2 c
)))
1610 (- math-comp-hpos oldh
)
1611 (math-comp-height c
)))))
1612 ((eq (car c
) 'subscr
)
1613 (let* ((asc (math-comp-ascent (nth 2 c
)))
1614 (desc (math-comp-descent (nth 1 c
)))
1615 (oldv math-comp-vpos
)
1618 (math-comp-simplify-term (nth 1 c
))))
1619 (math-comp-vpos (+ math-comp-vpos
(+ asc desc
))))
1620 (math-comp-simplify-term (nth 2 c
))
1621 (if math-comp-sel-hpos
1622 (math-comp-add-string-sel oldh oldv
1623 (- math-comp-hpos oldh
)
1624 (math-comp-height c
)))))
1626 (cond ((eq (nth 1 c
) math-comp-selected
)
1627 (let ((math-comp-highlight (not calc-show-selections
)))
1628 (math-comp-simplify-term (nth 2 c
))))
1630 (let ((math-comp-highlight nil
))
1631 (math-comp-simplify-term (nth 2 c
))))
1632 (t (let ((math-comp-tag c
))
1633 (math-comp-simplify-term (nth 2 c
))))))))
1636 ;;; Measuring a composition.
1638 (defun math-comp-first-char (c)
1640 (and (> (length c
) 0)
1642 ((memq (car c
) '(horiz subscr supscr
))
1643 (while (and (setq c
(cdr c
))
1644 (math-comp-is-null (car c
))))
1645 (and c
(math-comp-first-char (car c
))))
1647 (math-comp-first-char (nth 2 c
)))))
1649 (defun math-comp-first-string (c)
1651 (and (> (length c
) 0)
1653 ((eq (car c
) 'horiz
)
1654 (while (and (setq c
(cdr c
))
1655 (math-comp-is-null (car c
))))
1656 (and c
(math-comp-first-string (car c
))))
1658 (math-comp-first-string (nth 2 c
)))))
1660 (defun math-comp-last-char (c)
1662 (and (> (length c
) 0)
1663 (elt c
(1- (length c
)))))
1664 ((eq (car c
) 'horiz
)
1665 (let ((c (reverse (cdr c
))))
1666 (while (and c
(math-comp-is-null (car c
)))
1668 (and c
(math-comp-last-char (car c
)))))
1670 (math-comp-last-char (nth 2 c
)))))
1672 (defun math-comp-is-null (c)
1673 (cond ((stringp c
) (= (length c
) 0))
1674 ((memq (car c
) '(horiz subscr supscr
))
1675 (while (and (setq c
(cdr c
))
1676 (math-comp-is-null (car c
))))
1679 (math-comp-is-null (nth 2 c
)))
1680 ((memq (car c
) '(set break
)) t
)))
1682 (defun math-comp-width (c)
1683 (cond ((not (consp c
)) (length c
))
1684 ((memq (car c
) '(horiz subscr supscr
))
1686 (while (setq c
(cdr c
))
1687 (setq accum
(+ accum
(math-comp-width (car c
)))))
1689 ((memq (car c
) '(vcent vleft vright
))
1692 (while (setq c
(cdr c
))
1693 (setq accum
(max accum
(math-comp-width (car c
)))))
1696 (math-comp-width (nth 2 c
)))
1699 (defun math-comp-height (c)
1702 (+ (math-comp-ascent c
) (math-comp-descent c
))))
1704 (defun math-comp-ascent (c)
1705 (cond ((not (consp c
)) 1)
1706 ((eq (car c
) 'horiz
)
1708 (while (setq c
(cdr c
))
1709 (setq accum
(max accum
(math-comp-ascent (car c
)))))
1711 ((memq (car c
) '(vcent vleft vright
))
1712 (if (> (nth 1 c
) 0) (1+ (nth 1 c
)) 1))
1713 ((eq (car c
) 'supscr
)
1714 (max (math-comp-ascent (nth 1 c
)) (1+ (math-comp-height (nth 2 c
)))))
1715 ((eq (car c
) 'subscr
)
1716 (math-comp-ascent (nth 1 c
)))
1718 (math-comp-ascent (nth 2 c
)))
1721 (defun math-comp-descent (c)
1722 (cond ((not (consp c
)) 0)
1723 ((eq (car c
) 'horiz
)
1725 (while (setq c
(cdr c
))
1726 (setq accum
(max accum
(math-comp-descent (car c
)))))
1728 ((memq (car c
) '(vcent vleft vright
))
1729 (let ((accum (- (nth 1 c
))))
1731 (while (setq c
(cdr c
))
1732 (setq accum
(+ accum
(math-comp-height (car c
)))))
1733 (max (1- accum
) 0)))
1734 ((eq (car c
) 'supscr
)
1735 (math-comp-descent (nth 1 c
)))
1736 ((eq (car c
) 'subscr
)
1737 (+ (math-comp-descent (nth 1 c
)) (math-comp-height (nth 2 c
))))
1739 (math-comp-descent (nth 2 c
)))
1742 (defun calcFunc-cwidth (a &optional prec
)
1743 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1744 (math-comp-width (math-compose-expr a
(or prec
0))))
1746 (defun calcFunc-cheight (a &optional prec
)
1747 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1748 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1749 (memq (length a
) '(2 3))
1752 (math-comp-height (math-compose-expr a
(or prec
0)))))
1754 (defun calcFunc-cascent (a &optional prec
)
1755 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1756 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1757 (memq (length a
) '(2 3))
1760 (math-comp-ascent (math-compose-expr a
(or prec
0)))))
1762 (defun calcFunc-cdescent (a &optional prec
)
1763 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1764 (math-comp-descent (math-compose-expr a
(or prec
0))))
1767 ;;; Convert a simplified composition into string form.
1769 (defun math-vert-comp-to-string (c)
1772 (math-vert-comp-to-string-step (cdr (cdr c
)))))
1774 (defun math-vert-comp-to-string-step (c)
1776 (concat (car c
) "\n" (math-vert-comp-to-string-step (cdr c
)))
1780 ;;; Convert a composition to a string in "raw" form (for debugging).
1782 (defun math-comp-to-string-raw (c indent
)
1783 (cond ((or (not (consp c
)) (eq (car c
) 'set
))
1784 (prin1-to-string c
))
1786 (concat "(" (symbol-name (car c
)) ")"))
1788 (let ((next-indent (+ indent
2 (length (symbol-name (car c
))))))
1790 (symbol-name (car c
))
1792 (math-comp-to-string-raw (nth 1 c
) next-indent
)
1793 (math-comp-to-string-raw-step (cdr (cdr c
))
1797 (defun math-comp-to-string-raw-step (cl indent
)
1800 (make-string indent
32)
1801 (math-comp-to-string-raw (car cl
) indent
)
1802 (math-comp-to-string-raw-step (cdr cl
) indent
))
1807 ;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1808 ;;; calccomp.el ends here