1 ;;; calccomp.el --- composition functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainers: D. Goel <deego@gnufans.org>
7 ;; Colin Walters <walters@debian.org>
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 (defun calc-Need-calc-comp () nil
)
37 (defconst math-eqn-special-funcs
39 calcFunc-ln calcFunc-exp
40 calcFunc-sin calcFunc-cos calcFunc-tan
41 calcFunc-sinh calcFunc-cosh calcFunc-tanh
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 (defun math-compose-expr (a prec
)
66 (let ((math-compose-level (1+ math-compose-level
)))
68 ((or (and (eq a math-comp-selected
) a
)
70 (not (eq math-comp-tagged a
))))
71 (let ((math-comp-selected nil
))
72 (and math-comp-tagged
(setq math-comp-tagged a
))
73 (list 'tag a
(math-compose-expr a prec
))))
74 ((and (not (consp a
)) (not (integerp a
)))
75 (concat "'" (prin1-to-string a
)))
77 (if (or (eq (car-safe a
) 'frac
)
78 (and (nth 1 calc-frac-format
) (Math-integerp a
)))
79 (if (memq calc-language
'(tex eqn math maple c fortran pascal
))
80 (let ((aa (math-adjust-fraction a
))
81 (calc-frac-format nil
))
82 (math-compose-expr (list '/
83 (if (memq calc-language
'(c fortran
))
84 (math-float (nth 1 aa
))
87 (if (and (eq calc-language
'big
)
88 (= (length (car calc-frac-format
)) 1))
89 (let* ((aa (math-adjust-fraction a
))
90 (calc-frac-format nil
)
91 (math-radix-explicit-format nil
)
93 (if (math-negp (nth 1 aa
))
97 (math-abs (nth 1 aa
)))
99 (math-format-number (nth 2 aa
))))))
100 (if (= calc-number-radix
10)
104 (int-to-string calc-number-radix
)))))
105 (math-format-number a
)))
106 (if (not (eq calc-language
'big
))
107 (math-format-number a prec
)
108 (if (memq (car-safe a
) '(cplx polar
))
109 (if (math-zerop (nth 2 a
))
110 (math-compose-expr (nth 1 a
) prec
)
112 (math-compose-expr (nth 1 a
) 0)
113 (if (eq (car a
) 'cplx
) ", " "; ")
114 (math-compose-expr (nth 2 a
) 0) ")"))
115 (if (or (= calc-number-radix
10)
117 (and calc-group-digits
118 (not (assoc calc-group-char
'((",") (" "))))))
119 (math-format-number a prec
)
120 (let ((s (math-format-number a prec
))
122 (while (string-match (if (> calc-number-radix
14)
123 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
124 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
126 (setq c
(nconc c
(list (substring s
0 (match-beginning 0))
128 (math-match-substring s
2)
129 (math-match-substring s
1))))
130 s
(substring s
(match-end 0))))
132 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s
)
134 (substring s
0 (match-beginning 0)) " "
136 (math-match-substring s
1)
137 (math-match-substring s
2))
138 (math-match-substring s
3))))
139 (if c
(cons 'horiz
(nconc c
(list s
))) s
)))))))
140 ((and (get (car a
) 'math-compose-forms
)
141 (not (eq calc-language
'unform
))
142 (let ((comps (get (car a
) 'math-compose-forms
))
144 (or (and (setq temp
(assq calc-language comps
))
145 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
146 (setq temp
(apply (cdr temp2
) (cdr a
)))
147 (math-compose-expr temp prec
))
148 (and (setq temp2
(assq nil
(cdr temp
)))
149 (funcall (cdr temp2
) a
))))
150 (and (setq temp
(assq nil comps
))
151 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
152 (setq temp
(apply (cdr temp2
) (cdr a
)))
153 (math-compose-expr temp prec
))
154 (and (setq temp2
(assq nil
(cdr temp
)))
155 (funcall (cdr temp2
) a
))))))))
157 (let* ((left-bracket (if calc-vector-brackets
158 (substring calc-vector-brackets
0 1) ""))
159 (right-bracket (if calc-vector-brackets
160 (substring calc-vector-brackets
1 2) ""))
161 (inner-brackets (memq 'R calc-matrix-brackets
))
162 (outer-brackets (memq 'O calc-matrix-brackets
))
163 (row-commas (memq 'C calc-matrix-brackets
))
164 (comma-spc (or calc-vector-commas
" "))
165 (comma (or calc-vector-commas
""))
166 (vector-prec (if (or (and calc-vector-commas
167 (math-vector-no-parens a
))
168 (memq 'P calc-matrix-brackets
)) 0 1000))
169 (just (cond ((eq calc-matrix-just
'right
) 'vright
)
170 ((eq calc-matrix-just
'center
) 'vcent
)
172 (break calc-break-vectors
))
173 (if (and (memq calc-language
'(nil big
))
174 (not calc-break-vectors
)
175 (math-matrixp a
) (not (math-matrixp (nth 1 a
)))
176 (or calc-full-vectors
177 (and (< (length a
) 7) (< (length (nth 1 a
)) 7))
178 (progn (setq break t
) nil
)))
180 (setq vector-prec
(if (or (and calc-vector-commas
181 (math-vector-no-parens
183 (memq 'P calc-matrix-brackets
))
187 (concat left-bracket left-bracket
" ")
188 (math-compose-vector (cdr (nth 1 a
)) (concat comma
" ")
190 (concat " " right-bracket right-bracket
))
191 (let* ((rows (1- (length a
)))
192 (cols (1- (length (nth 1 a
))))
193 (base (/ (1- rows
) 2))
194 (calc-language 'flat
))
196 (list (append '(vleft)
198 (list (concat (and outer-brackets
205 (concat (and outer-brackets
211 (math-compose-matrix (cdr a
) 1 cols base
)
212 (list (append '(vleft)
220 (if (and outer-brackets
230 right-bracket
)))))))))
231 (if (and calc-display-strings
233 (math-vector-is-string a
))
234 (math-vector-to-string a t
)
235 (if (and break
(cdr a
)
236 (not (eq calc-language
'flat
)))
237 (let* ((full (or calc-full-vectors
(< (length a
) 7)))
238 (rows (if full
(1- (length a
)) 5))
239 (base (/ (1- rows
) 2))
241 (calc-break-vectors nil
))
243 (cons 'vleft
(cons base
246 (if full rows
3) t
)))))
247 (if (or calc-full-vectors
(< (length a
) 7))
248 (if (and (eq calc-language
'tex
)
250 (append '(horiz "\\matrix{ ")
251 (math-compose-tex-matrix (cdr a
))
253 (if (and (eq calc-language
'eqn
)
255 (append '(horiz "matrix { ")
256 (math-compose-eqn-matrix
257 (cdr (math-transpose a
)))
259 (if (and (eq calc-language
'maple
)
264 (math-compose-vector (cdr a
) (concat comma
" ")
270 (math-compose-vector (cdr a
) (concat comma
" ")
275 (math-compose-vector (list (nth 1 a
) (nth 2 a
) (nth 3 a
))
276 (concat comma
" ") vector-prec
)
277 comma
(if (eq calc-language
'tex
) " \\ldots" " ...")
279 (list 'break math-compose-level
)
280 (math-compose-expr (nth (1- (length a
)) a
)
281 (if (equal comma
"") 1000 0))
283 ((eq (car a
) 'incomplete
)
285 (cond ((eq (nth 1 a
) 'vec
)
287 (math-compose-vector (cdr (cdr a
)) ", " 0)
289 ((eq (nth 1 a
) 'cplx
)
291 (math-compose-vector (cdr (cdr a
)) ", " 0)
293 ((eq (nth 1 a
) 'polar
)
295 (math-compose-vector (cdr (cdr a
)) "; " 0)
297 ((eq (nth 1 a
) 'intv
)
299 (if (memq (nth 2 a
) '(0 1)) "(" "[")
300 (math-compose-vector (cdr (cdr (cdr a
))) " .. " 0)
303 (cond ((eq (nth 1 a
) 'vec
) "[ ...")
304 ((eq (nth 1 a
) 'intv
)
305 (if (memq (nth 2 a
) '(0 1)) "( ..." "[ ..."))
308 (let ((v (rassq (nth 2 a
) math-expr-variable-mapping
)))
310 (symbol-name (car v
))
311 (if (and (eq calc-language
'tex
)
313 (not (= calc-language-option
0))
314 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
315 (symbol-name (nth 1 a
))))
316 (format "\\hbox{%s}" (symbol-name (nth 1 a
)))
317 (if (and math-compose-hash-args
318 (let ((p calc-arg-values
))
320 (while (and p
(not (equal (car p
) a
)))
321 (setq p
(and (eq math-compose-hash-args t
) (cdr p
))
324 (if (eq math-compose-hash-args
1)
327 (if (memq calc-language
'(c fortran pascal maple
))
328 (math-to-underscores (symbol-name (nth 1 a
)))
329 (if (and (eq calc-language
'eqn
)
330 (string-match ".'\\'" (symbol-name (nth 2 a
))))
332 (list 'calcFunc-Prime
335 (intern (substring (symbol-name (nth 1 a
)) 0 -
1))
336 (intern (substring (symbol-name (nth 2 a
)) 0 -
1))))
338 (symbol-name (nth 1 a
)))))))))
341 (if (eq calc-language
'maple
) ""
342 (if (memq (nth 1 a
) '(0 1)) "(" "["))
343 (math-compose-expr (nth 2 a
) 0)
344 (if (eq calc-language
'tex
) " \\ldots "
345 (if (eq calc-language
'eqn
) " ... " " .. "))
346 (math-compose-expr (nth 3 a
) 0)
347 (if (eq calc-language
'maple
) ""
348 (if (memq (nth 1 a
) '(0 2)) ")" "]"))))
350 (if (eq (car calc-date-format
) 'X
)
352 (concat "<" (math-format-date a
) ">")))
353 ((and (eq (car a
) 'calcFunc-subscr
) (cdr (cdr a
))
354 (memq calc-language
'(c pascal fortran maple
)))
355 (let ((args (cdr (cdr a
))))
356 (while (and (memq calc-language
'(pascal fortran
))
357 (eq (car-safe (nth 1 a
)) 'calcFunc-subscr
))
358 (setq args
(append (cdr (cdr (nth 1 a
))) args
)
361 (math-compose-expr (nth 1 a
) 1000)
362 (if (eq calc-language
'fortran
) "(" "[")
363 (math-compose-vector args
", " 0)
364 (if (eq calc-language
'fortran
) ")" "]"))))
365 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
366 (eq calc-language
'big
))
367 (let* ((a1 (math-compose-expr (nth 1 a
) 1000))
368 (calc-language 'flat
)
369 (a2 (math-compose-expr (nth 2 a
) 0)))
370 (if (or (eq (car-safe a1
) 'subscr
)
371 (and (eq (car-safe a1
) 'tag
)
372 (eq (car-safe (nth 2 a1
)) 'subscr
)
373 (setq a1
(nth 2 a1
))))
380 (list 'subscr a1 a2
))))
381 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
382 (eq calc-language
'math
))
384 (math-compose-expr (nth 1 a
) 1000)
386 (math-compose-expr (nth 2 a
) 0)
388 ((and (eq (car a
) 'calcFunc-sqrt
)
389 (eq calc-language
'tex
))
392 (math-compose-expr (nth 1 a
) 0)
394 ((and nil
(eq (car a
) 'calcFunc-sqrt
)
395 (eq calc-language
'eqn
))
398 (math-compose-expr (nth 1 a
) -
1)
400 ((and (eq (car a
) '^
)
401 (eq calc-language
'big
))
403 (if (or (math-looks-negp (nth 1 a
))
404 (memq (car-safe (nth 1 a
)) '(^
/ frac calcFunc-sqrt
))
405 (and (eq (car-safe (nth 1 a
)) 'cplx
)
406 (math-negp (nth 1 (nth 1 a
)))
407 (eq (nth 2 (nth 1 a
)) 0)))
408 (list 'horiz
"(" (math-compose-expr (nth 1 a
) 0) ")")
409 (math-compose-expr (nth 1 a
) 201))
410 (let ((calc-language 'flat
)
411 (calc-number-radix 10))
412 (math-compose-expr (nth 2 a
) 0))))
413 ((and (eq (car a
) '/)
414 (eq calc-language
'big
))
415 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a
)) '(/ frac
))
417 (math-compose-expr (nth 1 a
) 0)))
418 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a
)) '(/ frac
))
420 (math-compose-expr (nth 2 a
) 0))))
422 (math-comp-height a1
)
424 ((and (memq (car a
) '(calcFunc-sum calcFunc-prod
))
425 (eq calc-language
'tex
)
427 (list 'horiz
(if (eq (car a
) 'calcFunc-sum
) "\\sum" "\\prod")
428 "_{" (math-compose-expr (nth 2 a
) 0)
429 "=" (math-compose-expr (nth 3 a
) 0)
430 "}^{" (math-compose-expr (nth 4 a
) 0)
431 "}{" (math-compose-expr (nth 1 a
) 0) "}"))
432 ((and (eq (car a
) 'calcFunc-lambda
)
434 (memq calc-language
'(nil flat big
)))
437 (math-compose-hash-args (if (= (length a
) 3) 1 t
)))
438 (while (and (cdr p
) (equal (car p
) (car ap
)))
439 (setq p
(cdr p
) ap
(cdr ap
)))
442 (list (math-compose-vector
443 (nreverse (cdr (reverse (cdr a
)))) ", " 0)
446 (list (math-compose-expr (nth (1- (length a
)) a
) 0)
448 ((and (eq (car a
) 'calcFunc-string
)
450 (math-vectorp (nth 1 a
))
451 (math-vector-is-string (nth 1 a
)))
452 (if (eq calc-language
'unform
)
453 (concat "string(" (math-vector-to-string (nth 1 a
) t
) ")")
454 (math-vector-to-string (nth 1 a
) nil
)))
455 ((and (eq (car a
) 'calcFunc-bstring
)
457 (math-vectorp (nth 1 a
))
458 (math-vector-is-string (nth 1 a
)))
459 (if (eq calc-language
'unform
)
460 (concat "bstring(" (math-vector-to-string (nth 1 a
) t
) ")")
462 (s (math-vector-to-string (nth 1 a
) nil
))
464 (while (string-match "[^ ] +[^ ]" s
)
465 (setq p
(1- (match-end 0))
466 c
(cons (list 'break math-compose-level
)
467 (cons (substring s
0 p
)
470 (setq c
(nreverse (cons s c
)))
472 (setq c
(cons (list 'set math-compose-level
2) c
)))
474 ((and (eq (car a
) 'calcFunc-cprec
)
475 (not (eq calc-language
'unform
))
477 (integerp (nth 2 a
)))
478 (let ((c (math-compose-expr (nth 1 a
) -
1)))
479 (if (> prec
(nth 2 a
))
480 (if (eq calc-language
'tex
)
481 (list 'horiz
"\\left( " c
" \\right)")
482 (if (eq calc-language
'eqn
)
483 (list 'horiz
"{left ( " c
" right )}")
484 (list 'horiz
"(" c
")")))
486 ((and (eq (car a
) 'calcFunc-choriz
)
487 (not (eq calc-language
'unform
))
488 (memq (length a
) '(2 3 4))
489 (math-vectorp (nth 1 a
))
490 (if (integerp (nth 2 a
))
492 (and (math-vectorp (nth 3 a
))
493 (math-vector-is-string (nth 3 a
))))
495 (and (math-vectorp (nth 2 a
))
496 (math-vector-is-string (nth 2 a
))))))
497 (let* ((cprec (and (integerp (nth 2 a
)) (nth 2 a
)))
498 (sep (nth (if cprec
3 2) a
))
501 (math-compose-vector (cdr (nth 1 a
))
502 (math-vector-to-string sep nil
)
504 (cons 'horiz
(mapcar (function
506 (if (eq (car-safe x
) 'calcFunc-bstring
)
509 x
(or bprec cprec prec
))
511 (math-compose-expr x
(or cprec prec
)))))
513 ((and (memq (car a
) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert
))
514 (not (eq calc-language
'unform
))
515 (memq (length a
) '(2 3))
516 (math-vectorp (nth 1 a
))
518 (integerp (nth 2 a
))))
521 (prec (or (nth 2 a
) prec
))
524 (let ((b nil
) (cc nil
) a d
)
525 (if (and (memq (car-safe x
) '(calcFunc-cbase
528 (memq (length x
) '(1 2)))
531 (if (and (eq (car-safe x
) 'calcFunc-crule
)
532 (memq (length x
) '(1 2))
534 (and (math-vectorp (nth 1 x
))
535 (= (length (nth 1 x
)) 2)
536 (math-vector-is-string
538 (and (natnump (nth 1 x
))
539 (<= (nth 1 x
) 255))))
542 (if (math-vectorp (nth 1 x
))
543 (aref (math-vector-to-string
546 (or (and (memq (car-safe x
) '(calcFunc-cvspace
549 (memq (length x
) '(2 3))
552 (setq cc
(math-compose-expr x prec
))))
553 (setq a
(if cc
(math-comp-ascent cc
) 0)
554 d
(if cc
(math-comp-descent cc
) 0))
555 (if (eq b
'calcFunc-cbase
)
556 (setq base
(+ v a -
1))
557 (if (eq b
'calcFunc-ctbase
)
559 (if (eq b
'calcFunc-cbbase
)
560 (setq base
(+ v a d -
1)))))
564 (setq c
(delq nil c
))
566 (cons (if (eq (car a
) 'calcFunc-cvert
) 'vcent
567 (if (eq (car a
) 'calcFunc-clvert
) 'vleft
'vright
))
570 ((and (memq (car a
) '(calcFunc-csup calcFunc-csub
))
571 (not (eq calc-language
'unform
))
572 (memq (length a
) '(3 4))
574 (integerp (nth 3 a
))))
575 (list (if (eq (car a
) 'calcFunc-csup
) 'supscr
'subscr
)
576 (math-compose-expr (nth 1 a
) (or (nth 3 a
) 0))
577 (math-compose-expr (nth 2 a
) 0)))
578 ((and (eq (car a
) 'calcFunc-cflat
)
579 (not (eq calc-language
'unform
))
580 (memq (length a
) '(2 3))
582 (integerp (nth 2 a
))))
583 (let ((calc-language (if (memq calc-language
'(nil big
))
584 'flat calc-language
)))
585 (math-compose-expr (nth 1 a
) (or (nth 2 a
) 0))))
586 ((and (eq (car a
) 'calcFunc-cspace
)
587 (memq (length a
) '(2 3))
590 (cons 'horiz
(make-list (nth 1 a
)
591 (if (and (math-vectorp (nth 2 a
))
592 (math-vector-is-string (nth 2 a
)))
593 (math-vector-to-string (nth 2 a
) nil
)
594 (math-compose-expr (nth 2 a
) 0))))
595 (make-string (nth 1 a
) ?\
)))
596 ((and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
597 (memq (length a
) '(2 3))
601 (let* ((c (if (nth 2 a
)
602 (if (and (math-vectorp (nth 2 a
))
603 (math-vector-is-string (nth 2 a
)))
604 (math-vector-to-string (nth 2 a
) nil
)
605 (math-compose-expr (nth 2 a
) 0))
607 (ca (math-comp-ascent c
))
608 (cd (math-comp-descent c
)))
610 (cons (if (eq (car a
) 'calcFunc-ctspace
)
612 (if (eq (car a
) 'calcFunc-cbspace
)
613 (+ (* (1- (nth 1 a
)) (+ ca cd
)) (1- ca
))
614 (/ (1- (* (nth 1 a
) (+ ca cd
))) 2)))
615 (make-list (nth 1 a
) c
))))))
616 ((and (eq (car a
) 'calcFunc-evalto
)
617 (setq calc-any-evaltos t
)
618 (memq calc-language
'(tex eqn
))
619 (= math-compose-level
(if math-comp-tagged
2 1))
622 (if (eq calc-language
'tex
) "\\evalto " "evalto ")
623 (math-compose-expr (nth 1 a
) 0)
624 (if (eq calc-language
'tex
) " \\to " " -> ")
625 (math-compose-expr (nth 2 a
) 0)))
627 (let ((op (and (not (eq calc-language
'unform
))
628 (if (and (eq (car a
) 'calcFunc-if
) (= (length a
) 4))
629 (assoc "?" math-expr-opers
)
630 (math-assq2 (car a
) math-expr-opers
)))))
632 (or (= (length a
) 3) (eq (car a
) 'calcFunc-if
))
635 ((> prec
(or (nth 4 op
) (min (nth 2 op
) (nth 3 op
))))
636 (if (and (eq calc-language
'tex
)
637 (not (math-tex-expr-is-flat a
)))
638 (if (eq (car-safe a
) '/)
639 (list 'horiz
"{" (math-compose-expr a -
1) "}")
640 (list 'horiz
"\\left( "
641 (math-compose-expr a -
1)
643 (if (eq calc-language
'eqn
)
644 (if (or (eq (car-safe a
) '/)
646 (list 'horiz
"{" (math-compose-expr a -
1) "}")
647 (if (math-tex-expr-is-flat a
)
648 (list 'horiz
"( " (math-compose-expr a -
1) " )")
649 (list 'horiz
"{left ( "
650 (math-compose-expr a -
1)
652 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
653 ((and (eq calc-language
'tex
)
654 (memq (car a
) '(/ calcFunc-choose calcFunc-evalto
))
656 (list 'horiz
"{" (math-compose-expr a -
1) "}"))
657 ((eq (car a
) 'calcFunc-if
)
659 (math-compose-expr (nth 1 a
) (nth 2 op
))
661 (math-compose-expr (nth 2 a
) 0)
663 (math-compose-expr (nth 3 a
) (nth 3 op
))))
665 (let* ((math-comp-tagged (and math-comp-tagged
668 (setlev (if (= prec
(min (nth 2 op
) (nth 3 op
)))
670 (setq math-compose-level
671 (1- math-compose-level
))
674 (lhs (math-compose-expr (nth 1 a
) (nth 2 op
)))
675 (rhs (math-compose-expr (nth 2 a
) (nth 3 op
))))
676 (and (equal (car op
) "^")
677 (eq (math-comp-first-char lhs
) ?-
)
678 (setq lhs
(list 'horiz
"(" lhs
")")))
679 (and (eq calc-language
'tex
)
680 (or (equal (car op
) "^") (equal (car op
) "_"))
681 (not (and (stringp rhs
) (= (length rhs
) 1)))
682 (setq rhs
(list 'horiz
"{" rhs
"}")))
683 (or (and (eq (car a
) '*)
684 (or (null calc-language
)
685 (assoc "2x" math-expr-opers
))
686 (let* ((prevt (math-prod-last-term (nth 1 a
)))
687 (nextt (math-prod-first-term (nth 2 a
)))
688 (prevc (or (math-comp-last-char lhs
)
689 (and (memq (car-safe prevt
)
693 (eq calc-language
'big
)
695 (nextc (or (math-comp-first-char rhs
)
696 (and (memq (car-safe nextt
)
701 (eq calc-language
'big
)
704 (or (and (>= nextc ?a
) (<= nextc ?z
))
705 (and (>= nextc ?A
) (<= nextc ?Z
))
706 (and (>= nextc ?
0) (<= nextc ?
9))
707 (memq nextc
'(?. ?_ ?
#
712 (math-comp-first-string
714 (not (and (eq (car-safe prevt
) 'var
)
719 (list 'break math-compose-level
)
725 (list 'break math-compose-level
)
726 (if (or (equal (car op
) "^")
728 (equal (car op
) "**")
729 (and (equal (car op
) "*")
730 (math-comp-last-char lhs
)
731 (math-comp-first-char rhs
))
732 (and (equal (car op
) "/")
733 (math-num-integerp (nth 1 a
))
734 (math-integerp (nth 2 a
))))
736 (if (and (eq calc-language
'big
)
737 (equal (car op
) "=>"))
739 (concat " " (car op
) " ")))
741 ((and op
(= (length a
) 2) (= (nth 3 op
) -
1))
743 ((or (> prec
(or (nth 4 op
) (nth 2 op
)))
744 (and (not (eq (assoc (car op
) math-expr-opers
) op
))
745 (> prec
0))) ; don't write x% + y
746 (if (and (eq calc-language
'tex
)
747 (not (math-tex-expr-is-flat a
)))
748 (list 'horiz
"\\left( "
749 (math-compose-expr a -
1)
751 (if (eq calc-language
'eqn
)
752 (if (= (/ prec
100) 9)
753 (list 'horiz
"{" (math-compose-expr a -
1) "}")
754 (if (math-tex-expr-is-flat a
)
755 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
756 (list 'horiz
"{left ( "
757 (math-compose-expr a -
1)
759 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
761 (let ((lhs (math-compose-expr (nth 1 a
) (nth 2 op
))))
764 (if (or (> (length (car op
)) 1)
765 (not (math-comp-is-flat lhs
)))
766 (concat " " (car op
))
768 ((and op
(= (length a
) 2) (= (nth 2 op
) -
1))
771 (let ((lr (and (eq calc-language
'tex
)
772 (not (math-tex-expr-is-flat (nth 1 a
))))))
775 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op
))
776 (substring (car op
) 1)
778 (if (or lr
(> (length (car op
)) 2)) " " "")
779 (math-compose-expr (nth 1 a
) -
1)
780 (if (or lr
(> (length (car op
)) 2)) " " "")
782 (car (nth 1 (memq op math-expr-opers
))))))
783 ((> prec
(or (nth 4 op
) (nth 3 op
)))
784 (if (and (eq calc-language
'tex
)
785 (not (math-tex-expr-is-flat a
)))
786 (list 'horiz
"\\left( "
787 (math-compose-expr a -
1)
789 (if (eq calc-language
'eqn
)
790 (if (= (/ prec
100) 9)
791 (list 'horiz
"{" (math-compose-expr a -
1) "}")
792 (if (math-tex-expr-is-flat a
)
793 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
794 (list 'horiz
"{left ( "
795 (math-compose-expr a -
1)
797 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
799 (let ((rhs (math-compose-expr (nth 1 a
) (nth 3 op
))))
801 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
803 (substring (car op
) 1)
805 (if (or (> (length ops
) 1)
806 (not (math-comp-is-flat rhs
)))
810 ((and (eq calc-language
'big
)
811 (setq op
(get (car a
) 'math-compose-big
))
812 (funcall op a prec
)))
813 ((and (setq op
(assq calc-language
814 '( ( nil . math-compose-normal
)
815 ( flat . math-compose-normal
)
816 ( big . math-compose-normal
)
817 ( c . math-compose-c
)
818 ( pascal . math-compose-pascal
)
819 ( fortran . math-compose-fortran
)
820 ( tex . math-compose-tex
)
821 ( eqn . math-compose-eqn
)
822 ( math . math-compose-math
)
823 ( maple . math-compose-maple
))))
824 (setq op
(get (car a
) (cdr op
)))
825 (funcall op a prec
)))
827 (let* ((func (car a
))
828 (func2 (assq func
'(( mod . calcFunc-makemod
)
829 ( sdev . calcFunc-sdev
)
836 ( neg . calcFunc-neg
)
837 ( | . calcFunc-vconcat
))))
840 (setq func
(cdr func2
)))
841 (if (setq func2
(rassq func math-expr-function-mapping
))
842 (setq func
(car func2
)))
843 (setq func
(math-remove-dashes
845 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
847 (math-match-substring (symbol-name func
) 1)
848 (symbol-name func
))))
849 (if (memq calc-language
'(c fortran pascal maple
))
850 (setq func
(math-to-underscores func
)))
851 (if (and (eq calc-language
'tex
)
853 (not (= calc-language-option
0))
854 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func
))
855 (if (< (prefix-numeric-value calc-language-option
) 0)
856 (setq func
(format "\\%s" func
))
857 (setq func
(format "\\hbox{%s}" func
))))
858 (if (and (eq calc-language
'eqn
)
859 (string-match "[^']'+\\'" func
))
860 (let ((n (- (length func
) (match-beginning 0) 1)))
861 (setq func
(substring func
0 (- n
)))
862 (while (>= (setq n
(1- n
)) 0)
863 (setq func
(concat func
" prime")))))
864 (cond ((and (eq calc-language
'tex
)
866 (not (math-tex-expr-is-flat (nth 1 a
)))))
867 (setq left
"\\left( "
869 ((and (eq calc-language
'eqn
)
871 (not (math-tex-expr-is-flat (nth 1 a
)))))
872 (setq left
"{left ( "
874 ((and (or (and (eq calc-language
'tex
)
875 (eq (aref func
0) ?
\\))
876 (and (eq calc-language
'eqn
)
877 (memq (car a
) math-eqn-special-funcs
)))
878 (not (string-match "\\hbox{" func
))
880 (or (Math-realp (nth 1 a
))
881 (memq (car (nth 1 a
)) '(var *))))
882 (setq left
(if (eq calc-language
'eqn
) "~{" "{")
884 ((eq calc-language
'eqn
)
887 (t (setq left calc-function-open
888 right calc-function-close
)))
889 (list 'horiz func left
890 (math-compose-vector (cdr a
)
891 (if (eq calc-language
'eqn
)
897 (defun math-prod-first-term (x)
898 (while (eq (car-safe x
) '*)
902 (defun math-prod-last-term (x)
903 (while (eq (car-safe x
) '*)
907 (defun math-compose-vector (a sep prec
)
910 (cons (list 'set math-compose-level
)
911 (let ((c (list (math-compose-expr (car a
) prec
))))
912 (while (setq a
(cdr a
))
913 (setq c
(cons (if (eq (car-safe (car a
))
915 (let ((math-compose-level
916 (1- math-compose-level
)))
917 (math-compose-expr (car a
) -
123))
918 (math-compose-expr (car a
) prec
))
919 (cons (list 'break math-compose-level
)
924 (defun math-vector-no-parens (a)
926 (not (eq (car-safe (nth 1 a
)) '*))))
928 (defun math-compose-matrix (a col cols base
)
931 (while (<= (setq col
(1+ col
)) cols
)
932 (setq res
(cons (cons just
942 (concat comma-spc
" ")))))
947 (defun math-compose-rows (a count first
)
951 (math-compose-rows (cdr a
) -
1 nil
)
952 (cons (concat (if (eq calc-language
'tex
) " \\ldots" " ...")
954 (math-compose-rows (cdr a
) -
1 nil
)))
956 (if first
(concat left-bracket
" ") " ")
957 (math-compose-expr (car a
) vector-prec
)
959 (math-compose-rows (cdr a
) (1- count
) nil
)))
961 (if first
(concat left-bracket
" ") " ")
962 (math-compose-expr (car a
) vector-prec
)
963 (concat " " right-bracket
)))))
965 (defun math-compose-tex-matrix (a)
967 (cons (math-compose-vector (cdr (car a
)) " & " 0)
969 (math-compose-tex-matrix (cdr a
))))
970 (list (math-compose-vector (cdr (car a
)) " & " 0))))
972 (defun math-compose-eqn-matrix (a)
975 (cond ((eq calc-matrix-just
'right
) "rcol ")
976 ((eq calc-matrix-just
'center
) "ccol ")
979 (list 'break math-compose-level
)
983 (let ((math-compose-level (1+ math-compose-level
)))
984 (math-compose-vector (cdr (car a
)) " above " 1000))
987 (math-compose-eqn-matrix (cdr a
)))))))
990 (defun math-vector-is-string (a)
991 (while (and (setq a
(cdr a
))
992 (or (and (natnump (car a
))
994 (and (eq (car-safe (car a
)) 'cplx
)
995 (natnump (nth 1 (car a
)))
996 (eq (nth 2 (car a
)) 0)
997 (<= (nth 1 (car a
)) 255)))))
1000 (defconst math-vector-to-string-chars
'( ( ?
\" .
"\\\"" )
1011 (defun math-vector-to-string (a &optional quoted
)
1012 (setq a
(concat (mapcar (function (lambda (x) (if (consp x
) (nth 1 x
) x
)))
1014 (if (string-match "[\000-\037\177\\\"]" a
)
1016 (pat (if quoted
"[\000-\037\177\\\"]" "[\000-\037\177]"))
1017 (codes (if quoted math-vector-to-string-chars
'((?\^? .
"^?"))))
1018 (fmt (if quoted
"\\^%c" "^%c"))
1020 (while (setq p
(string-match pat a p
))
1021 (if (setq new
(assq (aref a p
) codes
))
1022 (setq a
(concat (substring a
0 p
)
1024 (substring a
(1+ p
)))
1025 p
(+ p
(length (cdr new
))))
1026 (setq a
(concat (substring a
0 p
)
1027 (format fmt
(+ (aref a p
) 64))
1028 (substring a
(1+ p
)))
1031 (concat "\"" a
"\"")
1035 (defun math-to-underscores (x)
1036 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x
)
1037 (math-to-underscores
1038 (concat (math-match-substring x
1) "_" (math-match-substring x
2)))
1041 (defun math-tex-expr-is-flat (a)
1042 (or (Math-integerp a
)
1043 (memq (car a
) '(float var
))
1044 (and (memq (car a
) '(+ -
* neg
))
1046 (while (and (setq a
(cdr a
))
1047 (math-tex-expr-is-flat (car a
))))
1049 (and (memq (car a
) '(^ calcFunc-subscr
))
1050 (math-tex-expr-is-flat (nth 1 a
)))))
1052 (put 'calcFunc-log
'math-compose-big
'math-compose-log
)
1053 (defun math-compose-log (a prec
)
1054 (and (= (length a
) 3)
1057 (let ((calc-language 'flat
))
1058 (math-compose-expr (nth 2 a
) 1000)))
1060 (math-compose-expr (nth 1 a
) 1000)
1063 (put 'calcFunc-log10
'math-compose-big
'math-compose-log10
)
1064 (defun math-compose-log10 (a prec
)
1065 (and (= (length a
) 2)
1067 (list 'subscr
"log" "10")
1069 (math-compose-expr (nth 1 a
) 1000)
1072 (put 'calcFunc-deriv
'math-compose-big
'math-compose-deriv
)
1073 (put 'calcFunc-tderiv
'math-compose-big
'math-compose-deriv
)
1074 (defun math-compose-deriv (a prec
)
1075 (when (= (length a
) 3)
1076 (math-compose-expr (list '/
1077 (list 'calcFunc-choriz
1079 '(calcFunc-string (vec ?d
))
1081 (list 'calcFunc-choriz
1083 '(calcFunc-string (vec ?d
))
1087 (put 'calcFunc-sqrt
'math-compose-big
'math-compose-sqrt
)
1088 (defun math-compose-sqrt (a prec
)
1089 (when (= (length a
) 2)
1090 (let* ((c (math-compose-expr (nth 1 a
) 0))
1091 (a (math-comp-ascent c
))
1092 (d (math-comp-descent c
))
1094 (w (math-comp-width c
)))
1097 (concat (if (= h
1) " " " ")
1098 (make-string (+ w
2) ?\_
))
1102 (append (list 'vleft
(1- a
))
1103 (make-list (1- h
) " |")
1108 (put 'calcFunc-choose
'math-compose-big
'math-compose-choose
)
1109 (defun math-compose-choose (a prec
)
1110 (let ((a1 (math-compose-expr (nth 1 a
) 0))
1111 (a2 (math-compose-expr (nth 2 a
) 0)))
1115 (math-comp-height a1
)
1119 (put 'calcFunc-integ
'math-compose-big
'math-compose-integ
)
1120 (defun math-compose-integ (a prec
)
1121 (and (memq (length a
) '(3 5))
1122 (eq (car-safe (nth 2 a
)) 'var
)
1123 (let* ((parens (and (>= prec
196) (/= prec
1000)))
1124 (var (math-compose-expr (nth 2 a
) 0))
1125 (over (and (eq (car-safe (nth 2 a
)) 'var
)
1126 (or (and (eq (car-safe (nth 1 a
)) '/)
1127 (math-numberp (nth 1 (nth 1 a
))))
1128 (and (eq (car-safe (nth 1 a
)) '^
)
1129 (math-looks-negp (nth 2 (nth 1 a
)))))))
1130 (expr (math-compose-expr (if over
1132 (math-build-var-name
1135 (nth 1 (nth 2 a
)))))
1137 (calc-language 'flat
)
1138 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1139 (high (and (nth 4 a
) (math-compose-expr (nth 4 a
) 0))))
1142 (append (list 'vcent
(if high
3 2))
1143 (and high
(list (list 'horiz
" " high
)))
1149 (and low
(list (list 'horiz low
" "))))
1153 (list 'horiz
" d" var
))
1154 (if parens
")" "")))))
1156 (put 'calcFunc-sum
'math-compose-big
'math-compose-sum
)
1157 (defun math-compose-sum (a prec
)
1158 (and (memq (length a
) '(3 5 6))
1159 (let* ((expr (math-compose-expr (nth 1 a
) 185))
1160 (calc-language 'flat
)
1161 (var (math-compose-expr (nth 2 a
) 0))
1162 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1163 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1165 (if (memq prec
'(180 201)) "(" "")
1166 (append (list 'vcent
(if high
3 2))
1167 (and high
(list high
))
1174 (list (list 'horiz var
" = " low
))
1176 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1179 (if (memq prec
'(180 201)) ")" "")))))
1181 (put 'calcFunc-prod
'math-compose-big
'math-compose-prod
)
1182 (defun math-compose-prod (a prec
)
1183 (and (memq (length a
) '(3 5 6))
1184 (let* ((expr (math-compose-expr (nth 1 a
) 198))
1185 (calc-language 'flat
)
1186 (var (math-compose-expr (nth 2 a
) 0))
1187 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1188 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1190 (if (memq prec
'(196 201)) "(" "")
1191 (append (list 'vcent
(if high
3 2))
1192 (and high
(list high
))
1198 (list (list 'horiz var
" = " low
))
1200 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1203 (if (memq prec
'(196 201)) ")" "")))))
1206 (defun math-stack-value-offset-fancy ()
1207 (let ((cwid (+ (math-comp-width c
))))
1208 (cond ((eq calc-display-just
'right
)
1209 (if calc-display-origin
1210 (setq wid
(max calc-display-origin
5))
1211 (if (integerp calc-line-breaking
)
1212 (setq wid calc-line-breaking
)))
1213 (setq off
(- wid cwid
1214 (max (- (length calc-right-label
)
1215 (if (and (integerp calc-line-breaking
)
1216 calc-display-origin
)
1217 (max (- calc-line-breaking
1218 calc-display-origin
)
1223 (if calc-display-origin
1225 (setq off
(- calc-display-origin
(/ cwid
2)))
1226 (if (integerp calc-line-breaking
)
1227 (setq off
(min off
(- calc-line-breaking cwid
1228 (length calc-right-label
)))))
1230 (setq wid
(max wid
(+ off cwid
)))))
1231 (if (integerp calc-line-breaking
)
1232 (setq wid calc-line-breaking
))
1233 (setq off
(/ (- wid cwid
) 2)))))
1234 (and (integerp calc-line-breaking
)
1236 (and calc-display-origin
1237 (> calc-line-breaking calc-display-origin
)))
1238 (setq wid calc-line-breaking
))))
1242 ;;; Convert a composition to string form, with embedded \n's if necessary.
1244 (defun math-composition-to-string (c &optional width
)
1245 (or width
(setq width
(calc-window-width)))
1246 (if calc-display-raw
1247 (math-comp-to-string-raw c
0)
1248 (if (math-comp-is-flat c
)
1249 (math-comp-to-string-flat c width
)
1250 (math-vert-comp-to-string
1251 (math-comp-simplify c width
)))))
1253 (defvar math-comp-buf-string
(make-vector 10 ""))
1254 (defvar math-comp-buf-margin
(make-vector 10 0))
1255 (defvar math-comp-buf-level
(make-vector 10 0))
1256 (defun math-comp-is-flat (c) ; check if c's height is 1.
1257 (cond ((not (consp c
)) t
)
1258 ((memq (car c
) '(set break
)) t
)
1259 ((eq (car c
) 'horiz
)
1260 (while (and (setq c
(cdr c
))
1261 (math-comp-is-flat (car c
))))
1263 ((memq (car c
) '(vleft vcent vright
))
1264 (and (= (length c
) 3)
1266 (math-comp-is-flat (nth 2 c
))))
1268 (math-comp-is-flat (nth 2 c
)))
1272 ;;; Convert a one-line composition to a string. Break into multiple
1273 ;;; lines if necessary, choosing break points according to the structure
1276 (defun math-comp-to-string-flat (c full-width
)
1277 (if math-comp-sel-hpos
1279 (math-comp-sel-flat-term c
))
1284 (comp-highlight (and math-comp-selected calc-show-selections
))
1286 (math-comp-to-string-flat-term '(set -
1 0))
1287 (math-comp-to-string-flat-term c
)
1288 (math-comp-to-string-flat-term '(break -
1))
1289 (let ((str (aref math-comp-buf-string
0))
1291 (and (> (length str
) 0) (= (aref str
0) ?
)
1292 (> (length comp-buf
) 0)
1293 (let ((k (length comp-buf
)))
1294 (while (not (= (aref comp-buf
(setq k
(1- k
))) ?
\n)))
1295 (aset comp-buf k ?
)
1296 (if (and (< (1+ k
) (length comp-buf
))
1297 (= (aref comp-buf
(1+ k
)) ?
))
1299 (aset comp-buf
(1+ k
) ?
\n)
1301 (setq prefix
"\n"))))
1302 (concat comp-buf prefix str
)))))
1304 (defun math-comp-to-string-flat-term (c)
1305 (cond ((not (consp c
))
1307 (setq c
(math-comp-highlight-string c
)))
1308 (setq comp-word
(if (= (length comp-word
) 0) c
(concat comp-word c
))
1309 comp-pos
(+ comp-pos
(length c
))))
1311 ((eq (car c
) 'horiz
)
1312 (while (setq c
(cdr c
))
1313 (math-comp-to-string-flat-term (car c
))))
1318 (setq comp-level
(1+ comp-level
))
1319 (if (>= comp-level
(length math-comp-buf-string
))
1320 (setq math-comp-buf-string
(vconcat math-comp-buf-string
1321 math-comp-buf-string
)
1322 math-comp-buf-margin
(vconcat math-comp-buf-margin
1323 math-comp-buf-margin
)
1324 math-comp-buf-level
(vconcat math-comp-buf-level
1325 math-comp-buf-level
)))
1326 (aset math-comp-buf-string comp-level
"")
1327 (aset math-comp-buf-margin comp-level
(+ comp-pos
1329 (aset math-comp-buf-level comp-level
(nth 1 c
)))))
1331 ((eq (car c
) 'break
)
1332 (if (not calc-line-breaking
)
1333 (setq comp-buf
(concat comp-buf comp-word
)
1336 (if (and (> comp-pos full-width
)
1339 (setq str
(aref math-comp-buf-string i
))
1340 (and (= (length str
) 0) (< i comp-level
)))
1342 (or (> (length str
) 0) (> (length comp-buf
) 0))))
1343 (let ((prefix "") mrg wid
)
1344 (setq mrg
(aref math-comp-buf-margin i
))
1345 (if (> mrg
12) ; indenting too far, go back to far left
1346 (let ((j i
) (new (if calc-line-numbering
5 1)))
1347 '(while (<= j comp-level
)
1348 (aset math-comp-buf-margin j
1349 (+ (aref math-comp-buf-margin j
) (- new mrg
)))
1352 (setq wid
(+ (length str
) comp-margin
))
1353 (and (> (length str
) 0) (= (aref str
0) ?
)
1354 (> (length comp-buf
) 0)
1355 (let ((k (length comp-buf
)))
1356 (while (not (= (aref comp-buf
(setq k
(1- k
))) ?
\n)))
1357 (aset comp-buf k ?
)
1358 (if (and (< (1+ k
) (length comp-buf
))
1359 (= (aref comp-buf
(1+ k
)) ?
))
1361 (aset comp-buf
(1+ k
) ?
\n)
1363 (setq prefix
"\n"))))
1364 (setq comp-buf
(concat comp-buf prefix str
"\n"
1365 (make-string mrg ?
))
1366 comp-pos
(+ comp-pos
(- mrg wid
))
1368 (aset math-comp-buf-string i
"")
1369 (while (<= (setq i
(1+ i
)) comp-level
)
1370 (if (> (aref math-comp-buf-margin i
) wid
)
1371 (aset math-comp-buf-margin i
1372 (+ (aref math-comp-buf-margin i
)
1374 (if (and (= (nth 1 c
) (aref math-comp-buf-level comp-level
))
1375 (< comp-pos
(+ (aref math-comp-buf-margin comp-level
) 2)))
1376 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1377 (let ((str (aref math-comp-buf-string comp-level
)))
1378 (setq str
(if (= (length str
) 0)
1380 (concat str comp-word
))
1382 (while (< (nth 1 c
) (aref math-comp-buf-level comp-level
))
1383 (setq comp-level
(1- comp-level
))
1384 (or (= (length (aref math-comp-buf-string comp-level
)) 0)
1385 (setq str
(concat (aref math-comp-buf-string comp-level
)
1387 (aset math-comp-buf-string comp-level str
)))))
1390 (cond ((eq (nth 1 c
) math-comp-selected
)
1391 (let ((comp-highlight (not calc-show-selections
)))
1392 (math-comp-to-string-flat-term (nth 2 c
))))
1394 (let ((comp-highlight nil
))
1395 (math-comp-to-string-flat-term (nth 2 c
))))
1396 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1398 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1400 (defun math-comp-highlight-string (s)
1401 (setq s
(copy-sequence s
))
1402 (let ((i (length s
)))
1403 (while (>= (setq i
(1- i
)) 0)
1404 (or (memq (aref s i
) '(32 ?
\n))
1405 (aset s i
(if calc-show-selections ?\. ?\
#)))))
1408 (defun math-comp-sel-flat-term (c)
1409 (cond ((not (consp c
))
1410 (setq comp-pos
(+ comp-pos
(length c
))))
1411 ((memq (car c
) '(set break
)))
1412 ((eq (car c
) 'horiz
)
1413 (while (and (setq c
(cdr c
)) (< math-comp-sel-cpos
1000000))
1414 (math-comp-sel-flat-term (car c
))))
1416 (if (<= comp-pos math-comp-sel-cpos
)
1418 (math-comp-sel-flat-term (nth 2 c
))
1419 (if (> comp-pos math-comp-sel-cpos
)
1420 (setq math-comp-sel-tag c
1421 math-comp-sel-cpos
1000000)))
1422 (math-comp-sel-flat-term (nth 2 c
))))
1423 (t (math-comp-sel-flat-term (nth 2 c
)))))
1426 ;;; Simplify a composition to a canonical form consisting of
1427 ;;; (vleft n "string" "string" "string" ...)
1428 ;;; where 0 <= n < number-of-strings.
1430 (defun math-comp-simplify (c full-width
)
1431 (let ((comp-buf (list ""))
1436 (comp-highlight (and math-comp-selected calc-show-selections
))
1438 (math-comp-simplify-term c
)
1439 (cons 'vleft
(cons comp-base comp-buf
))))
1441 (defun math-comp-add-string (s h v
)
1442 (and (> (length s
) 0)
1443 (let ((vv (+ v comp-base
)))
1444 (if math-comp-sel-hpos
1445 (math-comp-add-string-sel h vv
(length s
) 1)
1447 (setq comp-buf
(nconc (make-list (- vv
) "") comp-buf
)
1449 comp-height
(- comp-height vv
)
1451 (if (>= vv comp-height
)
1452 (setq comp-buf
(nconc comp-buf
1453 (make-list (1+ (- vv comp-height
)) ""))
1454 comp-height
(1+ vv
))))
1455 (let ((str (nthcdr vv comp-buf
)))
1456 (setcar str
(concat (car str
)
1457 (make-string (- h
(length (car str
))) 32)
1459 (math-comp-highlight-string s
)
1462 (defun math-comp-add-string-sel (x y w h
)
1463 (if (and (<= y math-comp-sel-vpos
)
1464 (> (+ y h
) math-comp-sel-vpos
)
1465 (<= x math-comp-sel-hpos
)
1466 (> (+ x w
) math-comp-sel-hpos
))
1467 (setq math-comp-sel-tag comp-tag
1468 math-comp-sel-vpos
10000)))
1470 (defun math-comp-simplify-term (c)
1472 (math-comp-add-string c comp-hpos comp-vpos
)
1473 (setq comp-hpos
(+ comp-hpos
(length c
))))
1474 ((memq (car c
) '(set break
))
1476 ((eq (car c
) 'horiz
)
1477 (while (setq c
(cdr c
))
1478 (math-comp-simplify-term (car c
))))
1479 ((memq (car c
) '(vleft vcent vright
))
1480 (let* ((comp-vpos (+ (- comp-vpos
(nth 1 c
))
1481 (1- (math-comp-ascent (nth 2 c
)))))
1482 (widths (mapcar 'math-comp-width
(cdr (cdr c
))))
1483 (maxwid (apply 'max widths
))
1484 (bias (cond ((eq (car c
) 'vleft
) 0)
1485 ((eq (car c
) 'vcent
) 1)
1488 (while (setq c
(cdr c
))
1489 (if (eq (car-safe (car c
)) 'rule
)
1490 (math-comp-add-string (make-string maxwid
(nth 1 (car c
)))
1491 comp-hpos comp-vpos
)
1492 (let ((comp-hpos (+ comp-hpos
(/ (* bias
(- maxwid
1495 (math-comp-simplify-term (car c
))))
1497 (setq comp-vpos
(+ comp-vpos
1498 (+ (math-comp-descent (car c
))
1499 (math-comp-ascent (nth 1 c
))))
1500 widths
(cdr widths
))))
1501 (setq comp-hpos
(+ comp-hpos maxwid
))))
1502 ((eq (car c
) 'supscr
)
1503 (let* ((asc (or 1 (math-comp-ascent (nth 1 c
))))
1504 (desc (math-comp-descent (nth 2 c
)))
1507 (math-comp-simplify-term (nth 1 c
))))
1508 (comp-vpos (- comp-vpos
(+ asc desc
))))
1509 (math-comp-simplify-term (nth 2 c
))
1510 (if math-comp-sel-hpos
1511 (math-comp-add-string-sel oldh
1514 (math-comp-ascent (nth 2 c
)))
1516 (math-comp-height c
)))))
1517 ((eq (car c
) 'subscr
)
1518 (let* ((asc (math-comp-ascent (nth 2 c
)))
1519 (desc (math-comp-descent (nth 1 c
)))
1523 (math-comp-simplify-term (nth 1 c
))))
1524 (comp-vpos (+ comp-vpos
(+ asc desc
))))
1525 (math-comp-simplify-term (nth 2 c
))
1526 (if math-comp-sel-hpos
1527 (math-comp-add-string-sel oldh oldv
1529 (math-comp-height c
)))))
1531 (cond ((eq (nth 1 c
) math-comp-selected
)
1532 (let ((comp-highlight (not calc-show-selections
)))
1533 (math-comp-simplify-term (nth 2 c
))))
1535 (let ((comp-highlight nil
))
1536 (math-comp-simplify-term (nth 2 c
))))
1537 (t (let ((comp-tag c
))
1538 (math-comp-simplify-term (nth 2 c
))))))))
1541 ;;; Measuring a composition.
1543 (defun math-comp-first-char (c)
1545 (and (> (length c
) 0)
1547 ((memq (car c
) '(horiz subscr supscr
))
1548 (while (and (setq c
(cdr c
))
1549 (math-comp-is-null (car c
))))
1550 (and c
(math-comp-first-char (car c
))))
1552 (math-comp-first-char (nth 2 c
)))))
1554 (defun math-comp-first-string (c)
1556 (and (> (length c
) 0)
1558 ((eq (car c
) 'horiz
)
1559 (while (and (setq c
(cdr c
))
1560 (math-comp-is-null (car c
))))
1561 (and c
(math-comp-first-string (car c
))))
1563 (math-comp-first-string (nth 2 c
)))))
1565 (defun math-comp-last-char (c)
1567 (and (> (length c
) 0)
1568 (elt c
(1- (length c
)))))
1569 ((eq (car c
) 'horiz
)
1570 (let ((c (reverse (cdr c
))))
1571 (while (and c
(math-comp-is-null (car c
)))
1573 (and c
(math-comp-last-char (car c
)))))
1575 (math-comp-last-char (nth 2 c
)))))
1577 (defun math-comp-is-null (c)
1578 (cond ((stringp c
) (= (length c
) 0))
1579 ((memq (car c
) '(horiz subscr supscr
))
1580 (while (and (setq c
(cdr c
))
1581 (math-comp-is-null (car c
))))
1584 (math-comp-is-null (nth 2 c
)))
1585 ((memq (car c
) '(set break
)) t
)))
1587 (defun math-comp-width (c)
1588 (cond ((not (consp c
)) (length c
))
1589 ((memq (car c
) '(horiz subscr supscr
))
1591 (while (setq c
(cdr c
))
1592 (setq accum
(+ accum
(math-comp-width (car c
)))))
1594 ((memq (car c
) '(vcent vleft vright
))
1597 (while (setq c
(cdr c
))
1598 (setq accum
(max accum
(math-comp-width (car c
)))))
1601 (math-comp-width (nth 2 c
)))
1604 (defun math-comp-height (c)
1607 (+ (math-comp-ascent c
) (math-comp-descent c
))))
1609 (defun math-comp-ascent (c)
1610 (cond ((not (consp c
)) 1)
1611 ((eq (car c
) 'horiz
)
1613 (while (setq c
(cdr c
))
1614 (setq accum
(max accum
(math-comp-ascent (car c
)))))
1616 ((memq (car c
) '(vcent vleft vright
))
1617 (if (> (nth 1 c
) 0) (1+ (nth 1 c
)) 1))
1618 ((eq (car c
) 'supscr
)
1619 (max (math-comp-ascent (nth 1 c
)) (1+ (math-comp-height (nth 2 c
)))))
1620 ((eq (car c
) 'subscr
)
1621 (math-comp-ascent (nth 1 c
)))
1623 (math-comp-ascent (nth 2 c
)))
1626 (defun math-comp-descent (c)
1627 (cond ((not (consp c
)) 0)
1628 ((eq (car c
) 'horiz
)
1630 (while (setq c
(cdr c
))
1631 (setq accum
(max accum
(math-comp-descent (car c
)))))
1633 ((memq (car c
) '(vcent vleft vright
))
1634 (let ((accum (- (nth 1 c
))))
1636 (while (setq c
(cdr c
))
1637 (setq accum
(+ accum
(math-comp-height (car c
)))))
1638 (max (1- accum
) 0)))
1639 ((eq (car c
) 'supscr
)
1640 (math-comp-descent (nth 1 c
)))
1641 ((eq (car c
) 'subscr
)
1642 (+ (math-comp-descent (nth 1 c
)) (math-comp-height (nth 2 c
))))
1644 (math-comp-descent (nth 2 c
)))
1647 (defun calcFunc-cwidth (a &optional prec
)
1648 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1649 (math-comp-width (math-compose-expr a
(or prec
0))))
1651 (defun calcFunc-cheight (a &optional prec
)
1652 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1653 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1654 (memq (length a
) '(2 3))
1657 (math-comp-height (math-compose-expr a
(or prec
0)))))
1659 (defun calcFunc-cascent (a &optional prec
)
1660 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1661 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1662 (memq (length a
) '(2 3))
1665 (math-comp-ascent (math-compose-expr a
(or prec
0)))))
1667 (defun calcFunc-cdescent (a &optional prec
)
1668 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1669 (math-comp-descent (math-compose-expr a
(or prec
0))))
1672 ;;; Convert a simplified composition into string form.
1674 (defun math-vert-comp-to-string (c)
1677 (math-vert-comp-to-string-step (cdr (cdr c
)))))
1679 (defun math-vert-comp-to-string-step (c)
1681 (concat (car c
) "\n" (math-vert-comp-to-string-step (cdr c
)))
1685 ;;; Convert a composition to a string in "raw" form (for debugging).
1687 (defun math-comp-to-string-raw (c indent
)
1688 (cond ((or (not (consp c
)) (eq (car c
) 'set
))
1689 (prin1-to-string c
))
1691 (concat "(" (symbol-name (car c
)) ")"))
1693 (let ((next-indent (+ indent
2 (length (symbol-name (car c
))))))
1695 (symbol-name (car c
))
1697 (math-comp-to-string-raw (nth 1 c
) next-indent
)
1698 (math-comp-to-string-raw-step (cdr (cdr c
))
1702 (defun math-comp-to-string-raw-step (cl indent
)
1705 (make-string indent
32)
1706 (math-comp-to-string-raw (car cl
) indent
)
1707 (math-comp-to-string-raw-step (cdr cl
) indent
))
1710 ;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1711 ;;; calccomp.el ends here