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