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 ;; Maintainer: Colin Walters <walters@debian.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
34 (defun calc-Need-calc-comp () nil
)
36 (defconst math-eqn-special-funcs
38 calcFunc-ln calcFunc-exp
39 calcFunc-sin calcFunc-cos calcFunc-tan
40 calcFunc-sinh calcFunc-cosh calcFunc-tanh
41 calcFunc-arcsin calcFunc-arccos calcFunc-arctan
42 calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
))
44 ;;; A "composition" has one of the following forms:
46 ;;; "string" A literal string
48 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
50 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
51 ;;; (break LEVEL) A potential line-break point
53 ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
54 ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
55 ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
56 ;;; N specifies baseline of the stack, 0=top line.
58 ;;; (supscr C1 C2) Composition C1 with superscript C2
59 ;;; (subscr C1 C2) Composition C1 with subscript C2
60 ;;; (rule X) Horizontal line of X, full width of enclosing comp
62 ;;; (tag X C) Composition C corresponds to sub-expression X
64 (defun math-compose-expr (a prec
)
65 (let ((math-compose-level (1+ math-compose-level
)))
67 ((or (and (eq a math-comp-selected
) a
)
69 (not (eq math-comp-tagged a
))))
70 (let ((math-comp-selected nil
))
71 (and math-comp-tagged
(setq math-comp-tagged a
))
72 (list 'tag a
(math-compose-expr a prec
))))
73 ((and (not (consp a
)) (not (integerp a
)))
74 (concat "'" (prin1-to-string a
)))
76 (if (or (eq (car-safe a
) 'frac
)
77 (and (nth 1 calc-frac-format
) (Math-integerp a
)))
78 (if (memq calc-language
'(tex eqn math maple c fortran pascal
))
79 (let ((aa (math-adjust-fraction a
))
80 (calc-frac-format nil
))
81 (math-compose-expr (list '/
82 (if (memq calc-language
'(c fortran
))
83 (math-float (nth 1 aa
))
86 (if (and (eq calc-language
'big
)
87 (= (length (car calc-frac-format
)) 1))
88 (let* ((aa (math-adjust-fraction a
))
89 (calc-frac-format nil
)
90 (math-radix-explicit-format nil
)
92 (if (math-negp (nth 1 aa
))
96 (math-abs (nth 1 aa
)))
98 (math-format-number (nth 2 aa
))))))
99 (if (= calc-number-radix
10)
103 (int-to-string calc-number-radix
)))))
104 (math-format-number a
)))
105 (if (not (eq calc-language
'big
))
106 (math-format-number a prec
)
107 (if (memq (car-safe a
) '(cplx polar
))
108 (if (math-zerop (nth 2 a
))
109 (math-compose-expr (nth 1 a
) prec
)
111 (math-compose-expr (nth 1 a
) 0)
112 (if (eq (car a
) 'cplx
) ", " "; ")
113 (math-compose-expr (nth 2 a
) 0) ")"))
114 (if (or (= calc-number-radix
10)
116 (and calc-group-digits
117 (not (assoc calc-group-char
'((",") (" "))))))
118 (math-format-number a prec
)
119 (let ((s (math-format-number a prec
))
121 (while (string-match (if (> calc-number-radix
14)
122 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
123 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
125 (setq c
(nconc c
(list (substring s
0 (match-beginning 0))
127 (math-match-substring s
2)
128 (math-match-substring s
1))))
129 s
(substring s
(match-end 0))))
131 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s
)
133 (substring s
0 (match-beginning 0)) " "
135 (math-match-substring s
1)
136 (math-match-substring s
2))
137 (math-match-substring s
3))))
138 (if c
(cons 'horiz
(nconc c
(list s
))) s
)))))))
139 ((and (get (car a
) 'math-compose-forms
)
140 (not (eq calc-language
'unform
))
141 (let ((comps (get (car a
) 'math-compose-forms
))
143 (or (and (setq temp
(assq calc-language comps
))
144 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
145 (setq temp
(apply (cdr temp2
) (cdr a
)))
146 (math-compose-expr temp prec
))
147 (and (setq temp2
(assq nil
(cdr temp
)))
148 (funcall (cdr temp2
) a
))))
149 (and (setq temp
(assq nil comps
))
150 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
151 (setq temp
(apply (cdr temp2
) (cdr a
)))
152 (math-compose-expr temp prec
))
153 (and (setq temp2
(assq nil
(cdr temp
)))
154 (funcall (cdr temp2
) a
))))))))
156 (let* ((left-bracket (if calc-vector-brackets
157 (substring calc-vector-brackets
0 1) ""))
158 (right-bracket (if calc-vector-brackets
159 (substring calc-vector-brackets
1 2) ""))
160 (inner-brackets (memq 'R calc-matrix-brackets
))
161 (outer-brackets (memq 'O calc-matrix-brackets
))
162 (row-commas (memq 'C calc-matrix-brackets
))
163 (comma-spc (or calc-vector-commas
" "))
164 (comma (or calc-vector-commas
""))
165 (vector-prec (if (or (and calc-vector-commas
166 (math-vector-no-parens a
))
167 (memq 'P calc-matrix-brackets
)) 0 1000))
168 (just (cond ((eq calc-matrix-just
'right
) 'vright
)
169 ((eq calc-matrix-just
'center
) 'vcent
)
171 (break calc-break-vectors
))
172 (if (and (memq calc-language
'(nil big
))
173 (not calc-break-vectors
)
174 (math-matrixp a
) (not (math-matrixp (nth 1 a
)))
175 (or calc-full-vectors
176 (and (< (length a
) 7) (< (length (nth 1 a
)) 7))
177 (progn (setq break t
) nil
)))
179 (setq vector-prec
(if (or (and calc-vector-commas
180 (math-vector-no-parens
182 (memq 'P calc-matrix-brackets
))
186 (concat left-bracket left-bracket
" ")
187 (math-compose-vector (cdr (nth 1 a
)) (concat comma
" ")
189 (concat " " right-bracket right-bracket
))
190 (let* ((rows (1- (length a
)))
191 (cols (1- (length (nth 1 a
))))
192 (base (/ (1- rows
) 2))
193 (calc-language 'flat
))
195 (list (append '(vleft)
197 (list (concat (and outer-brackets
204 (concat (and outer-brackets
210 (math-compose-matrix (cdr a
) 1 cols base
)
211 (list (append '(vleft)
219 (if (and outer-brackets
229 right-bracket
)))))))))
230 (if (and calc-display-strings
232 (math-vector-is-string a
))
233 (math-vector-to-string a t
)
234 (if (and break
(cdr a
)
235 (not (eq calc-language
'flat
)))
236 (let* ((full (or calc-full-vectors
(< (length a
) 7)))
237 (rows (if full
(1- (length a
)) 5))
238 (base (/ (1- rows
) 2))
240 (calc-break-vectors nil
))
242 (cons 'vleft
(cons base
245 (if full rows
3) t
)))))
246 (if (or calc-full-vectors
(< (length a
) 7))
247 (if (and (eq calc-language
'tex
)
249 (append '(horiz "\\matrix{ ")
250 (math-compose-tex-matrix (cdr a
))
252 (if (and (eq calc-language
'eqn
)
254 (append '(horiz "matrix { ")
255 (math-compose-eqn-matrix
256 (cdr (math-transpose a
)))
258 (if (and (eq calc-language
'maple
)
263 (math-compose-vector (cdr a
) (concat comma
" ")
269 (math-compose-vector (cdr a
) (concat comma
" ")
274 (math-compose-vector (list (nth 1 a
) (nth 2 a
) (nth 3 a
))
275 (concat comma
" ") vector-prec
)
276 comma
(if (eq calc-language
'tex
) " \\ldots" " ...")
278 (list 'break math-compose-level
)
279 (math-compose-expr (nth (1- (length a
)) a
)
280 (if (equal comma
"") 1000 0))
282 ((eq (car a
) 'incomplete
)
284 (cond ((eq (nth 1 a
) 'vec
)
286 (math-compose-vector (cdr (cdr a
)) ", " 0)
288 ((eq (nth 1 a
) 'cplx
)
290 (math-compose-vector (cdr (cdr a
)) ", " 0)
292 ((eq (nth 1 a
) 'polar
)
294 (math-compose-vector (cdr (cdr a
)) "; " 0)
296 ((eq (nth 1 a
) 'intv
)
298 (if (memq (nth 2 a
) '(0 1)) "(" "[")
299 (math-compose-vector (cdr (cdr (cdr a
))) " .. " 0)
302 (cond ((eq (nth 1 a
) 'vec
) "[ ...")
303 ((eq (nth 1 a
) 'intv
)
304 (if (memq (nth 2 a
) '(0 1)) "( ..." "[ ..."))
307 (let ((v (rassq (nth 2 a
) math-expr-variable-mapping
)))
309 (symbol-name (car v
))
310 (if (and (eq calc-language
'tex
)
312 (not (= calc-language-option
0))
313 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
314 (symbol-name (nth 1 a
))))
315 (format "\\hbox{%s}" (symbol-name (nth 1 a
)))
316 (if (and math-compose-hash-args
317 (let ((p calc-arg-values
))
319 (while (and p
(not (equal (car p
) a
)))
320 (setq p
(and (eq math-compose-hash-args t
) (cdr p
))
323 (if (eq math-compose-hash-args
1)
326 (if (memq calc-language
'(c fortran pascal maple
))
327 (math-to-underscores (symbol-name (nth 1 a
)))
328 (if (and (eq calc-language
'eqn
)
329 (string-match ".'\\'" (symbol-name (nth 2 a
))))
331 (list 'calcFunc-Prime
334 (intern (substring (symbol-name (nth 1 a
)) 0 -
1))
335 (intern (substring (symbol-name (nth 2 a
)) 0 -
1))))
337 (symbol-name (nth 1 a
)))))))))
340 (if (eq calc-language
'maple
) ""
341 (if (memq (nth 1 a
) '(0 1)) "(" "["))
342 (math-compose-expr (nth 2 a
) 0)
343 (if (eq calc-language
'tex
) " \\ldots "
344 (if (eq calc-language
'eqn
) " ... " " .. "))
345 (math-compose-expr (nth 3 a
) 0)
346 (if (eq calc-language
'maple
) ""
347 (if (memq (nth 1 a
) '(0 2)) ")" "]"))))
349 (if (eq (car calc-date-format
) 'X
)
351 (concat "<" (math-format-date a
) ">")))
352 ((and (eq (car a
) 'calcFunc-subscr
) (cdr (cdr a
))
353 (memq calc-language
'(c pascal fortran maple
)))
354 (let ((args (cdr (cdr a
))))
355 (while (and (memq calc-language
'(pascal fortran
))
356 (eq (car-safe (nth 1 a
)) 'calcFunc-subscr
))
357 (setq args
(append (cdr (cdr (nth 1 a
))) args
)
360 (math-compose-expr (nth 1 a
) 1000)
361 (if (eq calc-language
'fortran
) "(" "[")
362 (math-compose-vector args
", " 0)
363 (if (eq calc-language
'fortran
) ")" "]"))))
364 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
365 (eq calc-language
'big
))
366 (let* ((a1 (math-compose-expr (nth 1 a
) 1000))
367 (calc-language 'flat
)
368 (a2 (math-compose-expr (nth 2 a
) 0)))
369 (if (or (eq (car-safe a1
) 'subscr
)
370 (and (eq (car-safe a1
) 'tag
)
371 (eq (car-safe (nth 2 a1
)) 'subscr
)
372 (setq a1
(nth 2 a1
))))
379 (list 'subscr a1 a2
))))
380 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
381 (eq calc-language
'math
))
383 (math-compose-expr (nth 1 a
) 1000)
385 (math-compose-expr (nth 2 a
) 0)
387 ((and (eq (car a
) 'calcFunc-sqrt
)
388 (eq calc-language
'tex
))
391 (math-compose-expr (nth 1 a
) 0)
393 ((and nil
(eq (car a
) 'calcFunc-sqrt
)
394 (eq calc-language
'eqn
))
397 (math-compose-expr (nth 1 a
) -
1)
399 ((and (eq (car a
) '^
)
400 (eq calc-language
'big
))
402 (if (or (math-looks-negp (nth 1 a
))
403 (memq (car-safe (nth 1 a
)) '(^
/ frac calcFunc-sqrt
))
404 (and (eq (car-safe (nth 1 a
)) 'cplx
)
405 (math-negp (nth 1 (nth 1 a
)))
406 (eq (nth 2 (nth 1 a
)) 0)))
407 (list 'horiz
"(" (math-compose-expr (nth 1 a
) 0) ")")
408 (math-compose-expr (nth 1 a
) 201))
409 (let ((calc-language 'flat
)
410 (calc-number-radix 10))
411 (math-compose-expr (nth 2 a
) 0))))
412 ((and (eq (car a
) '/)
413 (eq calc-language
'big
))
414 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a
)) '(/ frac
))
416 (math-compose-expr (nth 1 a
) 0)))
417 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a
)) '(/ frac
))
419 (math-compose-expr (nth 2 a
) 0))))
421 (math-comp-height a1
)
423 ((and (memq (car a
) '(calcFunc-sum calcFunc-prod
))
424 (eq calc-language
'tex
)
426 (list 'horiz
(if (eq (car a
) 'calcFunc-sum
) "\\sum" "\\prod")
427 "_{" (math-compose-expr (nth 2 a
) 0)
428 "=" (math-compose-expr (nth 3 a
) 0)
429 "}^{" (math-compose-expr (nth 4 a
) 0)
430 "}{" (math-compose-expr (nth 1 a
) 0) "}"))
431 ((and (eq (car a
) 'calcFunc-lambda
)
433 (memq calc-language
'(nil flat big
)))
436 (math-compose-hash-args (if (= (length a
) 3) 1 t
)))
437 (while (and (cdr p
) (equal (car p
) (car ap
)))
438 (setq p
(cdr p
) ap
(cdr ap
)))
441 (list (math-compose-vector
442 (nreverse (cdr (reverse (cdr a
)))) ", " 0)
445 (list (math-compose-expr (nth (1- (length a
)) a
) 0)
447 ((and (eq (car a
) 'calcFunc-string
)
449 (math-vectorp (nth 1 a
))
450 (math-vector-is-string (nth 1 a
)))
451 (if (eq calc-language
'unform
)
452 (concat "string(" (math-vector-to-string (nth 1 a
) t
) ")")
453 (math-vector-to-string (nth 1 a
) nil
)))
454 ((and (eq (car a
) 'calcFunc-bstring
)
456 (math-vectorp (nth 1 a
))
457 (math-vector-is-string (nth 1 a
)))
458 (if (eq calc-language
'unform
)
459 (concat "bstring(" (math-vector-to-string (nth 1 a
) t
) ")")
461 (s (math-vector-to-string (nth 1 a
) nil
))
463 (while (string-match "[^ ] +[^ ]" s
)
464 (setq p
(1- (match-end 0))
465 c
(cons (list 'break math-compose-level
)
466 (cons (substring s
0 p
)
469 (setq c
(nreverse (cons s c
)))
471 (setq c
(cons (list 'set math-compose-level
2) c
)))
473 ((and (eq (car a
) 'calcFunc-cprec
)
474 (not (eq calc-language
'unform
))
476 (integerp (nth 2 a
)))
477 (let ((c (math-compose-expr (nth 1 a
) -
1)))
478 (if (> prec
(nth 2 a
))
479 (if (eq calc-language
'tex
)
480 (list 'horiz
"\\left( " c
" \\right)")
481 (if (eq calc-language
'eqn
)
482 (list 'horiz
"{left ( " c
" right )}")
483 (list 'horiz
"(" c
")")))
485 ((and (eq (car a
) 'calcFunc-choriz
)
486 (not (eq calc-language
'unform
))
487 (memq (length a
) '(2 3 4))
488 (math-vectorp (nth 1 a
))
489 (if (integerp (nth 2 a
))
491 (and (math-vectorp (nth 3 a
))
492 (math-vector-is-string (nth 3 a
))))
494 (and (math-vectorp (nth 2 a
))
495 (math-vector-is-string (nth 2 a
))))))
496 (let* ((cprec (and (integerp (nth 2 a
)) (nth 2 a
)))
497 (sep (nth (if cprec
3 2) a
))
500 (math-compose-vector (cdr (nth 1 a
))
501 (math-vector-to-string sep nil
)
503 (cons 'horiz
(mapcar (function
505 (if (eq (car-safe x
) 'calcFunc-bstring
)
508 x
(or bprec cprec prec
))
510 (math-compose-expr x
(or cprec prec
)))))
512 ((and (memq (car a
) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert
))
513 (not (eq calc-language
'unform
))
514 (memq (length a
) '(2 3))
515 (math-vectorp (nth 1 a
))
517 (integerp (nth 2 a
))))
520 (prec (or (nth 2 a
) prec
))
523 (let ((b nil
) (cc nil
) a d
)
524 (if (and (memq (car-safe x
) '(calcFunc-cbase
527 (memq (length x
) '(1 2)))
530 (if (and (eq (car-safe x
) 'calcFunc-crule
)
531 (memq (length x
) '(1 2))
533 (and (math-vectorp (nth 1 x
))
534 (= (length (nth 1 x
)) 2)
535 (math-vector-is-string
537 (and (natnump (nth 1 x
))
538 (<= (nth 1 x
) 255))))
541 (if (math-vectorp (nth 1 x
))
542 (aref (math-vector-to-string
545 (or (and (memq (car-safe x
) '(calcFunc-cvspace
548 (memq (length x
) '(2 3))
551 (setq cc
(math-compose-expr x prec
))))
552 (setq a
(if cc
(math-comp-ascent cc
) 0)
553 d
(if cc
(math-comp-descent cc
) 0))
554 (if (eq b
'calcFunc-cbase
)
555 (setq base
(+ v a -
1))
556 (if (eq b
'calcFunc-ctbase
)
558 (if (eq b
'calcFunc-cbbase
)
559 (setq base
(+ v a d -
1)))))
563 (setq c
(delq nil c
))
565 (cons (if (eq (car a
) 'calcFunc-cvert
) 'vcent
566 (if (eq (car a
) 'calcFunc-clvert
) 'vleft
'vright
))
569 ((and (memq (car a
) '(calcFunc-csup calcFunc-csub
))
570 (not (eq calc-language
'unform
))
571 (memq (length a
) '(3 4))
573 (integerp (nth 3 a
))))
574 (list (if (eq (car a
) 'calcFunc-csup
) 'supscr
'subscr
)
575 (math-compose-expr (nth 1 a
) (or (nth 3 a
) 0))
576 (math-compose-expr (nth 2 a
) 0)))
577 ((and (eq (car a
) 'calcFunc-cflat
)
578 (not (eq calc-language
'unform
))
579 (memq (length a
) '(2 3))
581 (integerp (nth 2 a
))))
582 (let ((calc-language (if (memq calc-language
'(nil big
))
583 'flat calc-language
)))
584 (math-compose-expr (nth 1 a
) (or (nth 2 a
) 0))))
585 ((and (eq (car a
) 'calcFunc-cspace
)
586 (memq (length a
) '(2 3))
589 (cons 'horiz
(make-list (nth 1 a
)
590 (if (and (math-vectorp (nth 2 a
))
591 (math-vector-is-string (nth 2 a
)))
592 (math-vector-to-string (nth 2 a
) nil
)
593 (math-compose-expr (nth 2 a
) 0))))
594 (make-string (nth 1 a
) ?\
)))
595 ((and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
596 (memq (length a
) '(2 3))
600 (let* ((c (if (nth 2 a
)
601 (if (and (math-vectorp (nth 2 a
))
602 (math-vector-is-string (nth 2 a
)))
603 (math-vector-to-string (nth 2 a
) nil
)
604 (math-compose-expr (nth 2 a
) 0))
606 (ca (math-comp-ascent c
))
607 (cd (math-comp-descent c
)))
609 (cons (if (eq (car a
) 'calcFunc-ctspace
)
611 (if (eq (car a
) 'calcFunc-cbspace
)
612 (+ (* (1- (nth 1 a
)) (+ ca cd
)) (1- ca
))
613 (/ (1- (* (nth 1 a
) (+ ca cd
))) 2)))
614 (make-list (nth 1 a
) c
))))))
615 ((and (eq (car a
) 'calcFunc-evalto
)
616 (setq calc-any-evaltos t
)
617 (memq calc-language
'(tex eqn
))
618 (= math-compose-level
(if math-comp-tagged
2 1))
621 (if (eq calc-language
'tex
) "\\evalto " "evalto ")
622 (math-compose-expr (nth 1 a
) 0)
623 (if (eq calc-language
'tex
) " \\to " " -> ")
624 (math-compose-expr (nth 2 a
) 0)))
626 (let ((op (and (not (eq calc-language
'unform
))
627 (if (and (eq (car a
) 'calcFunc-if
) (= (length a
) 4))
628 (assoc "?" math-expr-opers
)
629 (math-assq2 (car a
) math-expr-opers
)))))
631 (or (= (length a
) 3) (eq (car a
) 'calcFunc-if
))
634 ((> prec
(or (nth 4 op
) (min (nth 2 op
) (nth 3 op
))))
635 (if (and (eq calc-language
'tex
)
636 (not (math-tex-expr-is-flat a
)))
637 (if (eq (car-safe a
) '/)
638 (list 'horiz
"{" (math-compose-expr a -
1) "}")
639 (list 'horiz
"\\left( "
640 (math-compose-expr a -
1)
642 (if (eq calc-language
'eqn
)
643 (if (or (eq (car-safe a
) '/)
645 (list 'horiz
"{" (math-compose-expr a -
1) "}")
646 (if (math-tex-expr-is-flat a
)
647 (list 'horiz
"( " (math-compose-expr a -
1) " )")
648 (list 'horiz
"{left ( "
649 (math-compose-expr a -
1)
651 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
652 ((and (eq calc-language
'tex
)
653 (memq (car a
) '(/ calcFunc-choose calcFunc-evalto
))
655 (list 'horiz
"{" (math-compose-expr a -
1) "}"))
656 ((eq (car a
) 'calcFunc-if
)
658 (math-compose-expr (nth 1 a
) (nth 2 op
))
660 (math-compose-expr (nth 2 a
) 0)
662 (math-compose-expr (nth 3 a
) (nth 3 op
))))
664 (let* ((math-comp-tagged (and math-comp-tagged
667 (setlev (if (= prec
(min (nth 2 op
) (nth 3 op
)))
669 (setq math-compose-level
670 (1- math-compose-level
))
673 (lhs (math-compose-expr (nth 1 a
) (nth 2 op
)))
674 (rhs (math-compose-expr (nth 2 a
) (nth 3 op
))))
675 (and (equal (car op
) "^")
676 (eq (math-comp-first-char lhs
) ?-
)
677 (setq lhs
(list 'horiz
"(" lhs
")")))
678 (and (eq calc-language
'tex
)
679 (or (equal (car op
) "^") (equal (car op
) "_"))
680 (not (and (stringp rhs
) (= (length rhs
) 1)))
681 (setq rhs
(list 'horiz
"{" rhs
"}")))
682 (or (and (eq (car a
) '*)
683 (or (null calc-language
)
684 (assoc "2x" math-expr-opers
))
685 (let* ((prevt (math-prod-last-term (nth 1 a
)))
686 (nextt (math-prod-first-term (nth 2 a
)))
687 (prevc (or (math-comp-last-char lhs
)
688 (and (memq (car-safe prevt
)
692 (eq calc-language
'big
)
694 (nextc (or (math-comp-first-char rhs
)
695 (and (memq (car-safe nextt
)
700 (eq calc-language
'big
)
703 (or (and (>= nextc ?a
) (<= nextc ?z
))
704 (and (>= nextc ?A
) (<= nextc ?Z
))
705 (and (>= nextc ?
0) (<= nextc ?
9))
706 (memq nextc
'(?. ?_ ?
#
711 (math-comp-first-string
713 (not (and (eq (car-safe prevt
) 'var
)
718 (list 'break math-compose-level
)
724 (list 'break math-compose-level
)
725 (if (or (equal (car op
) "^")
727 (equal (car op
) "**")
728 (and (equal (car op
) "*")
729 (math-comp-last-char lhs
)
730 (math-comp-first-char rhs
))
731 (and (equal (car op
) "/")
732 (math-num-integerp (nth 1 a
))
733 (math-integerp (nth 2 a
))))
735 (if (and (eq calc-language
'big
)
736 (equal (car op
) "=>"))
738 (concat " " (car op
) " ")))
740 ((and op
(= (length a
) 2) (= (nth 3 op
) -
1))
742 ((or (> prec
(or (nth 4 op
) (nth 2 op
)))
743 (and (not (eq (assoc (car op
) math-expr-opers
) op
))
744 (> prec
0))) ; don't write x% + y
745 (if (and (eq calc-language
'tex
)
746 (not (math-tex-expr-is-flat a
)))
747 (list 'horiz
"\\left( "
748 (math-compose-expr a -
1)
750 (if (eq calc-language
'eqn
)
751 (if (= (/ prec
100) 9)
752 (list 'horiz
"{" (math-compose-expr a -
1) "}")
753 (if (math-tex-expr-is-flat a
)
754 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
755 (list 'horiz
"{left ( "
756 (math-compose-expr a -
1)
758 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
760 (let ((lhs (math-compose-expr (nth 1 a
) (nth 2 op
))))
763 (if (or (> (length (car op
)) 1)
764 (not (math-comp-is-flat lhs
)))
765 (concat " " (car op
))
767 ((and op
(= (length a
) 2) (= (nth 2 op
) -
1))
770 (let ((lr (and (eq calc-language
'tex
)
771 (not (math-tex-expr-is-flat (nth 1 a
))))))
774 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op
))
775 (substring (car op
) 1)
777 (if (or lr
(> (length (car op
)) 2)) " " "")
778 (math-compose-expr (nth 1 a
) -
1)
779 (if (or lr
(> (length (car op
)) 2)) " " "")
781 (car (nth 1 (memq op math-expr-opers
))))))
782 ((> prec
(or (nth 4 op
) (nth 3 op
)))
783 (if (and (eq calc-language
'tex
)
784 (not (math-tex-expr-is-flat a
)))
785 (list 'horiz
"\\left( "
786 (math-compose-expr a -
1)
788 (if (eq calc-language
'eqn
)
789 (if (= (/ prec
100) 9)
790 (list 'horiz
"{" (math-compose-expr a -
1) "}")
791 (if (math-tex-expr-is-flat a
)
792 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
793 (list 'horiz
"{left ( "
794 (math-compose-expr a -
1)
796 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
798 (let ((rhs (math-compose-expr (nth 1 a
) (nth 3 op
))))
800 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
802 (substring (car op
) 1)
804 (if (or (> (length ops
) 1)
805 (not (math-comp-is-flat rhs
)))
809 ((and (eq calc-language
'big
)
810 (setq op
(get (car a
) 'math-compose-big
))
811 (funcall op a prec
)))
812 ((and (setq op
(assq calc-language
813 '( ( nil . math-compose-normal
)
814 ( flat . math-compose-normal
)
815 ( big . math-compose-normal
)
816 ( c . math-compose-c
)
817 ( pascal . math-compose-pascal
)
818 ( fortran . math-compose-fortran
)
819 ( tex . math-compose-tex
)
820 ( eqn . math-compose-eqn
)
821 ( math . math-compose-math
)
822 ( maple . math-compose-maple
))))
823 (setq op
(get (car a
) (cdr op
)))
824 (funcall op a prec
)))
826 (let* ((func (car a
))
827 (func2 (assq func
'(( mod . calcFunc-makemod
)
828 ( sdev . calcFunc-sdev
)
835 ( neg . calcFunc-neg
)
836 ( | . calcFunc-vconcat
))))
839 (setq func
(cdr func2
)))
840 (if (setq func2
(rassq func math-expr-function-mapping
))
841 (setq func
(car func2
)))
842 (setq func
(math-remove-dashes
844 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
846 (math-match-substring (symbol-name func
) 1)
847 (symbol-name func
))))
848 (if (memq calc-language
'(c fortran pascal maple
))
849 (setq func
(math-to-underscores func
)))
850 (if (and (eq calc-language
'tex
)
852 (not (= calc-language-option
0))
853 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func
))
854 (if (< (prefix-numeric-value calc-language-option
) 0)
855 (setq func
(format "\\%s" func
))
856 (setq func
(format "\\hbox{%s}" func
))))
857 (if (and (eq calc-language
'eqn
)
858 (string-match "[^']'+\\'" func
))
859 (let ((n (- (length func
) (match-beginning 0) 1)))
860 (setq func
(substring func
0 (- n
)))
861 (while (>= (setq n
(1- n
)) 0)
862 (setq func
(concat func
" prime")))))
863 (cond ((and (eq calc-language
'tex
)
865 (not (math-tex-expr-is-flat (nth 1 a
)))))
866 (setq left
"\\left( "
868 ((and (eq calc-language
'eqn
)
870 (not (math-tex-expr-is-flat (nth 1 a
)))))
871 (setq left
"{left ( "
873 ((and (or (and (eq calc-language
'tex
)
874 (eq (aref func
0) ?
\\))
875 (and (eq calc-language
'eqn
)
876 (memq (car a
) math-eqn-special-funcs
)))
877 (not (string-match "\\hbox{" func
))
879 (or (Math-realp (nth 1 a
))
880 (memq (car (nth 1 a
)) '(var *))))
881 (setq left
(if (eq calc-language
'eqn
) "~{" "{")
883 ((eq calc-language
'eqn
)
886 (t (setq left calc-function-open
887 right calc-function-close
)))
888 (list 'horiz func left
889 (math-compose-vector (cdr a
)
890 (if (eq calc-language
'eqn
)
896 (defun math-prod-first-term (x)
897 (while (eq (car-safe x
) '*)
901 (defun math-prod-last-term (x)
902 (while (eq (car-safe x
) '*)
906 (defun math-compose-vector (a sep prec
)
909 (cons (list 'set math-compose-level
)
910 (let ((c (list (math-compose-expr (car a
) prec
))))
911 (while (setq a
(cdr a
))
912 (setq c
(cons (if (eq (car-safe (car a
))
914 (let ((math-compose-level
915 (1- math-compose-level
)))
916 (math-compose-expr (car a
) -
123))
917 (math-compose-expr (car a
) prec
))
918 (cons (list 'break math-compose-level
)
923 (defun math-vector-no-parens (a)
925 (not (eq (car-safe (nth 1 a
)) '*))))
927 (defun math-compose-matrix (a col cols base
)
930 (while (<= (setq col
(1+ col
)) cols
)
931 (setq res
(cons (cons just
941 (concat comma-spc
" ")))))
946 (defun math-compose-rows (a count first
)
950 (math-compose-rows (cdr a
) -
1 nil
)
951 (cons (concat (if (eq calc-language
'tex
) " \\ldots" " ...")
953 (math-compose-rows (cdr a
) -
1 nil
)))
955 (if first
(concat left-bracket
" ") " ")
956 (math-compose-expr (car a
) vector-prec
)
958 (math-compose-rows (cdr a
) (1- count
) nil
)))
960 (if first
(concat left-bracket
" ") " ")
961 (math-compose-expr (car a
) vector-prec
)
962 (concat " " right-bracket
)))))
964 (defun math-compose-tex-matrix (a)
966 (cons (math-compose-vector (cdr (car a
)) " & " 0)
968 (math-compose-tex-matrix (cdr a
))))
969 (list (math-compose-vector (cdr (car a
)) " & " 0))))
971 (defun math-compose-eqn-matrix (a)
974 (cond ((eq calc-matrix-just
'right
) "rcol ")
975 ((eq calc-matrix-just
'center
) "ccol ")
978 (list 'break math-compose-level
)
982 (let ((math-compose-level (1+ math-compose-level
)))
983 (math-compose-vector (cdr (car a
)) " above " 1000))
986 (math-compose-eqn-matrix (cdr a
)))))))
989 (defun math-vector-is-string (a)
990 (while (and (setq a
(cdr a
))
991 (or (and (natnump (car a
))
993 (and (eq (car-safe (car a
)) 'cplx
)
994 (natnump (nth 1 (car a
)))
995 (eq (nth 2 (car a
)) 0)
996 (<= (nth 1 (car a
)) 255)))))
999 (defconst math-vector-to-string-chars
'( ( ?
\" .
"\\\"" )
1010 (defun math-vector-to-string (a &optional quoted
)
1011 (setq a
(concat (mapcar (function (lambda (x) (if (consp x
) (nth 1 x
) x
)))
1013 (if (string-match "[\000-\037\177\\\"]" a
)
1015 (pat (if quoted
"[\000-\037\177\\\"]" "[\000-\037\177]"))
1016 (codes (if quoted math-vector-to-string-chars
'((?\^? .
"^?"))))
1017 (fmt (if quoted
"\\^%c" "^%c"))
1019 (while (setq p
(string-match pat a p
))
1020 (if (setq new
(assq (aref a p
) codes
))
1021 (setq a
(concat (substring a
0 p
)
1023 (substring a
(1+ p
)))
1024 p
(+ p
(length (cdr new
))))
1025 (setq a
(concat (substring a
0 p
)
1026 (format fmt
(+ (aref a p
) 64))
1027 (substring a
(1+ p
)))
1030 (concat "\"" a
"\"")
1034 (defun math-to-underscores (x)
1035 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x
)
1036 (math-to-underscores
1037 (concat (math-match-substring x
1) "_" (math-match-substring x
2)))
1040 (defun math-tex-expr-is-flat (a)
1041 (or (Math-integerp a
)
1042 (memq (car a
) '(float var
))
1043 (and (memq (car a
) '(+ -
* neg
))
1045 (while (and (setq a
(cdr a
))
1046 (math-tex-expr-is-flat (car a
))))
1048 (and (memq (car a
) '(^ calcFunc-subscr
))
1049 (math-tex-expr-is-flat (nth 1 a
)))))
1051 (put 'calcFunc-log
'math-compose-big
'math-compose-log
)
1052 (defun math-compose-log (a prec
)
1053 (and (= (length a
) 3)
1056 (let ((calc-language 'flat
))
1057 (math-compose-expr (nth 2 a
) 1000)))
1059 (math-compose-expr (nth 1 a
) 1000)
1062 (put 'calcFunc-log10
'math-compose-big
'math-compose-log10
)
1063 (defun math-compose-log10 (a prec
)
1064 (and (= (length a
) 2)
1066 (list 'subscr
"log" "10")
1068 (math-compose-expr (nth 1 a
) 1000)
1071 (put 'calcFunc-deriv
'math-compose-big
'math-compose-deriv
)
1072 (put 'calcFunc-tderiv
'math-compose-big
'math-compose-deriv
)
1073 (defun math-compose-deriv (a prec
)
1074 (when (= (length a
) 3)
1075 (math-compose-expr (list '/
1076 (list 'calcFunc-choriz
1078 '(calcFunc-string (vec ?d
))
1080 (list 'calcFunc-choriz
1082 '(calcFunc-string (vec ?d
))
1086 (put 'calcFunc-sqrt
'math-compose-big
'math-compose-sqrt
)
1087 (defun math-compose-sqrt (a prec
)
1088 (when (= (length a
) 2)
1089 (let* ((c (math-compose-expr (nth 1 a
) 0))
1090 (a (math-comp-ascent c
))
1091 (d (math-comp-descent c
))
1093 (w (math-comp-width c
)))
1096 (concat (if (= h
1) " " " ")
1097 (make-string (+ w
2) ?\_
))
1101 (append (list 'vleft
(1- a
))
1102 (make-list (1- h
) " |")
1107 (put 'calcFunc-choose
'math-compose-big
'math-compose-choose
)
1108 (defun math-compose-choose (a prec
)
1109 (let ((a1 (math-compose-expr (nth 1 a
) 0))
1110 (a2 (math-compose-expr (nth 2 a
) 0)))
1114 (math-comp-height a1
)
1118 (put 'calcFunc-integ
'math-compose-big
'math-compose-integ
)
1119 (defun math-compose-integ (a prec
)
1120 (and (memq (length a
) '(3 5))
1121 (eq (car-safe (nth 2 a
)) 'var
)
1122 (let* ((parens (and (>= prec
196) (/= prec
1000)))
1123 (var (math-compose-expr (nth 2 a
) 0))
1124 (over (and (eq (car-safe (nth 2 a
)) 'var
)
1125 (or (and (eq (car-safe (nth 1 a
)) '/)
1126 (math-numberp (nth 1 (nth 1 a
))))
1127 (and (eq (car-safe (nth 1 a
)) '^
)
1128 (math-looks-negp (nth 2 (nth 1 a
)))))))
1129 (expr (math-compose-expr (if over
1131 (math-build-var-name
1134 (nth 1 (nth 2 a
)))))
1136 (calc-language 'flat
)
1137 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1138 (high (and (nth 4 a
) (math-compose-expr (nth 4 a
) 0))))
1141 (append (list 'vcent
(if high
3 2))
1142 (and high
(list (list 'horiz
" " high
)))
1148 (and low
(list (list 'horiz low
" "))))
1152 (list 'horiz
" d" var
))
1153 (if parens
")" "")))))
1155 (put 'calcFunc-sum
'math-compose-big
'math-compose-sum
)
1156 (defun math-compose-sum (a prec
)
1157 (and (memq (length a
) '(3 5 6))
1158 (let* ((expr (math-compose-expr (nth 1 a
) 185))
1159 (calc-language 'flat
)
1160 (var (math-compose-expr (nth 2 a
) 0))
1161 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1162 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1164 (if (memq prec
'(180 201)) "(" "")
1165 (append (list 'vcent
(if high
3 2))
1166 (and high
(list high
))
1173 (list (list 'horiz var
" = " low
))
1175 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1178 (if (memq prec
'(180 201)) ")" "")))))
1180 (put 'calcFunc-prod
'math-compose-big
'math-compose-prod
)
1181 (defun math-compose-prod (a prec
)
1182 (and (memq (length a
) '(3 5 6))
1183 (let* ((expr (math-compose-expr (nth 1 a
) 198))
1184 (calc-language 'flat
)
1185 (var (math-compose-expr (nth 2 a
) 0))
1186 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1187 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1189 (if (memq prec
'(196 201)) "(" "")
1190 (append (list 'vcent
(if high
3 2))
1191 (and high
(list high
))
1197 (list (list 'horiz var
" = " low
))
1199 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1202 (if (memq prec
'(196 201)) ")" "")))))
1205 (defun math-stack-value-offset-fancy ()
1206 (let ((cwid (+ (math-comp-width c
))))
1207 (cond ((eq calc-display-just
'right
)
1208 (if calc-display-origin
1209 (setq wid
(max calc-display-origin
5))
1210 (if (integerp calc-line-breaking
)
1211 (setq wid calc-line-breaking
)))
1212 (setq off
(- wid cwid
1213 (max (- (length calc-right-label
)
1214 (if (and (integerp calc-line-breaking
)
1215 calc-display-origin
)
1216 (max (- calc-line-breaking
1217 calc-display-origin
)
1222 (if calc-display-origin
1224 (setq off
(- calc-display-origin
(/ cwid
2)))
1225 (if (integerp calc-line-breaking
)
1226 (setq off
(min off
(- calc-line-breaking cwid
1227 (length calc-right-label
)))))
1229 (setq wid
(max wid
(+ off cwid
)))))
1230 (if (integerp calc-line-breaking
)
1231 (setq wid calc-line-breaking
))
1232 (setq off
(/ (- wid cwid
) 2)))))
1233 (and (integerp calc-line-breaking
)
1235 (and calc-display-origin
1236 (> calc-line-breaking calc-display-origin
)))
1237 (setq wid calc-line-breaking
))))
1241 ;;; Convert a composition to string form, with embedded \n's if necessary.
1243 (defun math-composition-to-string (c &optional width
)
1244 (or width
(setq width
(calc-window-width)))
1245 (if calc-display-raw
1246 (math-comp-to-string-raw c
0)
1247 (if (math-comp-is-flat c
)
1248 (math-comp-to-string-flat c width
)
1249 (math-vert-comp-to-string
1250 (math-comp-simplify c width
)))))
1252 (defvar math-comp-buf-string
(make-vector 10 ""))
1253 (defvar math-comp-buf-margin
(make-vector 10 0))
1254 (defvar math-comp-buf-level
(make-vector 10 0))
1255 (defun math-comp-is-flat (c) ; check if c's height is 1.
1256 (cond ((not (consp c
)) t
)
1257 ((memq (car c
) '(set break
)) t
)
1258 ((eq (car c
) 'horiz
)
1259 (while (and (setq c
(cdr c
))
1260 (math-comp-is-flat (car c
))))
1262 ((memq (car c
) '(vleft vcent vright
))
1263 (and (= (length c
) 3)
1265 (math-comp-is-flat (nth 2 c
))))
1267 (math-comp-is-flat (nth 2 c
)))
1271 ;;; Convert a one-line composition to a string. Break into multiple
1272 ;;; lines if necessary, choosing break points according to the structure
1275 (defun math-comp-to-string-flat (c full-width
)
1276 (if math-comp-sel-hpos
1278 (math-comp-sel-flat-term c
))
1283 (comp-highlight (and math-comp-selected calc-show-selections
))
1285 (math-comp-to-string-flat-term '(set -
1 0))
1286 (math-comp-to-string-flat-term c
)
1287 (math-comp-to-string-flat-term '(break -
1))
1288 (let ((str (aref math-comp-buf-string
0))
1290 (and (> (length str
) 0) (= (aref str
0) ?
)
1291 (> (length comp-buf
) 0)
1292 (let ((k (length comp-buf
)))
1293 (while (not (= (aref comp-buf
(setq k
(1- k
))) ?
\n)))
1294 (aset comp-buf k ?
)
1295 (if (and (< (1+ k
) (length comp-buf
))
1296 (= (aref comp-buf
(1+ k
)) ?
))
1298 (aset comp-buf
(1+ k
) ?
\n)
1300 (setq prefix
"\n"))))
1301 (concat comp-buf prefix str
)))))
1303 (defun math-comp-to-string-flat-term (c)
1304 (cond ((not (consp c
))
1306 (setq c
(math-comp-highlight-string c
)))
1307 (setq comp-word
(if (= (length comp-word
) 0) c
(concat comp-word c
))
1308 comp-pos
(+ comp-pos
(length c
))))
1310 ((eq (car c
) 'horiz
)
1311 (while (setq c
(cdr c
))
1312 (math-comp-to-string-flat-term (car c
))))
1317 (setq comp-level
(1+ comp-level
))
1318 (if (>= comp-level
(length math-comp-buf-string
))
1319 (setq math-comp-buf-string
(vconcat math-comp-buf-string
1320 math-comp-buf-string
)
1321 math-comp-buf-margin
(vconcat math-comp-buf-margin
1322 math-comp-buf-margin
)
1323 math-comp-buf-level
(vconcat math-comp-buf-level
1324 math-comp-buf-level
)))
1325 (aset math-comp-buf-string comp-level
"")
1326 (aset math-comp-buf-margin comp-level
(+ comp-pos
1328 (aset math-comp-buf-level comp-level
(nth 1 c
)))))
1330 ((eq (car c
) 'break
)
1331 (if (not calc-line-breaking
)
1332 (setq comp-buf
(concat comp-buf comp-word
)
1335 (if (and (> comp-pos full-width
)
1338 (setq str
(aref math-comp-buf-string i
))
1339 (and (= (length str
) 0) (< i comp-level
)))
1341 (or (> (length str
) 0) (> (length comp-buf
) 0))))
1342 (let ((prefix "") mrg wid
)
1343 (setq mrg
(aref math-comp-buf-margin i
))
1344 (if (> mrg
12) ; indenting too far, go back to far left
1345 (let ((j i
) (new (if calc-line-numbering
5 1)))
1346 '(while (<= j comp-level
)
1347 (aset math-comp-buf-margin j
1348 (+ (aref math-comp-buf-margin j
) (- new mrg
)))
1351 (setq wid
(+ (length str
) comp-margin
))
1352 (and (> (length str
) 0) (= (aref str
0) ?
)
1353 (> (length comp-buf
) 0)
1354 (let ((k (length comp-buf
)))
1355 (while (not (= (aref comp-buf
(setq k
(1- k
))) ?
\n)))
1356 (aset comp-buf k ?
)
1357 (if (and (< (1+ k
) (length comp-buf
))
1358 (= (aref comp-buf
(1+ k
)) ?
))
1360 (aset comp-buf
(1+ k
) ?
\n)
1362 (setq prefix
"\n"))))
1363 (setq comp-buf
(concat comp-buf prefix str
"\n"
1364 (make-string mrg ?
))
1365 comp-pos
(+ comp-pos
(- mrg wid
))
1367 (aset math-comp-buf-string i
"")
1368 (while (<= (setq i
(1+ i
)) comp-level
)
1369 (if (> (aref math-comp-buf-margin i
) wid
)
1370 (aset math-comp-buf-margin i
1371 (+ (aref math-comp-buf-margin i
)
1373 (if (and (= (nth 1 c
) (aref math-comp-buf-level comp-level
))
1374 (< comp-pos
(+ (aref math-comp-buf-margin comp-level
) 2)))
1375 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1376 (let ((str (aref math-comp-buf-string comp-level
)))
1377 (setq str
(if (= (length str
) 0)
1379 (concat str comp-word
))
1381 (while (< (nth 1 c
) (aref math-comp-buf-level comp-level
))
1382 (setq comp-level
(1- comp-level
))
1383 (or (= (length (aref math-comp-buf-string comp-level
)) 0)
1384 (setq str
(concat (aref math-comp-buf-string comp-level
)
1386 (aset math-comp-buf-string comp-level str
)))))
1389 (cond ((eq (nth 1 c
) math-comp-selected
)
1390 (let ((comp-highlight (not calc-show-selections
)))
1391 (math-comp-to-string-flat-term (nth 2 c
))))
1393 (let ((comp-highlight nil
))
1394 (math-comp-to-string-flat-term (nth 2 c
))))
1395 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1397 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1399 (defun math-comp-highlight-string (s)
1400 (setq s
(copy-sequence s
))
1401 (let ((i (length s
)))
1402 (while (>= (setq i
(1- i
)) 0)
1403 (or (memq (aref s i
) '(32 ?
\n))
1404 (aset s i
(if calc-show-selections ?\. ?\
#)))))
1407 (defun math-comp-sel-flat-term (c)
1408 (cond ((not (consp c
))
1409 (setq comp-pos
(+ comp-pos
(length c
))))
1410 ((memq (car c
) '(set break
)))
1411 ((eq (car c
) 'horiz
)
1412 (while (and (setq c
(cdr c
)) (< math-comp-sel-cpos
1000000))
1413 (math-comp-sel-flat-term (car c
))))
1415 (if (<= comp-pos math-comp-sel-cpos
)
1417 (math-comp-sel-flat-term (nth 2 c
))
1418 (if (> comp-pos math-comp-sel-cpos
)
1419 (setq math-comp-sel-tag c
1420 math-comp-sel-cpos
1000000)))
1421 (math-comp-sel-flat-term (nth 2 c
))))
1422 (t (math-comp-sel-flat-term (nth 2 c
)))))
1425 ;;; Simplify a composition to a canonical form consisting of
1426 ;;; (vleft n "string" "string" "string" ...)
1427 ;;; where 0 <= n < number-of-strings.
1429 (defun math-comp-simplify (c full-width
)
1430 (let ((comp-buf (list ""))
1435 (comp-highlight (and math-comp-selected calc-show-selections
))
1437 (math-comp-simplify-term c
)
1438 (cons 'vleft
(cons comp-base comp-buf
))))
1440 (defun math-comp-add-string (s h v
)
1441 (and (> (length s
) 0)
1442 (let ((vv (+ v comp-base
)))
1443 (if math-comp-sel-hpos
1444 (math-comp-add-string-sel h vv
(length s
) 1)
1446 (setq comp-buf
(nconc (make-list (- vv
) "") comp-buf
)
1448 comp-height
(- comp-height vv
)
1450 (if (>= vv comp-height
)
1451 (setq comp-buf
(nconc comp-buf
1452 (make-list (1+ (- vv comp-height
)) ""))
1453 comp-height
(1+ vv
))))
1454 (let ((str (nthcdr vv comp-buf
)))
1455 (setcar str
(concat (car str
)
1456 (make-string (- h
(length (car str
))) 32)
1458 (math-comp-highlight-string s
)
1461 (defun math-comp-add-string-sel (x y w h
)
1462 (if (and (<= y math-comp-sel-vpos
)
1463 (> (+ y h
) math-comp-sel-vpos
)
1464 (<= x math-comp-sel-hpos
)
1465 (> (+ x w
) math-comp-sel-hpos
))
1466 (setq math-comp-sel-tag comp-tag
1467 math-comp-sel-vpos
10000)))
1469 (defun math-comp-simplify-term (c)
1471 (math-comp-add-string c comp-hpos comp-vpos
)
1472 (setq comp-hpos
(+ comp-hpos
(length c
))))
1473 ((memq (car c
) '(set break
))
1475 ((eq (car c
) 'horiz
)
1476 (while (setq c
(cdr c
))
1477 (math-comp-simplify-term (car c
))))
1478 ((memq (car c
) '(vleft vcent vright
))
1479 (let* ((comp-vpos (+ (- comp-vpos
(nth 1 c
))
1480 (1- (math-comp-ascent (nth 2 c
)))))
1481 (widths (mapcar 'math-comp-width
(cdr (cdr c
))))
1482 (maxwid (apply 'max widths
))
1483 (bias (cond ((eq (car c
) 'vleft
) 0)
1484 ((eq (car c
) 'vcent
) 1)
1487 (while (setq c
(cdr c
))
1488 (if (eq (car-safe (car c
)) 'rule
)
1489 (math-comp-add-string (make-string maxwid
(nth 1 (car c
)))
1490 comp-hpos comp-vpos
)
1491 (let ((comp-hpos (+ comp-hpos
(/ (* bias
(- maxwid
1494 (math-comp-simplify-term (car c
))))
1496 (setq comp-vpos
(+ comp-vpos
1497 (+ (math-comp-descent (car c
))
1498 (math-comp-ascent (nth 1 c
))))
1499 widths
(cdr widths
))))
1500 (setq comp-hpos
(+ comp-hpos maxwid
))))
1501 ((eq (car c
) 'supscr
)
1502 (let* ((asc (or 1 (math-comp-ascent (nth 1 c
))))
1503 (desc (math-comp-descent (nth 2 c
)))
1506 (math-comp-simplify-term (nth 1 c
))))
1507 (comp-vpos (- comp-vpos
(+ asc desc
))))
1508 (math-comp-simplify-term (nth 2 c
))
1509 (if math-comp-sel-hpos
1510 (math-comp-add-string-sel oldh
1513 (math-comp-ascent (nth 2 c
)))
1515 (math-comp-height c
)))))
1516 ((eq (car c
) 'subscr
)
1517 (let* ((asc (math-comp-ascent (nth 2 c
)))
1518 (desc (math-comp-descent (nth 1 c
)))
1522 (math-comp-simplify-term (nth 1 c
))))
1523 (comp-vpos (+ comp-vpos
(+ asc desc
))))
1524 (math-comp-simplify-term (nth 2 c
))
1525 (if math-comp-sel-hpos
1526 (math-comp-add-string-sel oldh oldv
1528 (math-comp-height c
)))))
1530 (cond ((eq (nth 1 c
) math-comp-selected
)
1531 (let ((comp-highlight (not calc-show-selections
)))
1532 (math-comp-simplify-term (nth 2 c
))))
1534 (let ((comp-highlight nil
))
1535 (math-comp-simplify-term (nth 2 c
))))
1536 (t (let ((comp-tag c
))
1537 (math-comp-simplify-term (nth 2 c
))))))))
1540 ;;; Measuring a composition.
1542 (defun math-comp-first-char (c)
1544 (and (> (length c
) 0)
1546 ((memq (car c
) '(horiz subscr supscr
))
1547 (while (and (setq c
(cdr c
))
1548 (math-comp-is-null (car c
))))
1549 (and c
(math-comp-first-char (car c
))))
1551 (math-comp-first-char (nth 2 c
)))))
1553 (defun math-comp-first-string (c)
1555 (and (> (length c
) 0)
1557 ((eq (car c
) 'horiz
)
1558 (while (and (setq c
(cdr c
))
1559 (math-comp-is-null (car c
))))
1560 (and c
(math-comp-first-string (car c
))))
1562 (math-comp-first-string (nth 2 c
)))))
1564 (defun math-comp-last-char (c)
1566 (and (> (length c
) 0)
1567 (elt c
(1- (length c
)))))
1568 ((eq (car c
) 'horiz
)
1569 (let ((c (reverse (cdr c
))))
1570 (while (and c
(math-comp-is-null (car c
)))
1572 (and c
(math-comp-last-char (car c
)))))
1574 (math-comp-last-char (nth 2 c
)))))
1576 (defun math-comp-is-null (c)
1577 (cond ((stringp c
) (= (length c
) 0))
1578 ((memq (car c
) '(horiz subscr supscr
))
1579 (while (and (setq c
(cdr c
))
1580 (math-comp-is-null (car c
))))
1583 (math-comp-is-null (nth 2 c
)))
1584 ((memq (car c
) '(set break
)) t
)))
1586 (defun math-comp-width (c)
1587 (cond ((not (consp c
)) (length c
))
1588 ((memq (car c
) '(horiz subscr supscr
))
1590 (while (setq c
(cdr c
))
1591 (setq accum
(+ accum
(math-comp-width (car c
)))))
1593 ((memq (car c
) '(vcent vleft vright
))
1596 (while (setq c
(cdr c
))
1597 (setq accum
(max accum
(math-comp-width (car c
)))))
1600 (math-comp-width (nth 2 c
)))
1603 (defun math-comp-height (c)
1606 (+ (math-comp-ascent c
) (math-comp-descent c
))))
1608 (defun math-comp-ascent (c)
1609 (cond ((not (consp c
)) 1)
1610 ((eq (car c
) 'horiz
)
1612 (while (setq c
(cdr c
))
1613 (setq accum
(max accum
(math-comp-ascent (car c
)))))
1615 ((memq (car c
) '(vcent vleft vright
))
1616 (if (> (nth 1 c
) 0) (1+ (nth 1 c
)) 1))
1617 ((eq (car c
) 'supscr
)
1618 (max (math-comp-ascent (nth 1 c
)) (1+ (math-comp-height (nth 2 c
)))))
1619 ((eq (car c
) 'subscr
)
1620 (math-comp-ascent (nth 1 c
)))
1622 (math-comp-ascent (nth 2 c
)))
1625 (defun math-comp-descent (c)
1626 (cond ((not (consp c
)) 0)
1627 ((eq (car c
) 'horiz
)
1629 (while (setq c
(cdr c
))
1630 (setq accum
(max accum
(math-comp-descent (car c
)))))
1632 ((memq (car c
) '(vcent vleft vright
))
1633 (let ((accum (- (nth 1 c
))))
1635 (while (setq c
(cdr c
))
1636 (setq accum
(+ accum
(math-comp-height (car c
)))))
1637 (max (1- accum
) 0)))
1638 ((eq (car c
) 'supscr
)
1639 (math-comp-descent (nth 1 c
)))
1640 ((eq (car c
) 'subscr
)
1641 (+ (math-comp-descent (nth 1 c
)) (math-comp-height (nth 2 c
))))
1643 (math-comp-descent (nth 2 c
)))
1646 (defun calcFunc-cwidth (a &optional prec
)
1647 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1648 (math-comp-width (math-compose-expr a
(or prec
0))))
1650 (defun calcFunc-cheight (a &optional prec
)
1651 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1652 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1653 (memq (length a
) '(2 3))
1656 (math-comp-height (math-compose-expr a
(or prec
0)))))
1658 (defun calcFunc-cascent (a &optional prec
)
1659 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1660 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1661 (memq (length a
) '(2 3))
1664 (math-comp-ascent (math-compose-expr a
(or prec
0)))))
1666 (defun calcFunc-cdescent (a &optional prec
)
1667 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1668 (math-comp-descent (math-compose-expr a
(or prec
0))))
1671 ;;; Convert a simplified composition into string form.
1673 (defun math-vert-comp-to-string (c)
1676 (math-vert-comp-to-string-step (cdr (cdr c
)))))
1678 (defun math-vert-comp-to-string-step (c)
1680 (concat (car c
) "\n" (math-vert-comp-to-string-step (cdr c
)))
1684 ;;; Convert a composition to a string in "raw" form (for debugging).
1686 (defun math-comp-to-string-raw (c indent
)
1687 (cond ((or (not (consp c
)) (eq (car c
) 'set
))
1688 (prin1-to-string c
))
1690 (concat "(" (symbol-name (car c
)) ")"))
1692 (let ((next-indent (+ indent
2 (length (symbol-name (car c
))))))
1694 (symbol-name (car c
))
1696 (math-comp-to-string-raw (nth 1 c
) next-indent
)
1697 (math-comp-to-string-raw-step (cdr (cdr c
))
1701 (defun math-comp-to-string-raw-step (cl indent
)
1704 (make-string indent
32)
1705 (math-comp-to-string-raw (car cl
) indent
)
1706 (math-comp-to-string-raw-step (cdr cl
) indent
))
1709 ;;; calccomp.el ends here