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: Jay Belanger <belanger@truman.edu>
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 (defconst math-eqn-special-funcs
36 calcFunc-ln calcFunc-exp
37 calcFunc-sin calcFunc-cos calcFunc-tan
38 calcFunc-sinh calcFunc-cosh calcFunc-tanh
39 calcFunc-arcsin calcFunc-arccos calcFunc-arctan
40 calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh))
42 ;;; A "composition" has one of the following forms:
44 ;;; "string" A literal string
46 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
48 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
49 ;;; (break LEVEL) A potential line-break point
51 ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
52 ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
53 ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
54 ;;; N specifies baseline of the stack, 0=top line.
56 ;;; (supscr C1 C2) Composition C1 with superscript C2
57 ;;; (subscr C1 C2) Composition C1 with subscript C2
58 ;;; (rule X) Horizontal line of X, full width of enclosing comp
60 ;;; (tag X C) Composition C corresponds to sub-expression X
62 ;; math-comp-just and math-comp-comma-spc are local to
63 ;; math-compose-expr, but are used by math-compose-matrix, which is
64 ;; called by math-compose-expr
65 (defvar math-comp-just)
66 (defvar math-comp-comma-spc)
68 ;; math-comp-vector-prec is local to math-compose-expr, but is used by
69 ;; math-compose-matrix and math-compose-rows, which are called by
71 (defvar math-comp-vector-prec)
73 ;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
74 ;; local to math-compose-expr, but are used by math-compose-rows, which is
75 ;; called by math-compose-expr.
76 (defvar math-comp-left-bracket)
77 (defvar math-comp-right-bracket)
78 (defvar math-comp-comma)
81 (defun math-compose-expr (a prec)
82 (let ((math-compose-level (1+ math-compose-level))
85 ((or (and (eq a math-comp-selected) a)
87 (not (eq math-comp-tagged a))))
88 (let ((math-comp-selected nil))
89 (and math-comp-tagged (setq math-comp-tagged a))
90 (list 'tag a (math-compose-expr a prec))))
91 ((and (not (consp a)) (not (integerp a)))
92 (concat "'" (prin1-to-string a)))
93 ((setq spfn (assq (car-safe a) math-expr-special-function-mapping))
94 (setq spfn (cdr spfn))
95 (funcall (car spfn) a spfn))
97 (if (or (eq (car-safe a) 'frac)
98 (and (nth 1 calc-frac-format) (Math-integerp a)))
99 (if (memq calc-language '(tex latex eqn math maple c fortran pascal))
100 (let ((aa (math-adjust-fraction a))
101 (calc-frac-format nil))
102 (math-compose-expr (list '/
103 (if (memq calc-language '(c fortran))
104 (math-float (nth 1 aa))
107 (if (and (eq calc-language 'big)
108 (= (length (car calc-frac-format)) 1))
109 (let* ((aa (math-adjust-fraction a))
110 (calc-frac-format nil)
111 (math-radix-explicit-format nil)
113 (if (math-negp (nth 1 aa))
117 (math-abs (nth 1 aa)))
119 (math-format-number (nth 2 aa))))))
120 (if (= calc-number-radix 10)
124 (int-to-string calc-number-radix)))))
125 (math-format-number a)))
126 (if (not (eq calc-language 'big))
127 (math-format-number a prec)
128 (if (memq (car-safe a) '(cplx polar))
129 (if (math-zerop (nth 2 a))
130 (math-compose-expr (nth 1 a) prec)
132 (math-compose-expr (nth 1 a) 0)
133 (if (eq (car a) 'cplx) ", " "; ")
134 (math-compose-expr (nth 2 a) 0) ")"))
135 (if (or (= calc-number-radix 10)
137 (and calc-group-digits
138 (not (assoc calc-group-char '((",") (" "))))))
139 (math-format-number a prec)
140 (let ((s (math-format-number a prec))
142 (while (string-match (if (> calc-number-radix 14)
143 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
144 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
146 (setq c (nconc c (list (substring s 0 (match-beginning 0))
148 (math-match-substring s 2)
149 (math-match-substring s 1))))
150 s (substring s (match-end 0))))
152 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
154 (substring s 0 (match-beginning 0)) " "
156 (math-match-substring s 1)
157 (math-match-substring s 2))
158 (math-match-substring s 3))))
159 (if c (cons 'horiz (nconc c (list s))) s)))))))
160 ((and (get (car a) 'math-compose-forms)
161 (not (eq calc-language 'unform))
162 (let ((comps (get (car a) 'math-compose-forms))
164 (or (and (setq temp (assq calc-language comps))
165 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
166 (setq temp (apply (cdr temp2) (cdr a)))
167 (math-compose-expr temp prec))
168 (and (setq temp2 (assq nil (cdr temp)))
169 (funcall (cdr temp2) a))))
170 (and (setq temp (assq nil comps))
171 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
172 (setq temp (apply (cdr temp2) (cdr a)))
173 (math-compose-expr temp prec))
174 (and (setq temp2 (assq nil (cdr temp)))
175 (funcall (cdr temp2) a))))))))
177 (let* ((math-comp-left-bracket (if calc-vector-brackets
178 (substring calc-vector-brackets 0 1) ""))
179 (math-comp-right-bracket (if calc-vector-brackets
180 (substring calc-vector-brackets 1 2) ""))
181 (inner-brackets (memq 'R calc-matrix-brackets))
182 (outer-brackets (memq 'O calc-matrix-brackets))
183 (row-commas (memq 'C calc-matrix-brackets))
184 (math-comp-comma-spc (or calc-vector-commas " "))
185 (math-comp-comma (or calc-vector-commas ""))
186 (math-comp-vector-prec (if (or (and calc-vector-commas
187 (math-vector-no-parens a))
188 (memq 'P calc-matrix-brackets)) 0 1000))
189 (math-comp-just (cond ((eq calc-matrix-just 'right) 'vright)
190 ((eq calc-matrix-just 'center) 'vcent)
192 (break calc-break-vectors))
193 (if (and (memq calc-language '(nil big))
194 (not calc-break-vectors)
195 (math-matrixp a) (not (math-matrixp (nth 1 a)))
196 (or calc-full-vectors
197 (and (< (length a) 7) (< (length (nth 1 a)) 7))
198 (progn (setq break t) nil)))
200 (setq math-comp-vector-prec (if (or (and calc-vector-commas
201 (math-vector-no-parens
203 (memq 'P calc-matrix-brackets))
207 (concat math-comp-left-bracket math-comp-left-bracket " ")
208 (math-compose-vector (cdr (nth 1 a)) (concat math-comp-comma " ")
209 math-comp-vector-prec)
210 (concat " " math-comp-right-bracket math-comp-right-bracket))
211 (let* ((rows (1- (length a)))
212 (cols (1- (length (nth 1 a))))
213 (base (/ (1- rows) 2))
214 (calc-language 'flat))
216 (list (append '(vleft)
218 (list (concat (and outer-brackets
219 (concat math-comp-left-bracket
222 (concat math-comp-left-bracket
225 (concat (and outer-brackets
229 math-comp-left-bracket
231 (math-compose-matrix (cdr a) 1 cols base)
232 (list (append '(vleft)
237 math-comp-right-bracket
240 (if (and outer-brackets
246 math-comp-right-bracket))
250 math-comp-right-bracket)))))))))
251 (if (and calc-display-strings
253 (math-vector-is-string a))
254 (math-vector-to-string a t)
255 (if (and break (cdr a)
256 (not (eq calc-language 'flat)))
257 (let* ((full (or calc-full-vectors (< (length a) 7)))
258 (rows (if full (1- (length a)) 5))
259 (base (/ (1- rows) 2))
260 (calc-break-vectors nil))
262 (cons 'vleft (cons base
265 (if full rows 3) t)))))
266 (if (or calc-full-vectors (< (length a) 7))
267 (if (and (eq calc-language 'tex)
269 (if (and (integerp calc-language-option)
270 (or (= calc-language-option 0)
271 (> calc-language-option 1)
272 (< calc-language-option -1)))
273 (append '(vleft 0 "\\matrix{")
274 (math-compose-tex-matrix (cdr a))
276 (append '(horiz "\\matrix{ ")
277 (math-compose-tex-matrix (cdr a))
279 (if (and (eq calc-language 'latex)
281 (if (and (integerp calc-language-option)
282 (or (= calc-language-option 0)
283 (> calc-language-option 1)
284 (< calc-language-option -1)))
285 (append '(vleft 0 "\\begin{pmatrix}")
286 (math-compose-tex-matrix (cdr a))
288 (append '(horiz "\\begin{pmatrix} ")
289 (math-compose-tex-matrix (cdr a))
290 '(" \\end{pmatrix}")))
291 (if (and (eq calc-language 'eqn)
293 (append '(horiz "matrix { ")
294 (math-compose-eqn-matrix
295 (cdr (math-transpose a)))
297 (if (and (eq calc-language 'maple)
301 math-comp-left-bracket
302 (math-compose-vector (cdr a)
303 (concat math-comp-comma " ")
304 math-comp-vector-prec)
305 math-comp-right-bracket
308 math-comp-left-bracket
309 (math-compose-vector (cdr a)
310 (concat math-comp-comma " ")
311 math-comp-vector-prec)
312 math-comp-right-bracket)))))
314 math-comp-left-bracket
315 (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
316 (concat math-comp-comma " ")
317 math-comp-vector-prec)
318 math-comp-comma (if (memq calc-language '(tex latex))
321 (list 'break math-compose-level)
322 (math-compose-expr (nth (1- (length a)) a)
323 (if (equal math-comp-comma "") 1000 0))
324 math-comp-right-bracket)))))))
325 ((eq (car a) 'incomplete)
327 (cond ((eq (nth 1 a) 'vec)
329 (math-compose-vector (cdr (cdr a)) ", " 0)
331 ((eq (nth 1 a) 'cplx)
333 (math-compose-vector (cdr (cdr a)) ", " 0)
335 ((eq (nth 1 a) 'polar)
337 (math-compose-vector (cdr (cdr a)) "; " 0)
339 ((eq (nth 1 a) 'intv)
341 (if (memq (nth 2 a) '(0 1)) "(" "[")
342 (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
345 (cond ((eq (nth 1 a) 'vec) "[ ...")
346 ((eq (nth 1 a) 'intv)
347 (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
350 (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
352 (symbol-name (car v))
353 (if (and (memq calc-language '(tex latex))
355 (not (= calc-language-option 0))
356 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
357 (symbol-name (nth 1 a))))
358 (if (eq calc-language 'latex)
359 (format "\\text{%s}" (symbol-name (nth 1 a)))
360 (format "\\hbox{%s}" (symbol-name (nth 1 a))))
361 (if (and math-compose-hash-args
362 (let ((p calc-arg-values))
364 (while (and p (not (equal (car p) a)))
365 (setq p (and (eq math-compose-hash-args t) (cdr p))
368 (if (eq math-compose-hash-args 1)
371 (if (memq calc-language '(c fortran pascal maple))
372 (math-to-underscores (symbol-name (nth 1 a)))
373 (if (and (eq calc-language 'eqn)
374 (string-match ".'\\'" (symbol-name (nth 2 a))))
376 (list 'calcFunc-Prime
379 (intern (substring (symbol-name (nth 1 a)) 0 -1))
380 (intern (substring (symbol-name (nth 2 a)) 0 -1))))
382 (symbol-name (nth 1 a)))))))))
385 (if (eq calc-language 'maple) ""
386 (if (memq (nth 1 a) '(0 1)) "(" "["))
387 (math-compose-expr (nth 2 a) 0)
388 (if (memq calc-language '(tex latex)) " \\ldots "
389 (if (eq calc-language 'eqn) " ... " " .. "))
390 (math-compose-expr (nth 3 a) 0)
391 (if (eq calc-language 'maple) ""
392 (if (memq (nth 1 a) '(0 2)) ")" "]"))))
394 (if (eq (car calc-date-format) 'X)
396 (concat "<" (math-format-date a) ">")))
397 ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a))
398 (memq calc-language '(c pascal fortran maple)))
399 (let ((args (cdr (cdr a))))
400 (while (and (memq calc-language '(pascal fortran))
401 (eq (car-safe (nth 1 a)) 'calcFunc-subscr))
402 (setq args (append (cdr (cdr (nth 1 a))) args)
405 (math-compose-expr (nth 1 a) 1000)
406 (if (eq calc-language 'fortran) "(" "[")
407 (math-compose-vector args ", " 0)
408 (if (eq calc-language 'fortran) ")" "]"))))
409 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
410 (eq calc-language 'big))
411 (let* ((a1 (math-compose-expr (nth 1 a) 1000))
412 (calc-language 'flat)
413 (a2 (math-compose-expr (nth 2 a) 0)))
414 (if (or (eq (car-safe a1) 'subscr)
415 (and (eq (car-safe a1) 'tag)
416 (eq (car-safe (nth 2 a1)) 'subscr)
417 (setq a1 (nth 2 a1))))
424 (list 'subscr a1 a2))))
425 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
426 (eq calc-language 'math))
428 (math-compose-expr (nth 1 a) 1000)
430 (math-compose-expr (nth 2 a) 0)
432 ((and (eq (car a) 'calcFunc-sqrt)
433 (memq calc-language '(tex latex)))
436 (math-compose-expr (nth 1 a) 0)
438 ((and nil (eq (car a) 'calcFunc-sqrt)
439 (eq calc-language 'eqn))
442 (math-compose-expr (nth 1 a) -1)
444 ((and (eq (car a) '^)
445 (eq calc-language 'big))
447 (if (or (math-looks-negp (nth 1 a))
448 (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
449 (and (eq (car-safe (nth 1 a)) 'cplx)
450 (math-negp (nth 1 (nth 1 a)))
451 (eq (nth 2 (nth 1 a)) 0)))
452 (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
453 (math-compose-expr (nth 1 a) 201))
454 (let ((calc-language 'flat)
455 (calc-number-radix 10))
456 (math-compose-expr (nth 2 a) 0))))
457 ((and (eq (car a) '/)
458 (eq calc-language 'big))
459 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
461 (math-compose-expr (nth 1 a) 0)))
462 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
464 (math-compose-expr (nth 2 a) 0))))
466 (math-comp-height a1)
468 ((and (memq (car a) '(calcFunc-sum calcFunc-prod))
469 (memq calc-language '(tex latex))
471 (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod")
472 "_{" (math-compose-expr (nth 2 a) 0)
473 "=" (math-compose-expr (nth 3 a) 0)
474 "}^{" (math-compose-expr (nth 4 a) 0)
475 "}{" (math-compose-expr (nth 1 a) 0) "}"))
476 ((and (eq (car a) 'calcFunc-lambda)
478 (memq calc-language '(nil flat big)))
481 (math-compose-hash-args (if (= (length a) 3) 1 t)))
482 (while (and (cdr p) (equal (car p) (car ap)))
483 (setq p (cdr p) ap (cdr ap)))
486 (list (math-compose-vector
487 (nreverse (cdr (reverse (cdr a)))) ", " 0)
490 (list (math-compose-expr (nth (1- (length a)) a) 0)
492 ((and (eq (car a) 'calcFunc-string)
494 (math-vectorp (nth 1 a))
495 (math-vector-is-string (nth 1 a)))
496 (if (eq calc-language 'unform)
497 (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
498 (math-vector-to-string (nth 1 a) nil)))
499 ((and (eq (car a) 'calcFunc-bstring)
501 (math-vectorp (nth 1 a))
502 (math-vector-is-string (nth 1 a)))
503 (if (eq calc-language 'unform)
504 (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
506 (s (math-vector-to-string (nth 1 a) nil))
508 (while (string-match "[^ ] +[^ ]" s)
509 (setq p (1- (match-end 0))
510 c (cons (list 'break math-compose-level)
511 (cons (substring s 0 p)
514 (setq c (nreverse (cons s c)))
516 (setq c (cons (list 'set math-compose-level 2) c)))
518 ((and (eq (car a) 'calcFunc-cprec)
519 (not (eq calc-language 'unform))
521 (integerp (nth 2 a)))
522 (let ((c (math-compose-expr (nth 1 a) -1)))
523 (if (> prec (nth 2 a))
524 (if (memq calc-language '(tex latex))
525 (list 'horiz "\\left( " c " \\right)")
526 (if (eq calc-language 'eqn)
527 (list 'horiz "{left ( " c " right )}")
528 (list 'horiz "(" c ")")))
530 ((and (eq (car a) 'calcFunc-choriz)
531 (not (eq calc-language 'unform))
532 (memq (length a) '(2 3 4))
533 (math-vectorp (nth 1 a))
534 (if (integerp (nth 2 a))
536 (and (math-vectorp (nth 3 a))
537 (math-vector-is-string (nth 3 a))))
539 (and (math-vectorp (nth 2 a))
540 (math-vector-is-string (nth 2 a))))))
541 (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
542 (sep (nth (if cprec 3 2) a))
545 (math-compose-vector (cdr (nth 1 a))
546 (math-vector-to-string sep nil)
548 (cons 'horiz (mapcar (function
550 (if (eq (car-safe x) 'calcFunc-bstring)
553 x (or bprec cprec prec))
555 (math-compose-expr x (or cprec prec)))))
557 ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
558 (not (eq calc-language 'unform))
559 (memq (length a) '(2 3))
560 (math-vectorp (nth 1 a))
562 (integerp (nth 2 a))))
565 (prec (or (nth 2 a) prec))
568 (let ((b nil) (cc nil) a d)
569 (if (and (memq (car-safe x) '(calcFunc-cbase
572 (memq (length x) '(1 2)))
575 (if (and (eq (car-safe x) 'calcFunc-crule)
576 (memq (length x) '(1 2))
578 (and (math-vectorp (nth 1 x))
579 (= (length (nth 1 x)) 2)
580 (math-vector-is-string
582 (and (natnump (nth 1 x))
583 (<= (nth 1 x) 255))))
586 (if (math-vectorp (nth 1 x))
587 (aref (math-vector-to-string
590 (or (and (memq (car-safe x) '(calcFunc-cvspace
593 (memq (length x) '(2 3))
596 (setq cc (math-compose-expr x prec))))
597 (setq a (if cc (math-comp-ascent cc) 0)
598 d (if cc (math-comp-descent cc) 0))
599 (if (eq b 'calcFunc-cbase)
600 (setq base (+ v a -1))
601 (if (eq b 'calcFunc-ctbase)
603 (if (eq b 'calcFunc-cbbase)
604 (setq base (+ v a d -1)))))
608 (setq c (delq nil c))
610 (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
611 (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
614 ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
615 (not (eq calc-language 'unform))
616 (memq (length a) '(3 4))
618 (integerp (nth 3 a))))
619 (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
620 (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
621 (math-compose-expr (nth 2 a) 0)))
622 ((and (eq (car a) 'calcFunc-cflat)
623 (not (eq calc-language 'unform))
624 (memq (length a) '(2 3))
626 (integerp (nth 2 a))))
627 (let ((calc-language (if (memq calc-language '(nil big))
628 'flat calc-language)))
629 (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
630 ((and (eq (car a) 'calcFunc-cspace)
631 (memq (length a) '(2 3))
634 (cons 'horiz (make-list (nth 1 a)
635 (if (and (math-vectorp (nth 2 a))
636 (math-vector-is-string (nth 2 a)))
637 (math-vector-to-string (nth 2 a) nil)
638 (math-compose-expr (nth 2 a) 0))))
639 (make-string (nth 1 a) ?\ )))
640 ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
641 (memq (length a) '(2 3))
645 (let* ((c (if (nth 2 a)
646 (if (and (math-vectorp (nth 2 a))
647 (math-vector-is-string (nth 2 a)))
648 (math-vector-to-string (nth 2 a) nil)
649 (math-compose-expr (nth 2 a) 0))
651 (ca (math-comp-ascent c))
652 (cd (math-comp-descent c)))
654 (cons (if (eq (car a) 'calcFunc-ctspace)
656 (if (eq (car a) 'calcFunc-cbspace)
657 (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
658 (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
659 (make-list (nth 1 a) c))))))
660 ((and (eq (car a) 'calcFunc-evalto)
661 (setq calc-any-evaltos t)
662 (memq calc-language '(tex latex eqn))
663 (= math-compose-level (if math-comp-tagged 2 1))
666 (if (memq calc-language '(tex latex)) "\\evalto " "evalto ")
667 (math-compose-expr (nth 1 a) 0)
668 (if (memq calc-language '(tex latex)) " \\to " " -> ")
669 (math-compose-expr (nth 2 a) 0)))
671 (let ((op (and (not (eq calc-language 'unform))
672 (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
673 (assoc "?" math-expr-opers)
674 (math-assq2 (car a) math-expr-opers)))))
676 (or (= (length a) 3) (eq (car a) 'calcFunc-if))
679 ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
680 (if (and (memq calc-language '(tex latex))
681 (not (math-tex-expr-is-flat a)))
682 (if (eq (car-safe a) '/)
683 (list 'horiz "{" (math-compose-expr a -1) "}")
684 (list 'horiz "\\left( "
685 (math-compose-expr a -1)
687 (if (eq calc-language 'eqn)
688 (if (or (eq (car-safe a) '/)
690 (list 'horiz "{" (math-compose-expr a -1) "}")
691 (if (math-tex-expr-is-flat a)
692 (list 'horiz "( " (math-compose-expr a -1) " )")
693 (list 'horiz "{left ( "
694 (math-compose-expr a -1)
696 (list 'horiz "(" (math-compose-expr a 0) ")"))))
697 ((and (memq calc-language '(tex latex))
698 (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
700 (list 'horiz "{" (math-compose-expr a -1) "}"))
701 ((eq (car a) 'calcFunc-if)
703 (math-compose-expr (nth 1 a) (nth 2 op))
705 (math-compose-expr (nth 2 a) 0)
707 (math-compose-expr (nth 3 a) (nth 3 op))))
709 (let* ((math-comp-tagged (and math-comp-tagged
712 (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
714 (setq math-compose-level
715 (1- math-compose-level))
718 (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
719 (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
720 (and (equal (car op) "^")
721 (eq (math-comp-first-char lhs) ?-)
722 (setq lhs (list 'horiz "(" lhs ")")))
723 (and (memq calc-language '(tex latex))
724 (or (equal (car op) "^") (equal (car op) "_"))
725 (not (and (stringp rhs) (= (length rhs) 1)))
726 (setq rhs (list 'horiz "{" rhs "}")))
727 (or (and (eq (car a) '*)
728 (or (null calc-language)
729 (assoc "2x" math-expr-opers))
730 (let* ((prevt (math-prod-last-term (nth 1 a)))
731 (nextt (math-prod-first-term (nth 2 a)))
732 (prevc (or (math-comp-last-char lhs)
733 (and (memq (car-safe prevt)
737 (eq calc-language 'big)
739 (nextc (or (math-comp-first-char rhs)
740 (and (memq (car-safe nextt)
745 (eq calc-language 'big)
748 (or (and (>= nextc ?a) (<= nextc ?z))
749 (and (>= nextc ?A) (<= nextc ?Z))
750 (and (>= nextc ?0) (<= nextc ?9))
751 (memq nextc '(?. ?_ ?#
756 (math-comp-first-string
758 (not (and (eq (car-safe prevt) 'var)
763 (list 'break math-compose-level)
769 (list 'break math-compose-level)
770 (if (or (equal (car op) "^")
772 (equal (car op) "**")
773 (and (equal (car op) "*")
774 (math-comp-last-char lhs)
775 (math-comp-first-char rhs))
776 (and (equal (car op) "/")
777 (math-num-integerp (nth 1 a))
778 (math-integerp (nth 2 a))))
780 (if (and (eq calc-language 'big)
781 (equal (car op) "=>"))
783 (concat " " (car op) " ")))
785 ((and op (= (length a) 2) (= (nth 3 op) -1))
787 ((or (> prec (or (nth 4 op) (nth 2 op)))
788 (and (not (eq (assoc (car op) math-expr-opers) op))
789 (> prec 0))) ; don't write x% + y
790 (if (and (memq calc-language '(tex latex))
791 (not (math-tex-expr-is-flat a)))
792 (list 'horiz "\\left( "
793 (math-compose-expr a -1)
795 (if (eq calc-language 'eqn)
796 (if (= (/ prec 100) 9)
797 (list 'horiz "{" (math-compose-expr a -1) "}")
798 (if (math-tex-expr-is-flat a)
799 (list 'horiz "{( " (math-compose-expr a -1) " )}")
800 (list 'horiz "{left ( "
801 (math-compose-expr a -1)
803 (list 'horiz "(" (math-compose-expr a 0) ")"))))
805 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
808 (if (or (> (length (car op)) 1)
809 (not (math-comp-is-flat lhs)))
810 (concat " " (car op))
812 ((and op (= (length a) 2) (= (nth 2 op) -1))
815 (let ((lr (and (memq calc-language '(tex latex))
816 (not (math-tex-expr-is-flat (nth 1 a))))))
819 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
820 (substring (car op) 1)
822 (if (or lr (> (length (car op)) 2)) " " "")
823 (math-compose-expr (nth 1 a) -1)
824 (if (or lr (> (length (car op)) 2)) " " "")
826 (car (nth 1 (memq op math-expr-opers))))))
827 ((> prec (or (nth 4 op) (nth 3 op)))
828 (if (and (memq calc-language '(tex latex))
829 (not (math-tex-expr-is-flat a)))
830 (list 'horiz "\\left( "
831 (math-compose-expr a -1)
833 (if (eq calc-language 'eqn)
834 (if (= (/ prec 100) 9)
835 (list 'horiz "{" (math-compose-expr a -1) "}")
836 (if (math-tex-expr-is-flat a)
837 (list 'horiz "{( " (math-compose-expr a -1) " )}")
838 (list 'horiz "{left ( "
839 (math-compose-expr a -1)
841 (list 'horiz "(" (math-compose-expr a 0) ")"))))
843 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
845 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
847 (substring (car op) 1)
849 (if (or (> (length ops) 1)
850 (not (math-comp-is-flat rhs)))
854 ((and (eq calc-language 'big)
855 (setq op (get (car a) 'math-compose-big))
856 (funcall op a prec)))
857 ((and (setq op (assq calc-language
858 '( ( nil . math-compose-normal )
859 ( flat . math-compose-normal )
860 ( big . math-compose-normal )
861 ( c . math-compose-c )
862 ( pascal . math-compose-pascal )
863 ( fortran . math-compose-fortran )
864 ( tex . math-compose-tex )
865 ( latex . math-compose-latex )
866 ( eqn . math-compose-eqn )
867 ( math . math-compose-math )
868 ( maple . math-compose-maple ))))
869 (setq op (get (car a) (cdr op)))
870 (funcall op a prec)))
872 (let* ((func (car a))
873 (func2 (assq func '(( mod . calcFunc-makemod )
874 ( sdev . calcFunc-sdev )
881 ( neg . calcFunc-neg )
882 ( | . calcFunc-vconcat ))))
885 (setq func (cdr func2)))
886 (if (setq func2 (rassq func math-expr-function-mapping))
887 (setq func (car func2)))
888 (setq func (math-remove-dashes
890 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
892 (math-match-substring (symbol-name func) 1)
893 (symbol-name func))))
894 (if (memq calc-language '(c fortran pascal maple))
895 (setq func (math-to-underscores func)))
896 (if (and (memq calc-language '(tex latex))
898 (not (= calc-language-option 0))
899 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func))
900 (if (< (prefix-numeric-value calc-language-option) 0)
901 (setq func (format "\\%s" func))
902 (setq func (if (eq calc-language 'latex)
903 (format "\\text{%s}" func)
904 (format "\\hbox{%s}" func)))))
905 (if (and (eq calc-language 'eqn)
906 (string-match "[^']'+\\'" func))
907 (let ((n (- (length func) (match-beginning 0) 1)))
908 (setq func (substring func 0 (- n)))
909 (while (>= (setq n (1- n)) 0)
910 (setq func (concat func " prime")))))
911 (cond ((and (memq calc-language '(tex latex))
913 (not (math-tex-expr-is-flat (nth 1 a)))))
914 (setq left "\\left( "
916 ((and (eq calc-language 'eqn)
918 (not (math-tex-expr-is-flat (nth 1 a)))))
919 (setq left "{left ( "
921 ((and (or (and (memq calc-language '(tex latex))
922 (eq (aref func 0) ?\\))
923 (and (eq calc-language 'eqn)
924 (memq (car a) math-eqn-special-funcs)))
926 (string-match "\\hbox{" func)
927 (string-match "\\text{" func)))
929 (or (Math-realp (nth 1 a))
930 (memq (car (nth 1 a)) '(var *))))
931 (setq left (if (eq calc-language 'eqn) "~{" "{")
933 ((eq calc-language 'eqn)
936 (t (setq left calc-function-open
937 right calc-function-close)))
938 (list 'horiz func left
939 (math-compose-vector (cdr a)
940 (if (eq calc-language 'eqn)
946 (defun math-prod-first-term (x)
947 (while (eq (car-safe x) '*)
951 (defun math-prod-last-term (x)
952 (while (eq (car-safe x) '*)
956 (defun math-compose-vector (a sep prec)
959 (cons (list 'set math-compose-level)
960 (let ((c (list (math-compose-expr (car a) prec))))
961 (while (setq a (cdr a))
962 (setq c (cons (if (eq (car-safe (car a))
964 (let ((math-compose-level
965 (1- math-compose-level)))
966 (math-compose-expr (car a) -123))
967 (math-compose-expr (car a) prec))
968 (cons (list 'break math-compose-level)
973 (defun math-vector-no-parens (a)
975 (not (eq (car-safe (nth 1 a)) '*))))
977 (defun math-compose-matrix (a col cols base)
980 (while (<= (setq col (1+ col)) cols)
981 (setq res (cons (cons math-comp-just
988 math-comp-vector-prec)
992 math-comp-comma-spc " ")))))
997 (defun math-compose-rows (a count first)
1001 (math-compose-rows (cdr a) -1 nil)
1002 (cons (concat (if (memq calc-language '(tex latex)) " \\ldots" " ...")
1004 (math-compose-rows (cdr a) -1 nil)))
1006 (if first (concat math-comp-left-bracket " ") " ")
1007 (math-compose-expr (car a) math-comp-vector-prec)
1009 (math-compose-rows (cdr a) (1- count) nil)))
1011 (if first (concat math-comp-left-bracket " ") " ")
1012 (math-compose-expr (car a) math-comp-vector-prec)
1013 (concat " " math-comp-right-bracket)))))
1015 (defun math-compose-tex-matrix (a)
1017 (cons (append (math-compose-vector (cdr (car a)) " & " 0) '(" \\\\ "))
1018 (math-compose-tex-matrix (cdr a)))
1019 (list (math-compose-vector (cdr (car a)) " & " 0))))
1021 (defun math-compose-eqn-matrix (a)
1024 (cond ((eq calc-matrix-just 'right) "rcol ")
1025 ((eq calc-matrix-just 'center) "ccol ")
1028 (list 'break math-compose-level)
1032 (let ((math-compose-level (1+ math-compose-level)))
1033 (math-compose-vector (cdr (car a)) " above " 1000))
1036 (math-compose-eqn-matrix (cdr a)))))))
1039 (defun math-vector-is-string (a)
1040 (while (and (setq a (cdr a))
1041 (or (and (natnump (car a))
1043 (and (eq (car-safe (car a)) 'cplx)
1044 (natnump (nth 1 (car a)))
1045 (eq (nth 2 (car a)) 0)
1046 (<= (nth 1 (car a)) 255)))))
1049 (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
1060 (defun math-vector-to-string (a &optional quoted)
1061 (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
1063 (if (string-match "[\000-\037\177\\\"]" a)
1065 (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
1066 (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
1067 (fmt (if quoted "\\^%c" "^%c"))
1069 (while (setq p (string-match pat a p))
1070 (if (setq new (assq (aref a p) codes))
1071 (setq a (concat (substring a 0 p)
1073 (substring a (1+ p)))
1074 p (+ p (length (cdr new))))
1075 (setq a (concat (substring a 0 p)
1076 (format fmt (+ (aref a p) 64))
1077 (substring a (1+ p)))
1080 (concat "\"" a "\"")
1084 (defun math-to-underscores (x)
1085 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
1086 (math-to-underscores
1087 (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
1090 (defun math-tex-expr-is-flat (a)
1091 (or (Math-integerp a)
1092 (memq (car a) '(float var))
1093 (and (memq (car a) '(+ - * neg))
1095 (while (and (setq a (cdr a))
1096 (math-tex-expr-is-flat (car a))))
1098 (and (memq (car a) '(^ calcFunc-subscr))
1099 (math-tex-expr-is-flat (nth 1 a)))))
1101 (put 'calcFunc-log 'math-compose-big 'math-compose-log)
1102 (defun math-compose-log (a prec)
1103 (and (= (length a) 3)
1106 (let ((calc-language 'flat))
1107 (math-compose-expr (nth 2 a) 1000)))
1109 (math-compose-expr (nth 1 a) 1000)
1112 (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
1113 (defun math-compose-log10 (a prec)
1114 (and (= (length a) 2)
1116 (list 'subscr "log" "10")
1118 (math-compose-expr (nth 1 a) 1000)
1121 (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
1122 (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
1123 (defun math-compose-deriv (a prec)
1124 (when (= (length a) 3)
1125 (math-compose-expr (list '/
1126 (list 'calcFunc-choriz
1128 '(calcFunc-string (vec ?d))
1130 (list 'calcFunc-choriz
1132 '(calcFunc-string (vec ?d))
1136 (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
1137 (defun math-compose-sqrt (a prec)
1138 (when (= (length a) 2)
1139 (let* ((c (math-compose-expr (nth 1 a) 0))
1140 (a (math-comp-ascent c))
1141 (d (math-comp-descent c))
1143 (w (math-comp-width c)))
1146 (concat (if (= h 1) " " " ")
1147 (make-string (+ w 2) ?\_))
1151 (append (list 'vleft (1- a))
1152 (make-list (1- h) " |")
1157 (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
1158 (defun math-compose-choose (a prec)
1159 (let ((a1 (math-compose-expr (nth 1 a) 0))
1160 (a2 (math-compose-expr (nth 2 a) 0)))
1164 (math-comp-height a1)
1168 (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
1169 (defun math-compose-integ (a prec)
1170 (and (memq (length a) '(3 5))
1171 (eq (car-safe (nth 2 a)) 'var)
1172 (let* ((parens (and (>= prec 196) (/= prec 1000)))
1173 (var (math-compose-expr (nth 2 a) 0))
1174 (over (and (eq (car-safe (nth 2 a)) 'var)
1175 (or (and (eq (car-safe (nth 1 a)) '/)
1176 (math-numberp (nth 1 (nth 1 a))))
1177 (and (eq (car-safe (nth 1 a)) '^)
1178 (math-looks-negp (nth 2 (nth 1 a)))))))
1179 (expr (math-compose-expr (if over
1181 (math-build-var-name
1184 (nth 1 (nth 2 a)))))
1186 (calc-language 'flat)
1187 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1188 (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
1191 (append (list 'vcent (if high 3 2))
1192 (and high (list (list 'horiz " " high)))
1198 (and low (list (list 'horiz low " "))))
1202 (list 'horiz " d" var))
1203 (if parens ")" "")))))
1205 (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
1206 (defun math-compose-sum (a prec)
1207 (and (memq (length a) '(3 5 6))
1208 (let* ((expr (math-compose-expr (nth 1 a) 185))
1209 (calc-language 'flat)
1210 (var (math-compose-expr (nth 2 a) 0))
1211 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1212 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1214 (if (memq prec '(180 201)) "(" "")
1215 (append (list 'vcent (if high 3 2))
1216 (and high (list high))
1223 (list (list 'horiz var " = " low))
1225 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1228 (if (memq prec '(180 201)) ")" "")))))
1230 (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
1231 (defun math-compose-prod (a prec)
1232 (and (memq (length a) '(3 5 6))
1233 (let* ((expr (math-compose-expr (nth 1 a) 198))
1234 (calc-language 'flat)
1235 (var (math-compose-expr (nth 2 a) 0))
1236 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1237 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1239 (if (memq prec '(196 201)) "(" "")
1240 (append (list 'vcent (if high 3 2))
1241 (and high (list high))
1247 (list (list 'horiz var " = " low))
1249 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1252 (if (memq prec '(196 201)) ")" "")))))
1254 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1255 ;; to math-stack-value-offset in calc.el, but are used by
1256 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1258 (defvar math-svo-wid)
1259 (defvar math-svo-off)
1261 (defun math-stack-value-offset-fancy ()
1262 (let ((cwid (+ (math-comp-width math-svo-c))))
1263 (cond ((eq calc-display-just 'right)
1264 (if calc-display-origin
1265 (setq math-svo-wid (max calc-display-origin 5))
1266 (if (integerp calc-line-breaking)
1267 (setq math-svo-wid calc-line-breaking)))
1268 (setq math-svo-off (- math-svo-wid cwid
1269 (max (- (length calc-right-label)
1270 (if (and (integerp calc-line-breaking)
1271 calc-display-origin)
1272 (max (- calc-line-breaking
1273 calc-display-origin)
1278 (if calc-display-origin
1280 (setq math-svo-off (- calc-display-origin (/ cwid 2)))
1281 (if (integerp calc-line-breaking)
1282 (setq math-svo-off (min math-svo-off (- calc-line-breaking cwid
1283 (length calc-right-label)))))
1284 (if (>= math-svo-off 0)
1285 (setq math-svo-wid (max math-svo-wid (+ math-svo-off cwid)))))
1286 (if (integerp calc-line-breaking)
1287 (setq math-svo-wid calc-line-breaking))
1288 (setq math-svo-off (/ (- math-svo-wid cwid) 2)))))
1289 (and (integerp calc-line-breaking)
1290 (or (< math-svo-off 0)
1291 (and calc-display-origin
1292 (> calc-line-breaking calc-display-origin)))
1293 (setq math-svo-wid calc-line-breaking))))
1296 ;;; Convert a composition to string form, with embedded \n's if necessary.
1298 (defun math-composition-to-string (c &optional width)
1299 (or width (setq width (calc-window-width)))
1300 (if calc-display-raw
1301 (math-comp-to-string-raw c 0)
1302 (if (math-comp-is-flat c)
1303 (math-comp-to-string-flat c width)
1304 (math-vert-comp-to-string
1305 (math-comp-simplify c width)))))
1307 (defvar math-comp-buf-string (make-vector 10 ""))
1308 (defvar math-comp-buf-margin (make-vector 10 0))
1309 (defvar math-comp-buf-level (make-vector 10 0))
1310 (defun math-comp-is-flat (c) ; check if c's height is 1.
1311 (cond ((not (consp c)) t)
1312 ((memq (car c) '(set break)) t)
1313 ((eq (car c) 'horiz)
1314 (while (and (setq c (cdr c))
1315 (math-comp-is-flat (car c))))
1317 ((memq (car c) '(vleft vcent vright))
1318 (and (= (length c) 3)
1320 (math-comp-is-flat (nth 2 c))))
1322 (math-comp-is-flat (nth 2 c)))
1326 ;;; Convert a one-line composition to a string. Break into multiple
1327 ;;; lines if necessary, choosing break points according to the structure
1330 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1331 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1332 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1333 ;; which is called by math-comp-to-string-flat.
1334 ;; math-comp-highlight and math-comp-buf are also local to
1335 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1336 ;; by math-comp-add-string.
1337 (defvar math-comp-full-width)
1338 (defvar math-comp-highlight)
1339 (defvar math-comp-word)
1340 (defvar math-comp-level)
1341 (defvar math-comp-margin)
1342 (defvar math-comp-buf)
1343 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1344 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1345 ;; which are called by math-comp-to-string-flat.
1346 (defvar math-comp-pos)
1348 (defun math-comp-to-string-flat (c math-comp-full-width)
1349 (if math-comp-sel-hpos
1350 (let ((math-comp-pos 0))
1351 (math-comp-sel-flat-term c))
1352 (let ((math-comp-buf "")
1355 (math-comp-margin 0)
1356 (math-comp-highlight (and math-comp-selected calc-show-selections))
1357 (math-comp-level -1))
1358 (math-comp-to-string-flat-term '(set -1 0))
1359 (math-comp-to-string-flat-term c)
1360 (math-comp-to-string-flat-term '(break -1))
1361 (let ((str (aref math-comp-buf-string 0))
1363 (and (> (length str) 0) (= (aref str 0) ? )
1364 (> (length math-comp-buf) 0)
1365 (let ((k (length math-comp-buf)))
1366 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1367 (aset math-comp-buf k ? )
1368 (if (and (< (1+ k) (length math-comp-buf))
1369 (= (aref math-comp-buf (1+ k)) ? ))
1371 (aset math-comp-buf (1+ k) ?\n)
1373 (setq prefix "\n"))))
1374 (concat math-comp-buf prefix str)))))
1376 (defun math-comp-to-string-flat-term (c)
1377 (cond ((not (consp c))
1378 (if math-comp-highlight
1379 (setq c (math-comp-highlight-string c)))
1380 (setq math-comp-word (if (= (length math-comp-word) 0) c
1381 (concat math-comp-word c))
1382 math-comp-pos (+ math-comp-pos (length c))))
1384 ((eq (car c) 'horiz)
1385 (while (setq c (cdr c))
1386 (math-comp-to-string-flat-term (car c))))
1391 (setq math-comp-level (1+ math-comp-level))
1392 (if (>= math-comp-level (length math-comp-buf-string))
1393 (setq math-comp-buf-string (vconcat math-comp-buf-string
1394 math-comp-buf-string)
1395 math-comp-buf-margin (vconcat math-comp-buf-margin
1396 math-comp-buf-margin)
1397 math-comp-buf-level (vconcat math-comp-buf-level
1398 math-comp-buf-level)))
1399 (aset math-comp-buf-string math-comp-level "")
1400 (aset math-comp-buf-margin math-comp-level (+ math-comp-pos
1402 (aset math-comp-buf-level math-comp-level (nth 1 c)))))
1404 ((eq (car c) 'break)
1405 (if (not calc-line-breaking)
1406 (setq math-comp-buf (concat math-comp-buf math-comp-word)
1409 (if (and (> math-comp-pos math-comp-full-width)
1412 (setq str (aref math-comp-buf-string i))
1413 (and (= (length str) 0) (< i math-comp-level)))
1415 (or (> (length str) 0) (> (length math-comp-buf) 0))))
1416 (let ((prefix "") mrg wid)
1417 (setq mrg (aref math-comp-buf-margin i))
1418 (if (> mrg 12) ; indenting too far, go back to far left
1419 (let ((j i) (new (if calc-line-numbering 5 1)))
1420 '(while (<= j math-comp-level)
1421 (aset math-comp-buf-margin j
1422 (+ (aref math-comp-buf-margin j) (- new mrg)))
1425 (setq wid (+ (length str) math-comp-margin))
1426 (and (> (length str) 0) (= (aref str 0) ? )
1427 (> (length math-comp-buf) 0)
1428 (let ((k (length math-comp-buf)))
1429 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1430 (aset math-comp-buf k ? )
1431 (if (and (< (1+ k) (length math-comp-buf))
1432 (= (aref math-comp-buf (1+ k)) ? ))
1434 (aset math-comp-buf (1+ k) ?\n)
1436 (setq prefix "\n"))))
1437 (setq math-comp-buf (concat math-comp-buf prefix str "\n"
1438 (make-string mrg ? ))
1439 math-comp-pos (+ math-comp-pos (- mrg wid))
1440 math-comp-margin mrg)
1441 (aset math-comp-buf-string i "")
1442 (while (<= (setq i (1+ i)) math-comp-level)
1443 (if (> (aref math-comp-buf-margin i) wid)
1444 (aset math-comp-buf-margin i
1445 (+ (aref math-comp-buf-margin i)
1447 (if (and (= (nth 1 c) (aref math-comp-buf-level math-comp-level))
1448 (< math-comp-pos (+ (aref math-comp-buf-margin math-comp-level) 2)))
1449 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1450 (let ((str (aref math-comp-buf-string math-comp-level)))
1451 (setq str (if (= (length str) 0)
1453 (concat str math-comp-word))
1455 (while (< (nth 1 c) (aref math-comp-buf-level math-comp-level))
1456 (setq math-comp-level (1- math-comp-level))
1457 (or (= (length (aref math-comp-buf-string math-comp-level)) 0)
1458 (setq str (concat (aref math-comp-buf-string math-comp-level)
1460 (aset math-comp-buf-string math-comp-level str)))))
1463 (cond ((eq (nth 1 c) math-comp-selected)
1464 (let ((math-comp-highlight (not calc-show-selections)))
1465 (math-comp-to-string-flat-term (nth 2 c))))
1467 (let ((math-comp-highlight nil))
1468 (math-comp-to-string-flat-term (nth 2 c))))
1469 (t (math-comp-to-string-flat-term (nth 2 c)))))
1471 (t (math-comp-to-string-flat-term (nth 2 c)))))
1473 (defun math-comp-highlight-string (s)
1474 (setq s (copy-sequence s))
1475 (let ((i (length s)))
1476 (while (>= (setq i (1- i)) 0)
1477 (or (memq (aref s i) '(32 ?\n))
1478 (aset s i (if calc-show-selections ?\. ?\#)))))
1482 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1483 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1484 ;; math-comp-add-string-sel, which are called (indirectly) by
1485 ;; calc-find-selected-part.
1486 (defvar math-comp-sel-tag)
1488 (defun math-comp-sel-flat-term (c)
1489 (cond ((not (consp c))
1490 (setq math-comp-pos (+ math-comp-pos (length c))))
1491 ((memq (car c) '(set break)))
1492 ((eq (car c) 'horiz)
1493 (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
1494 (math-comp-sel-flat-term (car c))))
1496 (if (<= math-comp-pos math-comp-sel-cpos)
1498 (math-comp-sel-flat-term (nth 2 c))
1499 (if (> math-comp-pos math-comp-sel-cpos)
1500 (setq math-comp-sel-tag c
1501 math-comp-sel-cpos 1000000)))
1502 (math-comp-sel-flat-term (nth 2 c))))
1503 (t (math-comp-sel-flat-term (nth 2 c)))))
1506 ;;; Simplify a composition to a canonical form consisting of
1507 ;;; (vleft n "string" "string" "string" ...)
1508 ;;; where 0 <= n < number-of-strings.
1510 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1511 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1512 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1513 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1514 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1515 ;; math-comp-simplify.
1516 (defvar math-comp-base)
1517 (defvar math-comp-hgt)
1518 (defvar math-comp-tag)
1519 (defvar math-comp-hpos)
1520 (defvar math-comp-vpos)
1522 (defun math-comp-simplify (c full-width)
1523 (let ((math-comp-buf (list ""))
1528 (math-comp-highlight (and math-comp-selected calc-show-selections))
1529 (math-comp-tag nil))
1530 (math-comp-simplify-term c)
1531 (cons 'vleft (cons math-comp-base math-comp-buf))))
1533 (defun math-comp-add-string (s h v)
1534 (and (> (length s) 0)
1535 (let ((vv (+ v math-comp-base)))
1536 (if math-comp-sel-hpos
1537 (math-comp-add-string-sel h vv (length s) 1)
1539 (setq math-comp-buf (nconc (make-list (- vv) "") math-comp-buf)
1540 math-comp-base (- v)
1541 math-comp-hgt (- math-comp-hgt vv)
1543 (if (>= vv math-comp-hgt)
1544 (setq math-comp-buf (nconc math-comp-buf
1545 (make-list (1+ (- vv math-comp-hgt)) ""))
1546 math-comp-hgt (1+ vv))))
1547 (let ((str (nthcdr vv math-comp-buf)))
1548 (setcar str (concat (car str)
1549 (make-string (- h (length (car str))) 32)
1550 (if math-comp-highlight
1551 (math-comp-highlight-string s)
1554 (defun math-comp-add-string-sel (x y w h)
1555 (if (and (<= y math-comp-sel-vpos)
1556 (> (+ y h) math-comp-sel-vpos)
1557 (<= x math-comp-sel-hpos)
1558 (> (+ x w) math-comp-sel-hpos))
1559 (setq math-comp-sel-tag math-comp-tag
1560 math-comp-sel-vpos 10000)))
1562 (defun math-comp-simplify-term (c)
1564 (math-comp-add-string c math-comp-hpos math-comp-vpos)
1565 (setq math-comp-hpos (+ math-comp-hpos (length c))))
1566 ((memq (car c) '(set break))
1568 ((eq (car c) 'horiz)
1569 (while (setq c (cdr c))
1570 (math-comp-simplify-term (car c))))
1571 ((memq (car c) '(vleft vcent vright))
1572 (let* ((math-comp-vpos (+ (- math-comp-vpos (nth 1 c))
1573 (1- (math-comp-ascent (nth 2 c)))))
1574 (widths (mapcar 'math-comp-width (cdr (cdr c))))
1575 (maxwid (apply 'max widths))
1576 (bias (cond ((eq (car c) 'vleft) 0)
1577 ((eq (car c) 'vcent) 1)
1580 (while (setq c (cdr c))
1581 (if (eq (car-safe (car c)) 'rule)
1582 (math-comp-add-string (make-string maxwid (nth 1 (car c)))
1583 math-comp-hpos math-comp-vpos)
1584 (let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid
1587 (math-comp-simplify-term (car c))))
1589 (setq math-comp-vpos (+ math-comp-vpos
1590 (+ (math-comp-descent (car c))
1591 (math-comp-ascent (nth 1 c))))
1592 widths (cdr widths))))
1593 (setq math-comp-hpos (+ math-comp-hpos maxwid))))
1594 ((eq (car c) 'supscr)
1595 (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
1596 (desc (math-comp-descent (nth 2 c)))
1599 (math-comp-simplify-term (nth 1 c))))
1600 (math-comp-vpos (- math-comp-vpos (+ asc desc))))
1601 (math-comp-simplify-term (nth 2 c))
1602 (if math-comp-sel-hpos
1603 (math-comp-add-string-sel oldh
1606 (math-comp-ascent (nth 2 c)))
1607 (- math-comp-hpos oldh)
1608 (math-comp-height c)))))
1609 ((eq (car c) 'subscr)
1610 (let* ((asc (math-comp-ascent (nth 2 c)))
1611 (desc (math-comp-descent (nth 1 c)))
1612 (oldv math-comp-vpos)
1615 (math-comp-simplify-term (nth 1 c))))
1616 (math-comp-vpos (+ math-comp-vpos (+ asc desc))))
1617 (math-comp-simplify-term (nth 2 c))
1618 (if math-comp-sel-hpos
1619 (math-comp-add-string-sel oldh oldv
1620 (- math-comp-hpos oldh)
1621 (math-comp-height c)))))
1623 (cond ((eq (nth 1 c) math-comp-selected)
1624 (let ((math-comp-highlight (not calc-show-selections)))
1625 (math-comp-simplify-term (nth 2 c))))
1627 (let ((math-comp-highlight nil))
1628 (math-comp-simplify-term (nth 2 c))))
1629 (t (let ((math-comp-tag c))
1630 (math-comp-simplify-term (nth 2 c))))))))
1633 ;;; Measuring a composition.
1635 (defun math-comp-first-char (c)
1637 (and (> (length c) 0)
1639 ((memq (car c) '(horiz subscr supscr))
1640 (while (and (setq c (cdr c))
1641 (math-comp-is-null (car c))))
1642 (and c (math-comp-first-char (car c))))
1644 (math-comp-first-char (nth 2 c)))))
1646 (defun math-comp-first-string (c)
1648 (and (> (length c) 0)
1650 ((eq (car c) 'horiz)
1651 (while (and (setq c (cdr c))
1652 (math-comp-is-null (car c))))
1653 (and c (math-comp-first-string (car c))))
1655 (math-comp-first-string (nth 2 c)))))
1657 (defun math-comp-last-char (c)
1659 (and (> (length c) 0)
1660 (elt c (1- (length c)))))
1661 ((eq (car c) 'horiz)
1662 (let ((c (reverse (cdr c))))
1663 (while (and c (math-comp-is-null (car c)))
1665 (and c (math-comp-last-char (car c)))))
1667 (math-comp-last-char (nth 2 c)))))
1669 (defun math-comp-is-null (c)
1670 (cond ((stringp c) (= (length c) 0))
1671 ((memq (car c) '(horiz subscr supscr))
1672 (while (and (setq c (cdr c))
1673 (math-comp-is-null (car c))))
1676 (math-comp-is-null (nth 2 c)))
1677 ((memq (car c) '(set break)) t)))
1679 (defun math-comp-width (c)
1680 (cond ((not (consp c)) (length c))
1681 ((memq (car c) '(horiz subscr supscr))
1683 (while (setq c (cdr c))
1684 (setq accum (+ accum (math-comp-width (car c)))))
1686 ((memq (car c) '(vcent vleft vright))
1689 (while (setq c (cdr c))
1690 (setq accum (max accum (math-comp-width (car c)))))
1693 (math-comp-width (nth 2 c)))
1696 (defun math-comp-height (c)
1699 (+ (math-comp-ascent c) (math-comp-descent c))))
1701 (defun math-comp-ascent (c)
1702 (cond ((not (consp c)) 1)
1703 ((eq (car c) 'horiz)
1705 (while (setq c (cdr c))
1706 (setq accum (max accum (math-comp-ascent (car c)))))
1708 ((memq (car c) '(vcent vleft vright))
1709 (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
1710 ((eq (car c) 'supscr)
1711 (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
1712 ((eq (car c) 'subscr)
1713 (math-comp-ascent (nth 1 c)))
1715 (math-comp-ascent (nth 2 c)))
1718 (defun math-comp-descent (c)
1719 (cond ((not (consp c)) 0)
1720 ((eq (car c) 'horiz)
1722 (while (setq c (cdr c))
1723 (setq accum (max accum (math-comp-descent (car c)))))
1725 ((memq (car c) '(vcent vleft vright))
1726 (let ((accum (- (nth 1 c))))
1728 (while (setq c (cdr c))
1729 (setq accum (+ accum (math-comp-height (car c)))))
1730 (max (1- accum) 0)))
1731 ((eq (car c) 'supscr)
1732 (math-comp-descent (nth 1 c)))
1733 ((eq (car c) 'subscr)
1734 (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
1736 (math-comp-descent (nth 2 c)))
1739 (defun calcFunc-cwidth (a &optional prec)
1740 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1741 (math-comp-width (math-compose-expr a (or prec 0))))
1743 (defun calcFunc-cheight (a &optional prec)
1744 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1745 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1746 (memq (length a) '(2 3))
1749 (math-comp-height (math-compose-expr a (or prec 0)))))
1751 (defun calcFunc-cascent (a &optional prec)
1752 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1753 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1754 (memq (length a) '(2 3))
1757 (math-comp-ascent (math-compose-expr a (or prec 0)))))
1759 (defun calcFunc-cdescent (a &optional prec)
1760 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1761 (math-comp-descent (math-compose-expr a (or prec 0))))
1764 ;;; Convert a simplified composition into string form.
1766 (defun math-vert-comp-to-string (c)
1769 (math-vert-comp-to-string-step (cdr (cdr c)))))
1771 (defun math-vert-comp-to-string-step (c)
1773 (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
1777 ;;; Convert a composition to a string in "raw" form (for debugging).
1779 (defun math-comp-to-string-raw (c indent)
1780 (cond ((or (not (consp c)) (eq (car c) 'set))
1781 (prin1-to-string c))
1783 (concat "(" (symbol-name (car c)) ")"))
1785 (let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
1787 (symbol-name (car c))
1789 (math-comp-to-string-raw (nth 1 c) next-indent)
1790 (math-comp-to-string-raw-step (cdr (cdr c))
1794 (defun math-comp-to-string-raw-step (cl indent)
1797 (make-string indent 32)
1798 (math-comp-to-string-raw (car cl) indent)
1799 (math-comp-to-string-raw-step (cdr cl) indent))
1804 ;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1805 ;;; calccomp.el ends here