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 (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 ;; math-comp-just and math-comp-comma-spc are local to
65 ;; math-compose-expr, but are used by math-compose-matrix, which is
66 ;; called by math-compose-expr
67 (defvar math-comp-just)
68 (defvar math-comp-comma-spc)
70 ;; math-comp-vector-prec is local to math-compose-expr, but is used by
71 ;; math-compose-matrix and math-compose-rows, which are called by
73 (defvar math-comp-vector-prec)
75 ;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
76 ;; local to math-compose-expr, but are used by math-compose-rows, which is
77 ;; called by math-compose-expr.
78 (defvar math-comp-left-bracket)
79 (defvar math-comp-right-bracket)
80 (defvar math-comp-comma)
83 (defun math-compose-expr (a prec)
84 (let ((math-compose-level (1+ math-compose-level)))
86 ((or (and (eq a math-comp-selected) a)
88 (not (eq math-comp-tagged a))))
89 (let ((math-comp-selected nil))
90 (and math-comp-tagged (setq math-comp-tagged a))
91 (list 'tag a (math-compose-expr a prec))))
92 ((and (not (consp a)) (not (integerp a)))
93 (concat "'" (prin1-to-string a)))
95 (if (or (eq (car-safe a) 'frac)
96 (and (nth 1 calc-frac-format) (Math-integerp a)))
97 (if (memq calc-language '(tex eqn math maple c fortran pascal))
98 (let ((aa (math-adjust-fraction a))
99 (calc-frac-format nil))
100 (math-compose-expr (list '/
101 (if (memq calc-language '(c fortran))
102 (math-float (nth 1 aa))
105 (if (and (eq calc-language 'big)
106 (= (length (car calc-frac-format)) 1))
107 (let* ((aa (math-adjust-fraction a))
108 (calc-frac-format nil)
109 (math-radix-explicit-format nil)
111 (if (math-negp (nth 1 aa))
115 (math-abs (nth 1 aa)))
117 (math-format-number (nth 2 aa))))))
118 (if (= calc-number-radix 10)
122 (int-to-string calc-number-radix)))))
123 (math-format-number a)))
124 (if (not (eq calc-language 'big))
125 (math-format-number a prec)
126 (if (memq (car-safe a) '(cplx polar))
127 (if (math-zerop (nth 2 a))
128 (math-compose-expr (nth 1 a) prec)
130 (math-compose-expr (nth 1 a) 0)
131 (if (eq (car a) 'cplx) ", " "; ")
132 (math-compose-expr (nth 2 a) 0) ")"))
133 (if (or (= calc-number-radix 10)
135 (and calc-group-digits
136 (not (assoc calc-group-char '((",") (" "))))))
137 (math-format-number a prec)
138 (let ((s (math-format-number a prec))
140 (while (string-match (if (> calc-number-radix 14)
141 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
142 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
144 (setq c (nconc c (list (substring s 0 (match-beginning 0))
146 (math-match-substring s 2)
147 (math-match-substring s 1))))
148 s (substring s (match-end 0))))
150 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
152 (substring s 0 (match-beginning 0)) " "
154 (math-match-substring s 1)
155 (math-match-substring s 2))
156 (math-match-substring s 3))))
157 (if c (cons 'horiz (nconc c (list s))) s)))))))
158 ((and (get (car a) 'math-compose-forms)
159 (not (eq calc-language 'unform))
160 (let ((comps (get (car a) 'math-compose-forms))
162 (or (and (setq temp (assq calc-language comps))
163 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
164 (setq temp (apply (cdr temp2) (cdr a)))
165 (math-compose-expr temp prec))
166 (and (setq temp2 (assq nil (cdr temp)))
167 (funcall (cdr temp2) a))))
168 (and (setq temp (assq nil comps))
169 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
170 (setq temp (apply (cdr temp2) (cdr a)))
171 (math-compose-expr temp prec))
172 (and (setq temp2 (assq nil (cdr temp)))
173 (funcall (cdr temp2) a))))))))
175 (let* ((math-comp-left-bracket (if calc-vector-brackets
176 (substring calc-vector-brackets 0 1) ""))
177 (math-comp-right-bracket (if calc-vector-brackets
178 (substring calc-vector-brackets 1 2) ""))
179 (inner-brackets (memq 'R calc-matrix-brackets))
180 (outer-brackets (memq 'O calc-matrix-brackets))
181 (row-commas (memq 'C calc-matrix-brackets))
182 (math-comp-comma-spc (or calc-vector-commas " "))
183 (math-comp-comma (or calc-vector-commas ""))
184 (math-comp-vector-prec (if (or (and calc-vector-commas
185 (math-vector-no-parens a))
186 (memq 'P calc-matrix-brackets)) 0 1000))
187 (math-comp-just (cond ((eq calc-matrix-just 'right) 'vright)
188 ((eq calc-matrix-just 'center) 'vcent)
190 (break calc-break-vectors))
191 (if (and (memq calc-language '(nil big))
192 (not calc-break-vectors)
193 (math-matrixp a) (not (math-matrixp (nth 1 a)))
194 (or calc-full-vectors
195 (and (< (length a) 7) (< (length (nth 1 a)) 7))
196 (progn (setq break t) nil)))
198 (setq math-comp-vector-prec (if (or (and calc-vector-commas
199 (math-vector-no-parens
201 (memq 'P calc-matrix-brackets))
205 (concat math-comp-left-bracket math-comp-left-bracket " ")
206 (math-compose-vector (cdr (nth 1 a)) (concat math-comp-comma " ")
207 math-comp-vector-prec)
208 (concat " " math-comp-right-bracket math-comp-right-bracket))
209 (let* ((rows (1- (length a)))
210 (cols (1- (length (nth 1 a))))
211 (base (/ (1- rows) 2))
212 (calc-language 'flat))
214 (list (append '(vleft)
216 (list (concat (and outer-brackets
217 (concat math-comp-left-bracket
220 (concat math-comp-left-bracket
223 (concat (and outer-brackets
227 math-comp-left-bracket
229 (math-compose-matrix (cdr a) 1 cols base)
230 (list (append '(vleft)
235 math-comp-right-bracket
238 (if (and outer-brackets
244 math-comp-right-bracket))
248 math-comp-right-bracket)))))))))
249 (if (and calc-display-strings
251 (math-vector-is-string a))
252 (math-vector-to-string a t)
253 (if (and break (cdr a)
254 (not (eq calc-language 'flat)))
255 (let* ((full (or calc-full-vectors (< (length a) 7)))
256 (rows (if full (1- (length a)) 5))
257 (base (/ (1- rows) 2))
258 (calc-break-vectors nil))
260 (cons 'vleft (cons base
263 (if full rows 3) t)))))
264 (if (or calc-full-vectors (< (length a) 7))
265 (if (and (eq calc-language 'tex)
267 (append '(horiz "\\matrix{ ")
268 (math-compose-tex-matrix (cdr a))
270 (if (and (eq calc-language 'eqn)
272 (append '(horiz "matrix { ")
273 (math-compose-eqn-matrix
274 (cdr (math-transpose a)))
276 (if (and (eq calc-language 'maple)
280 math-comp-left-bracket
281 (math-compose-vector (cdr a)
282 (concat math-comp-comma " ")
283 math-comp-vector-prec)
284 math-comp-right-bracket
287 math-comp-left-bracket
288 (math-compose-vector (cdr a)
289 (concat math-comp-comma " ")
290 math-comp-vector-prec)
291 math-comp-right-bracket))))
293 math-comp-left-bracket
294 (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
295 (concat math-comp-comma " ")
296 math-comp-vector-prec)
297 math-comp-comma (if (eq calc-language 'tex) " \\ldots" " ...")
299 (list 'break math-compose-level)
300 (math-compose-expr (nth (1- (length a)) a)
301 (if (equal math-comp-comma "") 1000 0))
302 math-comp-right-bracket)))))))
303 ((eq (car a) 'incomplete)
305 (cond ((eq (nth 1 a) 'vec)
307 (math-compose-vector (cdr (cdr a)) ", " 0)
309 ((eq (nth 1 a) 'cplx)
311 (math-compose-vector (cdr (cdr a)) ", " 0)
313 ((eq (nth 1 a) 'polar)
315 (math-compose-vector (cdr (cdr a)) "; " 0)
317 ((eq (nth 1 a) 'intv)
319 (if (memq (nth 2 a) '(0 1)) "(" "[")
320 (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
323 (cond ((eq (nth 1 a) 'vec) "[ ...")
324 ((eq (nth 1 a) 'intv)
325 (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
328 (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
330 (symbol-name (car v))
331 (if (and (eq calc-language 'tex)
333 (not (= calc-language-option 0))
334 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
335 (symbol-name (nth 1 a))))
336 (format "\\hbox{%s}" (symbol-name (nth 1 a)))
337 (if (and math-compose-hash-args
338 (let ((p calc-arg-values))
340 (while (and p (not (equal (car p) a)))
341 (setq p (and (eq math-compose-hash-args t) (cdr p))
344 (if (eq math-compose-hash-args 1)
347 (if (memq calc-language '(c fortran pascal maple))
348 (math-to-underscores (symbol-name (nth 1 a)))
349 (if (and (eq calc-language 'eqn)
350 (string-match ".'\\'" (symbol-name (nth 2 a))))
352 (list 'calcFunc-Prime
355 (intern (substring (symbol-name (nth 1 a)) 0 -1))
356 (intern (substring (symbol-name (nth 2 a)) 0 -1))))
358 (symbol-name (nth 1 a)))))))))
361 (if (eq calc-language 'maple) ""
362 (if (memq (nth 1 a) '(0 1)) "(" "["))
363 (math-compose-expr (nth 2 a) 0)
364 (if (eq calc-language 'tex) " \\ldots "
365 (if (eq calc-language 'eqn) " ... " " .. "))
366 (math-compose-expr (nth 3 a) 0)
367 (if (eq calc-language 'maple) ""
368 (if (memq (nth 1 a) '(0 2)) ")" "]"))))
370 (if (eq (car calc-date-format) 'X)
372 (concat "<" (math-format-date a) ">")))
373 ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a))
374 (memq calc-language '(c pascal fortran maple)))
375 (let ((args (cdr (cdr a))))
376 (while (and (memq calc-language '(pascal fortran))
377 (eq (car-safe (nth 1 a)) 'calcFunc-subscr))
378 (setq args (append (cdr (cdr (nth 1 a))) args)
381 (math-compose-expr (nth 1 a) 1000)
382 (if (eq calc-language 'fortran) "(" "[")
383 (math-compose-vector args ", " 0)
384 (if (eq calc-language 'fortran) ")" "]"))))
385 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
386 (eq calc-language 'big))
387 (let* ((a1 (math-compose-expr (nth 1 a) 1000))
388 (calc-language 'flat)
389 (a2 (math-compose-expr (nth 2 a) 0)))
390 (if (or (eq (car-safe a1) 'subscr)
391 (and (eq (car-safe a1) 'tag)
392 (eq (car-safe (nth 2 a1)) 'subscr)
393 (setq a1 (nth 2 a1))))
400 (list 'subscr a1 a2))))
401 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
402 (eq calc-language 'math))
404 (math-compose-expr (nth 1 a) 1000)
406 (math-compose-expr (nth 2 a) 0)
408 ((and (eq (car a) 'calcFunc-sqrt)
409 (eq calc-language 'tex))
412 (math-compose-expr (nth 1 a) 0)
414 ((and nil (eq (car a) 'calcFunc-sqrt)
415 (eq calc-language 'eqn))
418 (math-compose-expr (nth 1 a) -1)
420 ((and (eq (car a) '^)
421 (eq calc-language 'big))
423 (if (or (math-looks-negp (nth 1 a))
424 (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
425 (and (eq (car-safe (nth 1 a)) 'cplx)
426 (math-negp (nth 1 (nth 1 a)))
427 (eq (nth 2 (nth 1 a)) 0)))
428 (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
429 (math-compose-expr (nth 1 a) 201))
430 (let ((calc-language 'flat)
431 (calc-number-radix 10))
432 (math-compose-expr (nth 2 a) 0))))
433 ((and (eq (car a) '/)
434 (eq calc-language 'big))
435 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
437 (math-compose-expr (nth 1 a) 0)))
438 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
440 (math-compose-expr (nth 2 a) 0))))
442 (math-comp-height a1)
444 ((and (memq (car a) '(calcFunc-sum calcFunc-prod))
445 (eq calc-language 'tex)
447 (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod")
448 "_{" (math-compose-expr (nth 2 a) 0)
449 "=" (math-compose-expr (nth 3 a) 0)
450 "}^{" (math-compose-expr (nth 4 a) 0)
451 "}{" (math-compose-expr (nth 1 a) 0) "}"))
452 ((and (eq (car a) 'calcFunc-lambda)
454 (memq calc-language '(nil flat big)))
457 (math-compose-hash-args (if (= (length a) 3) 1 t)))
458 (while (and (cdr p) (equal (car p) (car ap)))
459 (setq p (cdr p) ap (cdr ap)))
462 (list (math-compose-vector
463 (nreverse (cdr (reverse (cdr a)))) ", " 0)
466 (list (math-compose-expr (nth (1- (length a)) a) 0)
468 ((and (eq (car a) 'calcFunc-string)
470 (math-vectorp (nth 1 a))
471 (math-vector-is-string (nth 1 a)))
472 (if (eq calc-language 'unform)
473 (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
474 (math-vector-to-string (nth 1 a) nil)))
475 ((and (eq (car a) 'calcFunc-bstring)
477 (math-vectorp (nth 1 a))
478 (math-vector-is-string (nth 1 a)))
479 (if (eq calc-language 'unform)
480 (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
482 (s (math-vector-to-string (nth 1 a) nil))
484 (while (string-match "[^ ] +[^ ]" s)
485 (setq p (1- (match-end 0))
486 c (cons (list 'break math-compose-level)
487 (cons (substring s 0 p)
490 (setq c (nreverse (cons s c)))
492 (setq c (cons (list 'set math-compose-level 2) c)))
494 ((and (eq (car a) 'calcFunc-cprec)
495 (not (eq calc-language 'unform))
497 (integerp (nth 2 a)))
498 (let ((c (math-compose-expr (nth 1 a) -1)))
499 (if (> prec (nth 2 a))
500 (if (eq calc-language 'tex)
501 (list 'horiz "\\left( " c " \\right)")
502 (if (eq calc-language 'eqn)
503 (list 'horiz "{left ( " c " right )}")
504 (list 'horiz "(" c ")")))
506 ((and (eq (car a) 'calcFunc-choriz)
507 (not (eq calc-language 'unform))
508 (memq (length a) '(2 3 4))
509 (math-vectorp (nth 1 a))
510 (if (integerp (nth 2 a))
512 (and (math-vectorp (nth 3 a))
513 (math-vector-is-string (nth 3 a))))
515 (and (math-vectorp (nth 2 a))
516 (math-vector-is-string (nth 2 a))))))
517 (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
518 (sep (nth (if cprec 3 2) a))
521 (math-compose-vector (cdr (nth 1 a))
522 (math-vector-to-string sep nil)
524 (cons 'horiz (mapcar (function
526 (if (eq (car-safe x) 'calcFunc-bstring)
529 x (or bprec cprec prec))
531 (math-compose-expr x (or cprec prec)))))
533 ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
534 (not (eq calc-language 'unform))
535 (memq (length a) '(2 3))
536 (math-vectorp (nth 1 a))
538 (integerp (nth 2 a))))
541 (prec (or (nth 2 a) prec))
544 (let ((b nil) (cc nil) a d)
545 (if (and (memq (car-safe x) '(calcFunc-cbase
548 (memq (length x) '(1 2)))
551 (if (and (eq (car-safe x) 'calcFunc-crule)
552 (memq (length x) '(1 2))
554 (and (math-vectorp (nth 1 x))
555 (= (length (nth 1 x)) 2)
556 (math-vector-is-string
558 (and (natnump (nth 1 x))
559 (<= (nth 1 x) 255))))
562 (if (math-vectorp (nth 1 x))
563 (aref (math-vector-to-string
566 (or (and (memq (car-safe x) '(calcFunc-cvspace
569 (memq (length x) '(2 3))
572 (setq cc (math-compose-expr x prec))))
573 (setq a (if cc (math-comp-ascent cc) 0)
574 d (if cc (math-comp-descent cc) 0))
575 (if (eq b 'calcFunc-cbase)
576 (setq base (+ v a -1))
577 (if (eq b 'calcFunc-ctbase)
579 (if (eq b 'calcFunc-cbbase)
580 (setq base (+ v a d -1)))))
584 (setq c (delq nil c))
586 (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
587 (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
590 ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
591 (not (eq calc-language 'unform))
592 (memq (length a) '(3 4))
594 (integerp (nth 3 a))))
595 (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
596 (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
597 (math-compose-expr (nth 2 a) 0)))
598 ((and (eq (car a) 'calcFunc-cflat)
599 (not (eq calc-language 'unform))
600 (memq (length a) '(2 3))
602 (integerp (nth 2 a))))
603 (let ((calc-language (if (memq calc-language '(nil big))
604 'flat calc-language)))
605 (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
606 ((and (eq (car a) 'calcFunc-cspace)
607 (memq (length a) '(2 3))
610 (cons 'horiz (make-list (nth 1 a)
611 (if (and (math-vectorp (nth 2 a))
612 (math-vector-is-string (nth 2 a)))
613 (math-vector-to-string (nth 2 a) nil)
614 (math-compose-expr (nth 2 a) 0))))
615 (make-string (nth 1 a) ?\ )))
616 ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
617 (memq (length a) '(2 3))
621 (let* ((c (if (nth 2 a)
622 (if (and (math-vectorp (nth 2 a))
623 (math-vector-is-string (nth 2 a)))
624 (math-vector-to-string (nth 2 a) nil)
625 (math-compose-expr (nth 2 a) 0))
627 (ca (math-comp-ascent c))
628 (cd (math-comp-descent c)))
630 (cons (if (eq (car a) 'calcFunc-ctspace)
632 (if (eq (car a) 'calcFunc-cbspace)
633 (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
634 (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
635 (make-list (nth 1 a) c))))))
636 ((and (eq (car a) 'calcFunc-evalto)
637 (setq calc-any-evaltos t)
638 (memq calc-language '(tex eqn))
639 (= math-compose-level (if math-comp-tagged 2 1))
642 (if (eq calc-language 'tex) "\\evalto " "evalto ")
643 (math-compose-expr (nth 1 a) 0)
644 (if (eq calc-language 'tex) " \\to " " -> ")
645 (math-compose-expr (nth 2 a) 0)))
647 (let ((op (and (not (eq calc-language 'unform))
648 (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
649 (assoc "?" math-expr-opers)
650 (math-assq2 (car a) math-expr-opers)))))
652 (or (= (length a) 3) (eq (car a) 'calcFunc-if))
655 ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
656 (if (and (eq calc-language 'tex)
657 (not (math-tex-expr-is-flat a)))
658 (if (eq (car-safe a) '/)
659 (list 'horiz "{" (math-compose-expr a -1) "}")
660 (list 'horiz "\\left( "
661 (math-compose-expr a -1)
663 (if (eq calc-language 'eqn)
664 (if (or (eq (car-safe a) '/)
666 (list 'horiz "{" (math-compose-expr a -1) "}")
667 (if (math-tex-expr-is-flat a)
668 (list 'horiz "( " (math-compose-expr a -1) " )")
669 (list 'horiz "{left ( "
670 (math-compose-expr a -1)
672 (list 'horiz "(" (math-compose-expr a 0) ")"))))
673 ((and (eq calc-language 'tex)
674 (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
676 (list 'horiz "{" (math-compose-expr a -1) "}"))
677 ((eq (car a) 'calcFunc-if)
679 (math-compose-expr (nth 1 a) (nth 2 op))
681 (math-compose-expr (nth 2 a) 0)
683 (math-compose-expr (nth 3 a) (nth 3 op))))
685 (let* ((math-comp-tagged (and math-comp-tagged
688 (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
690 (setq math-compose-level
691 (1- math-compose-level))
694 (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
695 (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
696 (and (equal (car op) "^")
697 (eq (math-comp-first-char lhs) ?-)
698 (setq lhs (list 'horiz "(" lhs ")")))
699 (and (eq calc-language 'tex)
700 (or (equal (car op) "^") (equal (car op) "_"))
701 (not (and (stringp rhs) (= (length rhs) 1)))
702 (setq rhs (list 'horiz "{" rhs "}")))
703 (or (and (eq (car a) '*)
704 (or (null calc-language)
705 (assoc "2x" math-expr-opers))
706 (let* ((prevt (math-prod-last-term (nth 1 a)))
707 (nextt (math-prod-first-term (nth 2 a)))
708 (prevc (or (math-comp-last-char lhs)
709 (and (memq (car-safe prevt)
713 (eq calc-language 'big)
715 (nextc (or (math-comp-first-char rhs)
716 (and (memq (car-safe nextt)
721 (eq calc-language 'big)
724 (or (and (>= nextc ?a) (<= nextc ?z))
725 (and (>= nextc ?A) (<= nextc ?Z))
726 (and (>= nextc ?0) (<= nextc ?9))
727 (memq nextc '(?. ?_ ?#
732 (math-comp-first-string
734 (not (and (eq (car-safe prevt) 'var)
739 (list 'break math-compose-level)
745 (list 'break math-compose-level)
746 (if (or (equal (car op) "^")
748 (equal (car op) "**")
749 (and (equal (car op) "*")
750 (math-comp-last-char lhs)
751 (math-comp-first-char rhs))
752 (and (equal (car op) "/")
753 (math-num-integerp (nth 1 a))
754 (math-integerp (nth 2 a))))
756 (if (and (eq calc-language 'big)
757 (equal (car op) "=>"))
759 (concat " " (car op) " ")))
761 ((and op (= (length a) 2) (= (nth 3 op) -1))
763 ((or (> prec (or (nth 4 op) (nth 2 op)))
764 (and (not (eq (assoc (car op) math-expr-opers) op))
765 (> prec 0))) ; don't write x% + y
766 (if (and (eq calc-language 'tex)
767 (not (math-tex-expr-is-flat a)))
768 (list 'horiz "\\left( "
769 (math-compose-expr a -1)
771 (if (eq calc-language 'eqn)
772 (if (= (/ prec 100) 9)
773 (list 'horiz "{" (math-compose-expr a -1) "}")
774 (if (math-tex-expr-is-flat a)
775 (list 'horiz "{( " (math-compose-expr a -1) " )}")
776 (list 'horiz "{left ( "
777 (math-compose-expr a -1)
779 (list 'horiz "(" (math-compose-expr a 0) ")"))))
781 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
784 (if (or (> (length (car op)) 1)
785 (not (math-comp-is-flat lhs)))
786 (concat " " (car op))
788 ((and op (= (length a) 2) (= (nth 2 op) -1))
791 (let ((lr (and (eq calc-language 'tex)
792 (not (math-tex-expr-is-flat (nth 1 a))))))
795 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
796 (substring (car op) 1)
798 (if (or lr (> (length (car op)) 2)) " " "")
799 (math-compose-expr (nth 1 a) -1)
800 (if (or lr (> (length (car op)) 2)) " " "")
802 (car (nth 1 (memq op math-expr-opers))))))
803 ((> prec (or (nth 4 op) (nth 3 op)))
804 (if (and (eq calc-language 'tex)
805 (not (math-tex-expr-is-flat a)))
806 (list 'horiz "\\left( "
807 (math-compose-expr a -1)
809 (if (eq calc-language 'eqn)
810 (if (= (/ prec 100) 9)
811 (list 'horiz "{" (math-compose-expr a -1) "}")
812 (if (math-tex-expr-is-flat a)
813 (list 'horiz "{( " (math-compose-expr a -1) " )}")
814 (list 'horiz "{left ( "
815 (math-compose-expr a -1)
817 (list 'horiz "(" (math-compose-expr a 0) ")"))))
819 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
821 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
823 (substring (car op) 1)
825 (if (or (> (length ops) 1)
826 (not (math-comp-is-flat rhs)))
830 ((and (eq calc-language 'big)
831 (setq op (get (car a) 'math-compose-big))
832 (funcall op a prec)))
833 ((and (setq op (assq calc-language
834 '( ( nil . math-compose-normal )
835 ( flat . math-compose-normal )
836 ( big . math-compose-normal )
837 ( c . math-compose-c )
838 ( pascal . math-compose-pascal )
839 ( fortran . math-compose-fortran )
840 ( tex . math-compose-tex )
841 ( eqn . math-compose-eqn )
842 ( math . math-compose-math )
843 ( maple . math-compose-maple ))))
844 (setq op (get (car a) (cdr op)))
845 (funcall op a prec)))
847 (let* ((func (car a))
848 (func2 (assq func '(( mod . calcFunc-makemod )
849 ( sdev . calcFunc-sdev )
856 ( neg . calcFunc-neg )
857 ( | . calcFunc-vconcat ))))
860 (setq func (cdr func2)))
861 (if (setq func2 (rassq func math-expr-function-mapping))
862 (setq func (car func2)))
863 (setq func (math-remove-dashes
865 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
867 (math-match-substring (symbol-name func) 1)
868 (symbol-name func))))
869 (if (memq calc-language '(c fortran pascal maple))
870 (setq func (math-to-underscores func)))
871 (if (and (eq calc-language 'tex)
873 (not (= calc-language-option 0))
874 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func))
875 (if (< (prefix-numeric-value calc-language-option) 0)
876 (setq func (format "\\%s" func))
877 (setq func (format "\\hbox{%s}" func))))
878 (if (and (eq calc-language 'eqn)
879 (string-match "[^']'+\\'" func))
880 (let ((n (- (length func) (match-beginning 0) 1)))
881 (setq func (substring func 0 (- n)))
882 (while (>= (setq n (1- n)) 0)
883 (setq func (concat func " prime")))))
884 (cond ((and (eq calc-language 'tex)
886 (not (math-tex-expr-is-flat (nth 1 a)))))
887 (setq left "\\left( "
889 ((and (eq calc-language 'eqn)
891 (not (math-tex-expr-is-flat (nth 1 a)))))
892 (setq left "{left ( "
894 ((and (or (and (eq calc-language 'tex)
895 (eq (aref func 0) ?\\))
896 (and (eq calc-language 'eqn)
897 (memq (car a) math-eqn-special-funcs)))
898 (not (string-match "\\hbox{" func))
900 (or (Math-realp (nth 1 a))
901 (memq (car (nth 1 a)) '(var *))))
902 (setq left (if (eq calc-language 'eqn) "~{" "{")
904 ((eq calc-language 'eqn)
907 (t (setq left calc-function-open
908 right calc-function-close)))
909 (list 'horiz func left
910 (math-compose-vector (cdr a)
911 (if (eq calc-language 'eqn)
917 (defun math-prod-first-term (x)
918 (while (eq (car-safe x) '*)
922 (defun math-prod-last-term (x)
923 (while (eq (car-safe x) '*)
927 (defun math-compose-vector (a sep prec)
930 (cons (list 'set math-compose-level)
931 (let ((c (list (math-compose-expr (car a) prec))))
932 (while (setq a (cdr a))
933 (setq c (cons (if (eq (car-safe (car a))
935 (let ((math-compose-level
936 (1- math-compose-level)))
937 (math-compose-expr (car a) -123))
938 (math-compose-expr (car a) prec))
939 (cons (list 'break math-compose-level)
944 (defun math-vector-no-parens (a)
946 (not (eq (car-safe (nth 1 a)) '*))))
948 (defun math-compose-matrix (a col cols base)
951 (while (<= (setq col (1+ col)) cols)
952 (setq res (cons (cons math-comp-just
959 math-comp-vector-prec)
963 math-comp-comma-spc " ")))))
968 (defun math-compose-rows (a count first)
972 (math-compose-rows (cdr a) -1 nil)
973 (cons (concat (if (eq calc-language 'tex) " \\ldots" " ...")
975 (math-compose-rows (cdr a) -1 nil)))
977 (if first (concat math-comp-left-bracket " ") " ")
978 (math-compose-expr (car a) math-comp-vector-prec)
980 (math-compose-rows (cdr a) (1- count) nil)))
982 (if first (concat math-comp-left-bracket " ") " ")
983 (math-compose-expr (car a) math-comp-vector-prec)
984 (concat " " math-comp-right-bracket)))))
986 (defun math-compose-tex-matrix (a)
988 (cons (math-compose-vector (cdr (car a)) " & " 0)
990 (math-compose-tex-matrix (cdr a))))
991 (list (math-compose-vector (cdr (car a)) " & " 0))))
993 (defun math-compose-eqn-matrix (a)
996 (cond ((eq calc-matrix-just 'right) "rcol ")
997 ((eq calc-matrix-just 'center) "ccol ")
1000 (list 'break math-compose-level)
1004 (let ((math-compose-level (1+ math-compose-level)))
1005 (math-compose-vector (cdr (car a)) " above " 1000))
1008 (math-compose-eqn-matrix (cdr a)))))))
1011 (defun math-vector-is-string (a)
1012 (while (and (setq a (cdr a))
1013 (or (and (natnump (car a))
1015 (and (eq (car-safe (car a)) 'cplx)
1016 (natnump (nth 1 (car a)))
1017 (eq (nth 2 (car a)) 0)
1018 (<= (nth 1 (car a)) 255)))))
1021 (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
1032 (defun math-vector-to-string (a &optional quoted)
1033 (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
1035 (if (string-match "[\000-\037\177\\\"]" a)
1037 (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
1038 (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
1039 (fmt (if quoted "\\^%c" "^%c"))
1041 (while (setq p (string-match pat a p))
1042 (if (setq new (assq (aref a p) codes))
1043 (setq a (concat (substring a 0 p)
1045 (substring a (1+ p)))
1046 p (+ p (length (cdr new))))
1047 (setq a (concat (substring a 0 p)
1048 (format fmt (+ (aref a p) 64))
1049 (substring a (1+ p)))
1052 (concat "\"" a "\"")
1056 (defun math-to-underscores (x)
1057 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
1058 (math-to-underscores
1059 (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
1062 (defun math-tex-expr-is-flat (a)
1063 (or (Math-integerp a)
1064 (memq (car a) '(float var))
1065 (and (memq (car a) '(+ - * neg))
1067 (while (and (setq a (cdr a))
1068 (math-tex-expr-is-flat (car a))))
1070 (and (memq (car a) '(^ calcFunc-subscr))
1071 (math-tex-expr-is-flat (nth 1 a)))))
1073 (put 'calcFunc-log 'math-compose-big 'math-compose-log)
1074 (defun math-compose-log (a prec)
1075 (and (= (length a) 3)
1078 (let ((calc-language 'flat))
1079 (math-compose-expr (nth 2 a) 1000)))
1081 (math-compose-expr (nth 1 a) 1000)
1084 (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
1085 (defun math-compose-log10 (a prec)
1086 (and (= (length a) 2)
1088 (list 'subscr "log" "10")
1090 (math-compose-expr (nth 1 a) 1000)
1093 (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
1094 (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
1095 (defun math-compose-deriv (a prec)
1096 (when (= (length a) 3)
1097 (math-compose-expr (list '/
1098 (list 'calcFunc-choriz
1100 '(calcFunc-string (vec ?d))
1102 (list 'calcFunc-choriz
1104 '(calcFunc-string (vec ?d))
1108 (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
1109 (defun math-compose-sqrt (a prec)
1110 (when (= (length a) 2)
1111 (let* ((c (math-compose-expr (nth 1 a) 0))
1112 (a (math-comp-ascent c))
1113 (d (math-comp-descent c))
1115 (w (math-comp-width c)))
1118 (concat (if (= h 1) " " " ")
1119 (make-string (+ w 2) ?\_))
1123 (append (list 'vleft (1- a))
1124 (make-list (1- h) " |")
1129 (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
1130 (defun math-compose-choose (a prec)
1131 (let ((a1 (math-compose-expr (nth 1 a) 0))
1132 (a2 (math-compose-expr (nth 2 a) 0)))
1136 (math-comp-height a1)
1140 (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
1141 (defun math-compose-integ (a prec)
1142 (and (memq (length a) '(3 5))
1143 (eq (car-safe (nth 2 a)) 'var)
1144 (let* ((parens (and (>= prec 196) (/= prec 1000)))
1145 (var (math-compose-expr (nth 2 a) 0))
1146 (over (and (eq (car-safe (nth 2 a)) 'var)
1147 (or (and (eq (car-safe (nth 1 a)) '/)
1148 (math-numberp (nth 1 (nth 1 a))))
1149 (and (eq (car-safe (nth 1 a)) '^)
1150 (math-looks-negp (nth 2 (nth 1 a)))))))
1151 (expr (math-compose-expr (if over
1153 (math-build-var-name
1156 (nth 1 (nth 2 a)))))
1158 (calc-language 'flat)
1159 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1160 (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
1163 (append (list 'vcent (if high 3 2))
1164 (and high (list (list 'horiz " " high)))
1170 (and low (list (list 'horiz low " "))))
1174 (list 'horiz " d" var))
1175 (if parens ")" "")))))
1177 (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
1178 (defun math-compose-sum (a prec)
1179 (and (memq (length a) '(3 5 6))
1180 (let* ((expr (math-compose-expr (nth 1 a) 185))
1181 (calc-language 'flat)
1182 (var (math-compose-expr (nth 2 a) 0))
1183 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1184 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1186 (if (memq prec '(180 201)) "(" "")
1187 (append (list 'vcent (if high 3 2))
1188 (and high (list high))
1195 (list (list 'horiz var " = " low))
1197 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1200 (if (memq prec '(180 201)) ")" "")))))
1202 (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
1203 (defun math-compose-prod (a prec)
1204 (and (memq (length a) '(3 5 6))
1205 (let* ((expr (math-compose-expr (nth 1 a) 198))
1206 (calc-language 'flat)
1207 (var (math-compose-expr (nth 2 a) 0))
1208 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1209 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1211 (if (memq prec '(196 201)) "(" "")
1212 (append (list 'vcent (if high 3 2))
1213 (and high (list high))
1219 (list (list 'horiz var " = " low))
1221 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1224 (if (memq prec '(196 201)) ")" "")))))
1226 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1227 ;; to math-stack-value-offset in calc.el, but are used by
1228 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1230 (defvar math-svo-wid)
1231 (defvar math-svo-off)
1233 (defun math-stack-value-offset-fancy ()
1234 (let ((cwid (+ (math-comp-width math-svo-c))))
1235 (cond ((eq calc-display-just 'right)
1236 (if calc-display-origin
1237 (setq math-svo-wid (max calc-display-origin 5))
1238 (if (integerp calc-line-breaking)
1239 (setq math-svo-wid calc-line-breaking)))
1240 (setq math-svo-off (- math-svo-wid cwid
1241 (max (- (length calc-right-label)
1242 (if (and (integerp calc-line-breaking)
1243 calc-display-origin)
1244 (max (- calc-line-breaking
1245 calc-display-origin)
1250 (if calc-display-origin
1252 (setq math-svo-off (- calc-display-origin (/ cwid 2)))
1253 (if (integerp calc-line-breaking)
1254 (setq math-svo-off (min math-svo-off (- calc-line-breaking cwid
1255 (length calc-right-label)))))
1256 (if (>= math-svo-off 0)
1257 (setq math-svo-wid (max math-svo-wid (+ math-svo-off cwid)))))
1258 (if (integerp calc-line-breaking)
1259 (setq math-svo-wid calc-line-breaking))
1260 (setq math-svo-off (/ (- math-svo-wid cwid) 2)))))
1261 (and (integerp calc-line-breaking)
1262 (or (< math-svo-off 0)
1263 (and calc-display-origin
1264 (> calc-line-breaking calc-display-origin)))
1265 (setq math-svo-wid calc-line-breaking))))
1268 ;;; Convert a composition to string form, with embedded \n's if necessary.
1270 (defun math-composition-to-string (c &optional width)
1271 (or width (setq width (calc-window-width)))
1272 (if calc-display-raw
1273 (math-comp-to-string-raw c 0)
1274 (if (math-comp-is-flat c)
1275 (math-comp-to-string-flat c width)
1276 (math-vert-comp-to-string
1277 (math-comp-simplify c width)))))
1279 (defvar math-comp-buf-string (make-vector 10 ""))
1280 (defvar math-comp-buf-margin (make-vector 10 0))
1281 (defvar math-comp-buf-level (make-vector 10 0))
1282 (defun math-comp-is-flat (c) ; check if c's height is 1.
1283 (cond ((not (consp c)) t)
1284 ((memq (car c) '(set break)) t)
1285 ((eq (car c) 'horiz)
1286 (while (and (setq c (cdr c))
1287 (math-comp-is-flat (car c))))
1289 ((memq (car c) '(vleft vcent vright))
1290 (and (= (length c) 3)
1292 (math-comp-is-flat (nth 2 c))))
1294 (math-comp-is-flat (nth 2 c)))
1298 ;;; Convert a one-line composition to a string. Break into multiple
1299 ;;; lines if necessary, choosing break points according to the structure
1302 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1303 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1304 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1305 ;; which is called by math-comp-to-string-flat.
1306 ;; math-comp-highlight and math-comp-buf are also local to
1307 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1308 ;; by math-comp-add-string.
1309 (defvar math-comp-full-width)
1310 (defvar math-comp-highlight)
1311 (defvar math-comp-word)
1312 (defvar math-comp-level)
1313 (defvar math-comp-margin)
1314 (defvar math-comp-buf)
1315 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1316 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1317 ;; which are called by math-comp-to-string-flat.
1318 (defvar math-comp-pos)
1320 (defun math-comp-to-string-flat (c math-comp-full-width)
1321 (if math-comp-sel-hpos
1322 (let ((math-comp-pos 0))
1323 (math-comp-sel-flat-term c))
1324 (let ((math-comp-buf "")
1327 (math-comp-margin 0)
1328 (math-comp-highlight (and math-comp-selected calc-show-selections))
1329 (math-comp-level -1))
1330 (math-comp-to-string-flat-term '(set -1 0))
1331 (math-comp-to-string-flat-term c)
1332 (math-comp-to-string-flat-term '(break -1))
1333 (let ((str (aref math-comp-buf-string 0))
1335 (and (> (length str) 0) (= (aref str 0) ? )
1336 (> (length math-comp-buf) 0)
1337 (let ((k (length math-comp-buf)))
1338 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1339 (aset math-comp-buf k ? )
1340 (if (and (< (1+ k) (length math-comp-buf))
1341 (= (aref math-comp-buf (1+ k)) ? ))
1343 (aset math-comp-buf (1+ k) ?\n)
1345 (setq prefix "\n"))))
1346 (concat math-comp-buf prefix str)))))
1348 (defun math-comp-to-string-flat-term (c)
1349 (cond ((not (consp c))
1350 (if math-comp-highlight
1351 (setq c (math-comp-highlight-string c)))
1352 (setq math-comp-word (if (= (length math-comp-word) 0) c
1353 (concat math-comp-word c))
1354 math-comp-pos (+ math-comp-pos (length c))))
1356 ((eq (car c) 'horiz)
1357 (while (setq c (cdr c))
1358 (math-comp-to-string-flat-term (car c))))
1363 (setq math-comp-level (1+ math-comp-level))
1364 (if (>= math-comp-level (length math-comp-buf-string))
1365 (setq math-comp-buf-string (vconcat math-comp-buf-string
1366 math-comp-buf-string)
1367 math-comp-buf-margin (vconcat math-comp-buf-margin
1368 math-comp-buf-margin)
1369 math-comp-buf-level (vconcat math-comp-buf-level
1370 math-comp-buf-level)))
1371 (aset math-comp-buf-string math-comp-level "")
1372 (aset math-comp-buf-margin math-comp-level (+ math-comp-pos
1374 (aset math-comp-buf-level math-comp-level (nth 1 c)))))
1376 ((eq (car c) 'break)
1377 (if (not calc-line-breaking)
1378 (setq math-comp-buf (concat math-comp-buf math-comp-word)
1381 (if (and (> math-comp-pos math-comp-full-width)
1384 (setq str (aref math-comp-buf-string i))
1385 (and (= (length str) 0) (< i math-comp-level)))
1387 (or (> (length str) 0) (> (length math-comp-buf) 0))))
1388 (let ((prefix "") mrg wid)
1389 (setq mrg (aref math-comp-buf-margin i))
1390 (if (> mrg 12) ; indenting too far, go back to far left
1391 (let ((j i) (new (if calc-line-numbering 5 1)))
1392 '(while (<= j math-comp-level)
1393 (aset math-comp-buf-margin j
1394 (+ (aref math-comp-buf-margin j) (- new mrg)))
1397 (setq wid (+ (length str) math-comp-margin))
1398 (and (> (length str) 0) (= (aref str 0) ? )
1399 (> (length math-comp-buf) 0)
1400 (let ((k (length math-comp-buf)))
1401 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1402 (aset math-comp-buf k ? )
1403 (if (and (< (1+ k) (length math-comp-buf))
1404 (= (aref math-comp-buf (1+ k)) ? ))
1406 (aset math-comp-buf (1+ k) ?\n)
1408 (setq prefix "\n"))))
1409 (setq math-comp-buf (concat math-comp-buf prefix str "\n"
1410 (make-string mrg ? ))
1411 math-comp-pos (+ math-comp-pos (- mrg wid))
1412 math-comp-margin mrg)
1413 (aset math-comp-buf-string i "")
1414 (while (<= (setq i (1+ i)) math-comp-level)
1415 (if (> (aref math-comp-buf-margin i) wid)
1416 (aset math-comp-buf-margin i
1417 (+ (aref math-comp-buf-margin i)
1419 (if (and (= (nth 1 c) (aref math-comp-buf-level math-comp-level))
1420 (< math-comp-pos (+ (aref math-comp-buf-margin math-comp-level) 2)))
1421 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1422 (let ((str (aref math-comp-buf-string math-comp-level)))
1423 (setq str (if (= (length str) 0)
1425 (concat str math-comp-word))
1427 (while (< (nth 1 c) (aref math-comp-buf-level math-comp-level))
1428 (setq math-comp-level (1- math-comp-level))
1429 (or (= (length (aref math-comp-buf-string math-comp-level)) 0)
1430 (setq str (concat (aref math-comp-buf-string math-comp-level)
1432 (aset math-comp-buf-string math-comp-level str)))))
1435 (cond ((eq (nth 1 c) math-comp-selected)
1436 (let ((math-comp-highlight (not calc-show-selections)))
1437 (math-comp-to-string-flat-term (nth 2 c))))
1439 (let ((math-comp-highlight nil))
1440 (math-comp-to-string-flat-term (nth 2 c))))
1441 (t (math-comp-to-string-flat-term (nth 2 c)))))
1443 (t (math-comp-to-string-flat-term (nth 2 c)))))
1445 (defun math-comp-highlight-string (s)
1446 (setq s (copy-sequence s))
1447 (let ((i (length s)))
1448 (while (>= (setq i (1- i)) 0)
1449 (or (memq (aref s i) '(32 ?\n))
1450 (aset s i (if calc-show-selections ?\. ?\#)))))
1454 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1455 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1456 ;; math-comp-add-string-sel, which are called (indirectly) by
1457 ;; calc-find-selected-part.
1458 (defvar math-comp-sel-tag)
1460 (defun math-comp-sel-flat-term (c)
1461 (cond ((not (consp c))
1462 (setq math-comp-pos (+ math-comp-pos (length c))))
1463 ((memq (car c) '(set break)))
1464 ((eq (car c) 'horiz)
1465 (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
1466 (math-comp-sel-flat-term (car c))))
1468 (if (<= math-comp-pos math-comp-sel-cpos)
1470 (math-comp-sel-flat-term (nth 2 c))
1471 (if (> math-comp-pos math-comp-sel-cpos)
1472 (setq math-comp-sel-tag c
1473 math-comp-sel-cpos 1000000)))
1474 (math-comp-sel-flat-term (nth 2 c))))
1475 (t (math-comp-sel-flat-term (nth 2 c)))))
1478 ;;; Simplify a composition to a canonical form consisting of
1479 ;;; (vleft n "string" "string" "string" ...)
1480 ;;; where 0 <= n < number-of-strings.
1482 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1483 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1484 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1485 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1486 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1487 ;; math-comp-simplify.
1488 (defvar math-comp-base)
1489 (defvar math-comp-hgt)
1490 (defvar math-comp-tag)
1491 (defvar math-comp-hpos)
1492 (defvar math-comp-vpos)
1494 (defun math-comp-simplify (c full-width)
1495 (let ((math-comp-buf (list ""))
1500 (math-comp-highlight (and math-comp-selected calc-show-selections))
1501 (math-comp-tag nil))
1502 (math-comp-simplify-term c)
1503 (cons 'vleft (cons math-comp-base math-comp-buf))))
1505 (defun math-comp-add-string (s h v)
1506 (and (> (length s) 0)
1507 (let ((vv (+ v math-comp-base)))
1508 (if math-comp-sel-hpos
1509 (math-comp-add-string-sel h vv (length s) 1)
1511 (setq math-comp-buf (nconc (make-list (- vv) "") math-comp-buf)
1512 math-comp-base (- v)
1513 math-comp-hgt (- math-comp-hgt vv)
1515 (if (>= vv math-comp-hgt)
1516 (setq math-comp-buf (nconc math-comp-buf
1517 (make-list (1+ (- vv math-comp-hgt)) ""))
1518 math-comp-hgt (1+ vv))))
1519 (let ((str (nthcdr vv math-comp-buf)))
1520 (setcar str (concat (car str)
1521 (make-string (- h (length (car str))) 32)
1522 (if math-comp-highlight
1523 (math-comp-highlight-string s)
1526 (defun math-comp-add-string-sel (x y w h)
1527 (if (and (<= y math-comp-sel-vpos)
1528 (> (+ y h) math-comp-sel-vpos)
1529 (<= x math-comp-sel-hpos)
1530 (> (+ x w) math-comp-sel-hpos))
1531 (setq math-comp-sel-tag math-comp-tag
1532 math-comp-sel-vpos 10000)))
1534 (defun math-comp-simplify-term (c)
1536 (math-comp-add-string c math-comp-hpos math-comp-vpos)
1537 (setq math-comp-hpos (+ math-comp-hpos (length c))))
1538 ((memq (car c) '(set break))
1540 ((eq (car c) 'horiz)
1541 (while (setq c (cdr c))
1542 (math-comp-simplify-term (car c))))
1543 ((memq (car c) '(vleft vcent vright))
1544 (let* ((math-comp-vpos (+ (- math-comp-vpos (nth 1 c))
1545 (1- (math-comp-ascent (nth 2 c)))))
1546 (widths (mapcar 'math-comp-width (cdr (cdr c))))
1547 (maxwid (apply 'max widths))
1548 (bias (cond ((eq (car c) 'vleft) 0)
1549 ((eq (car c) 'vcent) 1)
1552 (while (setq c (cdr c))
1553 (if (eq (car-safe (car c)) 'rule)
1554 (math-comp-add-string (make-string maxwid (nth 1 (car c)))
1555 math-comp-hpos math-comp-vpos)
1556 (let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid
1559 (math-comp-simplify-term (car c))))
1561 (setq math-comp-vpos (+ math-comp-vpos
1562 (+ (math-comp-descent (car c))
1563 (math-comp-ascent (nth 1 c))))
1564 widths (cdr widths))))
1565 (setq math-comp-hpos (+ math-comp-hpos maxwid))))
1566 ((eq (car c) 'supscr)
1567 (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
1568 (desc (math-comp-descent (nth 2 c)))
1571 (math-comp-simplify-term (nth 1 c))))
1572 (math-comp-vpos (- math-comp-vpos (+ asc desc))))
1573 (math-comp-simplify-term (nth 2 c))
1574 (if math-comp-sel-hpos
1575 (math-comp-add-string-sel oldh
1578 (math-comp-ascent (nth 2 c)))
1579 (- math-comp-hpos oldh)
1580 (math-comp-height c)))))
1581 ((eq (car c) 'subscr)
1582 (let* ((asc (math-comp-ascent (nth 2 c)))
1583 (desc (math-comp-descent (nth 1 c)))
1584 (oldv math-comp-vpos)
1587 (math-comp-simplify-term (nth 1 c))))
1588 (math-comp-vpos (+ math-comp-vpos (+ asc desc))))
1589 (math-comp-simplify-term (nth 2 c))
1590 (if math-comp-sel-hpos
1591 (math-comp-add-string-sel oldh oldv
1592 (- math-comp-hpos oldh)
1593 (math-comp-height c)))))
1595 (cond ((eq (nth 1 c) math-comp-selected)
1596 (let ((math-comp-highlight (not calc-show-selections)))
1597 (math-comp-simplify-term (nth 2 c))))
1599 (let ((math-comp-highlight nil))
1600 (math-comp-simplify-term (nth 2 c))))
1601 (t (let ((math-comp-tag c))
1602 (math-comp-simplify-term (nth 2 c))))))))
1605 ;;; Measuring a composition.
1607 (defun math-comp-first-char (c)
1609 (and (> (length c) 0)
1611 ((memq (car c) '(horiz subscr supscr))
1612 (while (and (setq c (cdr c))
1613 (math-comp-is-null (car c))))
1614 (and c (math-comp-first-char (car c))))
1616 (math-comp-first-char (nth 2 c)))))
1618 (defun math-comp-first-string (c)
1620 (and (> (length c) 0)
1622 ((eq (car c) 'horiz)
1623 (while (and (setq c (cdr c))
1624 (math-comp-is-null (car c))))
1625 (and c (math-comp-first-string (car c))))
1627 (math-comp-first-string (nth 2 c)))))
1629 (defun math-comp-last-char (c)
1631 (and (> (length c) 0)
1632 (elt c (1- (length c)))))
1633 ((eq (car c) 'horiz)
1634 (let ((c (reverse (cdr c))))
1635 (while (and c (math-comp-is-null (car c)))
1637 (and c (math-comp-last-char (car c)))))
1639 (math-comp-last-char (nth 2 c)))))
1641 (defun math-comp-is-null (c)
1642 (cond ((stringp c) (= (length c) 0))
1643 ((memq (car c) '(horiz subscr supscr))
1644 (while (and (setq c (cdr c))
1645 (math-comp-is-null (car c))))
1648 (math-comp-is-null (nth 2 c)))
1649 ((memq (car c) '(set break)) t)))
1651 (defun math-comp-width (c)
1652 (cond ((not (consp c)) (length c))
1653 ((memq (car c) '(horiz subscr supscr))
1655 (while (setq c (cdr c))
1656 (setq accum (+ accum (math-comp-width (car c)))))
1658 ((memq (car c) '(vcent vleft vright))
1661 (while (setq c (cdr c))
1662 (setq accum (max accum (math-comp-width (car c)))))
1665 (math-comp-width (nth 2 c)))
1668 (defun math-comp-height (c)
1671 (+ (math-comp-ascent c) (math-comp-descent c))))
1673 (defun math-comp-ascent (c)
1674 (cond ((not (consp c)) 1)
1675 ((eq (car c) 'horiz)
1677 (while (setq c (cdr c))
1678 (setq accum (max accum (math-comp-ascent (car c)))))
1680 ((memq (car c) '(vcent vleft vright))
1681 (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
1682 ((eq (car c) 'supscr)
1683 (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
1684 ((eq (car c) 'subscr)
1685 (math-comp-ascent (nth 1 c)))
1687 (math-comp-ascent (nth 2 c)))
1690 (defun math-comp-descent (c)
1691 (cond ((not (consp c)) 0)
1692 ((eq (car c) 'horiz)
1694 (while (setq c (cdr c))
1695 (setq accum (max accum (math-comp-descent (car c)))))
1697 ((memq (car c) '(vcent vleft vright))
1698 (let ((accum (- (nth 1 c))))
1700 (while (setq c (cdr c))
1701 (setq accum (+ accum (math-comp-height (car c)))))
1702 (max (1- accum) 0)))
1703 ((eq (car c) 'supscr)
1704 (math-comp-descent (nth 1 c)))
1705 ((eq (car c) 'subscr)
1706 (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
1708 (math-comp-descent (nth 2 c)))
1711 (defun calcFunc-cwidth (a &optional prec)
1712 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1713 (math-comp-width (math-compose-expr a (or prec 0))))
1715 (defun calcFunc-cheight (a &optional prec)
1716 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1717 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1718 (memq (length a) '(2 3))
1721 (math-comp-height (math-compose-expr a (or prec 0)))))
1723 (defun calcFunc-cascent (a &optional prec)
1724 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1725 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1726 (memq (length a) '(2 3))
1729 (math-comp-ascent (math-compose-expr a (or prec 0)))))
1731 (defun calcFunc-cdescent (a &optional prec)
1732 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1733 (math-comp-descent (math-compose-expr a (or prec 0))))
1736 ;;; Convert a simplified composition into string form.
1738 (defun math-vert-comp-to-string (c)
1741 (math-vert-comp-to-string-step (cdr (cdr c)))))
1743 (defun math-vert-comp-to-string-step (c)
1745 (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
1749 ;;; Convert a composition to a string in "raw" form (for debugging).
1751 (defun math-comp-to-string-raw (c indent)
1752 (cond ((or (not (consp c)) (eq (car c) 'set))
1753 (prin1-to-string c))
1755 (concat "(" (symbol-name (car c)) ")"))
1757 (let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
1759 (symbol-name (car c))
1761 (math-comp-to-string-raw (nth 1 c) next-indent)
1762 (math-comp-to-string-raw-step (cdr (cdr c))
1766 (defun math-comp-to-string-raw-step (cl indent)
1769 (make-string indent 32)
1770 (math-comp-to-string-raw (car cl) indent)
1771 (math-comp-to-string-raw-step (cdr cl) indent))
1774 ;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1775 ;;; calccomp.el ends here