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