1 ;;; calccomp.el --- composition functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This file is autoloaded from calc-ext.el.
33 ;;; A "composition" has one of the following forms:
35 ;;; "string" A literal string
37 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
39 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
40 ;;; (break LEVEL) A potential line-break point
42 ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
43 ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
44 ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
45 ;;; N specifies baseline of the stack, 0=top line.
47 ;;; (supscr C1 C2) Composition C1 with superscript C2
48 ;;; (subscr C1 C2) Composition C1 with subscript C2
49 ;;; (rule X) Horizontal line of X, full width of enclosing comp
51 ;;; (tag X C) Composition C corresponds to sub-expression X
53 ;; math-comp-just and math-comp-comma-spc are local to
54 ;; math-compose-expr, but are used by math-compose-matrix, which is
55 ;; called by math-compose-expr
56 (defvar math-comp-just)
57 (defvar math-comp-comma-spc)
59 ;; math-comp-vector-prec is local to math-compose-expr, but is used by
60 ;; math-compose-matrix and math-compose-rows, which are called by
62 (defvar math-comp-vector-prec)
64 ;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
65 ;; local to math-compose-expr, but are used by math-compose-rows, which is
66 ;; called by math-compose-expr.
67 (defvar math-comp-left-bracket)
68 (defvar math-comp-right-bracket)
69 (defvar math-comp-comma)
71 (defun math-compose-var (a)
73 (if (and math-compose-hash-args
74 (let ((p calc-arg-values))
76 (while (and p (not (equal (car p) a)))
77 (setq p (and (eq math-compose-hash-args t) (cdr p))
80 (if (eq math-compose-hash-args 1)
83 (setq sn (symbol-name (nth 1 a)))
84 (if (memq calc-language calc-lang-allow-percentsigns)
85 (setq sn (math-to-percentsigns sn)))
86 (if (memq calc-language calc-lang-allow-underscores)
87 (setq sn (math-to-underscores sn)))
90 (defun math-compose-expr (a prec)
91 (let ((math-compose-level (1+ math-compose-level))
92 (math-expr-opers (math-expr-ops))
95 ((or (and (eq a math-comp-selected) a)
97 (not (eq math-comp-tagged a))))
98 (let ((math-comp-selected nil))
99 (and math-comp-tagged (setq math-comp-tagged a))
100 (list 'tag a (math-compose-expr a prec))))
101 ((and (not (consp a)) (not (integerp a)))
102 (concat "'" (prin1-to-string a)))
103 ((setq spfn (assq (car-safe a)
104 (get calc-language 'math-special-function-table)))
105 (setq spfn (cdr spfn))
107 (funcall (car spfn) a spfn)
110 (if (or (eq (car-safe a) 'frac)
111 (and (nth 1 calc-frac-format) (Math-integerp a)))
114 (not (memq calc-language
115 '(flat big unform))))
116 (let ((aa (math-adjust-fraction a))
117 (calc-frac-format nil))
118 (math-compose-expr (list '/
119 (if (memq calc-language
120 calc-lang-slash-idiv)
121 (math-float (nth 1 aa))
124 (if (and (eq calc-language 'big)
125 (= (length (car calc-frac-format)) 1))
126 (let* ((aa (math-adjust-fraction a))
127 (calc-frac-format nil)
128 (math-radix-explicit-format nil)
130 (if (math-negp (nth 1 aa))
134 (math-abs (nth 1 aa)))
136 (math-format-number (nth 2 aa))))))
137 (if (= calc-number-radix 10)
141 (int-to-string calc-number-radix)))))
142 (math-format-number a)))
143 (if (not (eq calc-language 'big))
144 (math-format-number a prec)
145 (if (memq (car-safe a) '(cplx polar))
146 (if (math-zerop (nth 2 a))
147 (math-compose-expr (nth 1 a) prec)
149 (math-compose-expr (nth 1 a) 0)
150 (if (eq (car a) 'cplx) ", " "; ")
151 (math-compose-expr (nth 2 a) 0) ")"))
152 (if (or (= calc-number-radix 10)
154 (and calc-group-digits
155 (not (assoc calc-group-char '((",") (" "))))))
156 (math-format-number a prec)
157 (let ((s (math-format-number a prec))
159 (while (string-match (if (> calc-number-radix 14)
160 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
161 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
163 (setq c (nconc c (list (substring s 0 (match-beginning 0))
165 (math-match-substring s 2)
166 (math-match-substring s 1))))
167 s (substring s (match-end 0))))
169 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
171 (substring s 0 (match-beginning 0)) " "
173 (math-match-substring s 1)
174 (math-match-substring s 2))
175 (math-match-substring s 3))))
176 (if c (cons 'horiz (nconc c (list s))) s)))))))
177 ((and (get (car a) 'math-compose-forms)
178 (not (eq calc-language 'unform))
179 (let ((comps (get (car a) 'math-compose-forms))
181 (or (and (setq temp (assq calc-language comps))
182 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
183 (setq temp (apply (cdr temp2) (cdr a)))
184 (math-compose-expr temp prec))
185 (and (setq temp2 (assq nil (cdr temp)))
186 (funcall (cdr temp2) a))))
187 (and (setq temp (assq nil comps))
188 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
189 (setq temp (apply (cdr temp2) (cdr a)))
190 (math-compose-expr temp prec))
191 (and (setq temp2 (assq nil (cdr temp)))
192 (funcall (cdr temp2) a))))))))
194 (let* ((math-comp-left-bracket (if calc-vector-brackets
195 (substring calc-vector-brackets 0 1) ""))
196 (math-comp-right-bracket (if calc-vector-brackets
197 (substring calc-vector-brackets 1 2) ""))
198 (inner-brackets (memq 'R calc-matrix-brackets))
199 (outer-brackets (memq 'O calc-matrix-brackets))
200 (row-commas (memq 'C calc-matrix-brackets))
201 (math-comp-comma-spc (or calc-vector-commas " "))
202 (math-comp-comma (or calc-vector-commas ""))
203 (math-comp-vector-prec (if (or (and calc-vector-commas
204 (math-vector-no-parens a))
205 (memq 'P calc-matrix-brackets)) 0 1000))
206 (math-comp-just (cond ((eq calc-matrix-just 'right) 'vright)
207 ((eq calc-matrix-just 'center) 'vcent)
209 (break calc-break-vectors))
210 (if (and (memq calc-language '(nil big))
211 (not calc-break-vectors)
212 (math-matrixp a) (not (math-matrixp (nth 1 a)))
213 (or calc-full-vectors
214 (and (< (length a) 7) (< (length (nth 1 a)) 7))
215 (progn (setq break t) nil)))
217 (setq math-comp-vector-prec (if (or (and calc-vector-commas
218 (math-vector-no-parens
220 (memq 'P calc-matrix-brackets))
224 (concat math-comp-left-bracket math-comp-left-bracket " ")
225 (math-compose-vector (cdr (nth 1 a)) (concat math-comp-comma " ")
226 math-comp-vector-prec)
227 (concat " " math-comp-right-bracket math-comp-right-bracket))
228 (let* ((rows (1- (length a)))
229 (cols (1- (length (nth 1 a))))
230 (base (/ (1- rows) 2))
231 (calc-language 'flat))
233 (list (append '(vleft)
235 (list (concat (and outer-brackets
236 (concat math-comp-left-bracket
239 (concat math-comp-left-bracket
242 (concat (and outer-brackets
246 math-comp-left-bracket
248 (math-compose-matrix (cdr a) 1 cols base)
249 (list (append '(vleft)
254 math-comp-right-bracket
257 (if (and outer-brackets
263 math-comp-right-bracket))
267 math-comp-right-bracket)))))))))
268 (if (and calc-display-strings
270 (math-vector-is-string a))
271 (math-vector-to-string a t)
272 (if (and break (cdr a)
273 (not (eq calc-language 'flat)))
274 (let* ((full (or calc-full-vectors (< (length a) 7)))
275 (rows (if full (1- (length a)) 5))
276 (base (/ (1- rows) 2))
277 (calc-break-vectors nil))
279 (cons 'vleft (cons base
282 (if full rows 3) t)))))
283 (if (or calc-full-vectors (< (length a) 7))
285 (setq spfn (get calc-language 'math-matrix-formatter))
289 math-comp-left-bracket
290 (math-compose-vector (cdr a)
291 (concat math-comp-comma " ")
292 math-comp-vector-prec)
293 math-comp-right-bracket))
295 math-comp-left-bracket
296 (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
297 (concat math-comp-comma " ")
298 math-comp-vector-prec)
300 (if (setq spfn (get calc-language 'math-dots))
304 (list 'break math-compose-level)
305 (math-compose-expr (nth (1- (length a)) a)
306 (if (equal math-comp-comma "") 1000 0))
307 math-comp-right-bracket)))))))
308 ((eq (car a) 'incomplete)
310 (cond ((eq (nth 1 a) 'vec)
312 (math-compose-vector (cdr (cdr a)) ", " 0)
314 ((eq (nth 1 a) 'cplx)
316 (math-compose-vector (cdr (cdr a)) ", " 0)
318 ((eq (nth 1 a) 'polar)
320 (math-compose-vector (cdr (cdr a)) "; " 0)
322 ((eq (nth 1 a) 'intv)
324 (if (memq (nth 2 a) '(0 1)) "(" "[")
325 (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
328 (cond ((eq (nth 1 a) 'vec) "[ ...")
329 ((eq (nth 1 a) 'intv)
330 (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
333 (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
335 (symbol-name (car v))
336 (if (setq spfn (get calc-language 'math-var-formatter))
337 (funcall spfn a prec)
338 (math-compose-var a)))))
341 (if (memq (nth 1 a) '(0 1)) "(" "[")
342 (math-compose-expr (nth 2 a) 0)
344 (math-compose-expr (nth 3 a) 0)
345 (if (memq (nth 1 a) '(0 2)) ")" "]")))
347 (if (eq (car calc-date-format) 'X)
349 (concat "<" (math-format-date a) ">")))
350 ((and (eq (car a) 'calcFunc-subscr)
351 (setq spfn (get calc-language 'math-compose-subscr)))
353 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
354 (eq calc-language 'big))
355 (let* ((a1 (math-compose-expr (nth 1 a) 1000))
356 (calc-language 'flat)
357 (a2 (math-compose-expr (nth 2 a) 0)))
358 (if (or (eq (car-safe a1) 'subscr)
359 (and (eq (car-safe a1) 'tag)
360 (eq (car-safe (nth 2 a1)) 'subscr)
361 (setq a1 (nth 2 a1))))
368 (list 'subscr a1 a2))))
369 ((and (eq (car a) '^)
370 (eq calc-language 'big))
372 (if (or (math-looks-negp (nth 1 a))
373 (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
374 (and (eq (car-safe (nth 1 a)) 'cplx)
375 (math-negp (nth 1 (nth 1 a)))
376 (eq (nth 2 (nth 1 a)) 0)))
377 (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
378 (math-compose-expr (nth 1 a) 201))
379 (let ((calc-language 'flat)
380 (calc-number-radix 10))
381 (math-compose-expr (nth 2 a) 0))))
382 ((and (eq (car a) '/)
383 (eq calc-language 'big))
384 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
386 (math-compose-expr (nth 1 a) 0)))
387 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
389 (math-compose-expr (nth 2 a) 0))))
391 (math-comp-height a1)
393 ((and (eq (car a) 'calcFunc-lambda)
395 (memq calc-language '(nil flat big)))
398 (math-compose-hash-args (if (= (length a) 3) 1 t)))
399 (while (and (cdr p) (equal (car p) (car ap)))
400 (setq p (cdr p) ap (cdr ap)))
403 (list (math-compose-vector
404 (nreverse (cdr (reverse (cdr a)))) ", " 0)
407 (list (math-compose-expr (nth (1- (length a)) a) 0)
409 ((and (eq (car a) 'calcFunc-string)
411 (math-vectorp (nth 1 a))
412 (math-vector-is-string (nth 1 a)))
413 (if (eq calc-language 'unform)
414 (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
415 (math-vector-to-string (nth 1 a) nil)))
416 ((and (eq (car a) 'calcFunc-bstring)
418 (math-vectorp (nth 1 a))
419 (math-vector-is-string (nth 1 a)))
420 (if (eq calc-language 'unform)
421 (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
423 (s (math-vector-to-string (nth 1 a) nil))
425 (while (string-match "[^ ] +[^ ]" s)
426 (setq p (1- (match-end 0))
427 c (cons (list 'break math-compose-level)
428 (cons (substring s 0 p)
431 (setq c (nreverse (cons s c)))
433 (setq c (cons (list 'set math-compose-level 2) c)))
435 ((and (eq (car a) 'calcFunc-cprec)
436 (not (eq calc-language 'unform))
438 (integerp (nth 2 a)))
439 (let ((c (math-compose-expr (nth 1 a) -1)))
440 (if (> prec (nth 2 a))
441 (if (setq spfn (get calc-language 'math-big-parens))
442 (list 'horiz (car spfn) c (cdr spfn))
443 (list 'horiz "(" c ")"))
445 ((and (eq (car a) 'calcFunc-choriz)
446 (not (eq calc-language 'unform))
447 (memq (length a) '(2 3 4))
448 (math-vectorp (nth 1 a))
449 (if (integerp (nth 2 a))
451 (and (math-vectorp (nth 3 a))
452 (math-vector-is-string (nth 3 a))))
454 (and (math-vectorp (nth 2 a))
455 (math-vector-is-string (nth 2 a))))))
456 (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
457 (sep (nth (if cprec 3 2) a))
460 (math-compose-vector (cdr (nth 1 a))
461 (math-vector-to-string sep nil)
463 (cons 'horiz (mapcar (function
465 (if (eq (car-safe x) 'calcFunc-bstring)
468 x (or bprec cprec prec))
470 (math-compose-expr x (or cprec prec)))))
472 ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
473 (not (eq calc-language 'unform))
474 (memq (length a) '(2 3))
475 (math-vectorp (nth 1 a))
477 (integerp (nth 2 a))))
480 (prec (or (nth 2 a) prec))
483 (let ((b nil) (cc nil) a d)
484 (if (and (memq (car-safe x) '(calcFunc-cbase
487 (memq (length x) '(1 2)))
490 (if (and (eq (car-safe x) 'calcFunc-crule)
491 (memq (length x) '(1 2))
493 (and (math-vectorp (nth 1 x))
494 (= (length (nth 1 x)) 2)
495 (math-vector-is-string
497 (and (natnump (nth 1 x))
498 (<= (nth 1 x) 255))))
501 (if (math-vectorp (nth 1 x))
502 (aref (math-vector-to-string
505 (or (and (memq (car-safe x) '(calcFunc-cvspace
508 (memq (length x) '(2 3))
511 (setq cc (math-compose-expr x prec))))
512 (setq a (if cc (math-comp-ascent cc) 0)
513 d (if cc (math-comp-descent cc) 0))
514 (if (eq b 'calcFunc-cbase)
515 (setq base (+ v a -1))
516 (if (eq b 'calcFunc-ctbase)
518 (if (eq b 'calcFunc-cbbase)
519 (setq base (+ v a d -1)))))
523 (setq c (delq nil c))
525 (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
526 (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
529 ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
530 (not (eq calc-language 'unform))
531 (memq (length a) '(3 4))
533 (integerp (nth 3 a))))
534 (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
535 (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
536 (math-compose-expr (nth 2 a) 0)))
537 ((and (eq (car a) 'calcFunc-cflat)
538 (not (eq calc-language 'unform))
539 (memq (length a) '(2 3))
541 (integerp (nth 2 a))))
542 (let ((calc-language (if (memq calc-language '(nil big))
543 'flat calc-language)))
544 (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
545 ((and (eq (car a) 'calcFunc-cspace)
546 (memq (length a) '(2 3))
549 (cons 'horiz (make-list (nth 1 a)
550 (if (and (math-vectorp (nth 2 a))
551 (math-vector-is-string (nth 2 a)))
552 (math-vector-to-string (nth 2 a) nil)
553 (math-compose-expr (nth 2 a) 0))))
554 (make-string (nth 1 a) ?\ )))
555 ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
556 (memq (length a) '(2 3))
560 (let* ((c (if (nth 2 a)
561 (if (and (math-vectorp (nth 2 a))
562 (math-vector-is-string (nth 2 a)))
563 (math-vector-to-string (nth 2 a) nil)
564 (math-compose-expr (nth 2 a) 0))
566 (ca (math-comp-ascent c))
567 (cd (math-comp-descent c)))
569 (cons (if (eq (car a) 'calcFunc-ctspace)
571 (if (eq (car a) 'calcFunc-cbspace)
572 (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
573 (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
574 (make-list (nth 1 a) c))))))
575 ((and (eq (car a) 'calcFunc-evalto)
576 (setq calc-any-evaltos t)
577 (setq spfn (get calc-language 'math-evalto))
578 (= math-compose-level (if math-comp-tagged 2 1))
582 (math-compose-expr (nth 1 a) 0)
584 (math-compose-expr (nth 2 a) 0)))
586 (let ((op (and (not (eq calc-language 'unform))
587 (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
588 (assoc "?" math-expr-opers)
589 (math-assq2 (car a) math-expr-opers)))))
591 (or (= (length a) 3) (eq (car a) 'calcFunc-if))
594 ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
595 (if (and (memq calc-language '(tex latex))
596 (not (math-tex-expr-is-flat a)))
597 (if (eq (car-safe a) '/)
598 (list 'horiz "{" (math-compose-expr a -1) "}")
599 (list 'horiz "\\left( "
600 (math-compose-expr a -1)
602 (if (eq calc-language 'eqn)
603 (if (or (eq (car-safe a) '/)
605 (list 'horiz "{" (math-compose-expr a -1) "}")
606 (if (math-tex-expr-is-flat a)
607 (list 'horiz "( " (math-compose-expr a -1) " )")
608 (list 'horiz "{left ( "
609 (math-compose-expr a -1)
611 (list 'horiz "(" (math-compose-expr a 0) ")"))))
612 ((and (memq calc-language '(tex latex))
613 (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
615 (list 'horiz "{" (math-compose-expr a -1) "}"))
616 ((eq (car a) 'calcFunc-if)
618 (math-compose-expr (nth 1 a) (nth 2 op))
620 (math-compose-expr (nth 2 a) 0)
622 (math-compose-expr (nth 3 a) (nth 3 op))))
624 (let* ((math-comp-tagged (and math-comp-tagged
627 (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
629 (setq math-compose-level
630 (1- math-compose-level))
633 (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
634 (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
635 (and (equal (car op) "^")
636 (eq (math-comp-first-char lhs) ?-)
637 (setq lhs (list 'horiz "(" lhs ")")))
638 (and (memq calc-language '(tex latex))
639 (or (equal (car op) "^") (equal (car op) "_"))
640 (not (and (stringp rhs) (= (length rhs) 1)))
641 (setq rhs (list 'horiz "{" rhs "}")))
642 (or (and (eq (car a) '*)
643 (or (null calc-language)
644 (assoc "2x" math-expr-opers))
645 (let* ((prevt (math-prod-last-term (nth 1 a)))
646 (nextt (math-prod-first-term (nth 2 a)))
647 (prevc (or (math-comp-last-char lhs)
648 (and (memq (car-safe prevt)
652 (eq calc-language 'big)
654 (nextc (or (math-comp-first-char rhs)
655 (and (memq (car-safe nextt)
660 (eq calc-language 'big)
663 (or (and (>= nextc ?a) (<= nextc ?z))
664 (and (>= nextc ?A) (<= nextc ?Z))
665 (and (>= nextc ?0) (<= nextc ?9))
666 (memq nextc '(?. ?_ ?#
671 (math-comp-first-string
673 (not (and (eq (car-safe prevt) 'var)
678 (list 'break math-compose-level)
684 (list 'break math-compose-level)
685 (if (or (equal (car op) "^")
687 (equal (car op) "**")
688 (and (equal (car op) "*")
689 (math-comp-last-char lhs)
690 (math-comp-first-char rhs))
691 (and (equal (car op) "/")
692 (math-num-integerp (nth 1 a))
693 (math-integerp (nth 2 a))))
695 (if (and (eq calc-language 'big)
696 (equal (car op) "=>"))
698 (concat " " (car op) " ")))
700 ((and op (= (length a) 2) (= (nth 3 op) -1))
702 ((or (> prec (or (nth 4 op) (nth 2 op)))
703 (and (not (eq (assoc (car op) math-expr-opers) op))
704 (> prec 0))) ; don't write x% + y
705 (if (and (memq calc-language '(tex latex))
706 (not (math-tex-expr-is-flat a)))
707 (list 'horiz "\\left( "
708 (math-compose-expr a -1)
710 (if (eq calc-language 'eqn)
711 (if (= (/ prec 100) 9)
712 (list 'horiz "{" (math-compose-expr a -1) "}")
713 (if (math-tex-expr-is-flat a)
714 (list 'horiz "{( " (math-compose-expr a -1) " )}")
715 (list 'horiz "{left ( "
716 (math-compose-expr a -1)
718 (list 'horiz "(" (math-compose-expr a 0) ")"))))
720 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
723 (if (or (> (length (car op)) 1)
724 (not (math-comp-is-flat lhs)))
725 (concat " " (car op))
727 ((and op (= (length a) 2) (= (nth 2 op) -1))
730 (let ((lr (and (memq calc-language '(tex latex))
731 (not (math-tex-expr-is-flat (nth 1 a))))))
734 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
735 (substring (car op) 1)
737 (if (or lr (> (length (car op)) 2)) " " "")
738 (math-compose-expr (nth 1 a) -1)
739 (if (or lr (> (length (car op)) 2)) " " "")
741 (car (nth 1 (memq op math-expr-opers))))))
742 ((> prec (or (nth 4 op) (nth 3 op)))
743 (if (and (memq calc-language '(tex latex))
744 (not (math-tex-expr-is-flat a)))
745 (list 'horiz "\\left( "
746 (math-compose-expr a -1)
748 (if (eq calc-language 'eqn)
749 (if (= (/ prec 100) 9)
750 (list 'horiz "{" (math-compose-expr a -1) "}")
751 (if (math-tex-expr-is-flat a)
752 (list 'horiz "{( " (math-compose-expr a -1) " )}")
753 (list 'horiz "{left ( "
754 (math-compose-expr a -1)
756 (list 'horiz "(" (math-compose-expr a 0) ")"))))
758 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
760 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
762 (substring (car op) 1)
764 (if (or (> (length ops) 1)
765 (not (math-comp-is-flat rhs)))
769 ((and (eq calc-language 'big)
770 (setq op (get (car a) 'math-compose-big))
771 (funcall op a prec)))
772 ((and (setq op (assq calc-language
773 '( ( nil . math-compose-normal )
774 ( flat . math-compose-normal )
775 ( big . math-compose-normal )
776 ( c . math-compose-c )
777 ( pascal . math-compose-pascal )
778 ( fortran . math-compose-fortran )
779 ( tex . math-compose-tex )
780 ( latex . math-compose-latex )
781 ( eqn . math-compose-eqn )
782 ( yacas . math-compose-yacas )
783 ( maxima . math-compose-maxima )
784 ( giac . math-compose-giac )
785 ( math . math-compose-math )
786 ( maple . math-compose-maple ))))
787 (setq op (get (car a) (cdr op)))
788 (funcall op a prec)))
790 (let* ((func (car a))
791 (func2 (assq func '(( mod . calcFunc-makemod )
792 ( sdev . calcFunc-sdev )
799 ( neg . calcFunc-neg )
800 ( | . calcFunc-vconcat ))))
803 (setq func (cdr func2)))
804 (if (setq func2 (rassq func math-expr-function-mapping))
805 (setq func (car func2)))
806 (setq func (math-remove-dashes
808 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
810 (math-match-substring (symbol-name func) 1)
811 (symbol-name func))))
812 (if (memq calc-language calc-lang-allow-percentsigns)
813 (setq func (math-to-percentsigns func)))
814 (if (memq calc-language calc-lang-allow-underscores)
815 (setq func (math-to-underscores func)))
816 (if (setq spfn (get calc-language 'math-func-formatter))
817 (funcall spfn func a)
819 (list 'horiz func calc-function-open
820 (math-compose-vector (cdr a) ", " 0)
821 calc-function-close))))))))))
824 (defun math-prod-first-term (x)
825 (while (eq (car-safe x) '*)
829 (defun math-prod-last-term (x)
830 (while (eq (car-safe x) '*)
834 (defun math-compose-vector (a sep prec)
837 (cons (list 'set math-compose-level)
838 (let ((c (list (math-compose-expr (car a) prec))))
839 (while (setq a (cdr a))
840 (setq c (cons (if (eq (car-safe (car a))
842 (let ((math-compose-level
843 (1- math-compose-level)))
844 (math-compose-expr (car a) -123))
845 (math-compose-expr (car a) prec))
846 (cons (list 'break math-compose-level)
851 (defun math-vector-no-parens (a)
853 (not (eq (car-safe (nth 1 a)) '*))))
855 (defun math-compose-matrix (a col cols base)
858 (while (<= (setq col (1+ col)) cols)
859 (setq res (cons (cons math-comp-just
866 math-comp-vector-prec)
870 math-comp-comma-spc " ")))))
875 (defun math-compose-rows (a count first)
879 (math-compose-rows (cdr a) -1 nil)
881 (let ((mdots (get calc-language 'math-dots)))
886 (math-compose-rows (cdr a) -1 nil)))
888 (if first (concat math-comp-left-bracket " ") " ")
889 (math-compose-expr (car a) math-comp-vector-prec)
891 (math-compose-rows (cdr a) (1- count) nil)))
893 (if first (concat math-comp-left-bracket " ") " ")
894 (math-compose-expr (car a) math-comp-vector-prec)
895 (concat " " math-comp-right-bracket)))))
897 (defun math-vector-is-string (a)
898 (while (and (setq a (cdr a))
899 (or (and (natnump (car a))
901 (and (eq (car-safe (car a)) 'cplx)
902 (natnump (nth 1 (car a)))
903 (eq (nth 2 (car a)) 0)
904 (<= (nth 1 (car a)) 255)))))
907 (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
918 (defun math-vector-to-string (a &optional quoted)
919 (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
921 (if (string-match "[\000-\037\177\\\"]" a)
923 (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
924 (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
925 (fmt (if quoted "\\^%c" "^%c"))
927 (while (setq p (string-match pat a p))
928 (if (setq new (assq (aref a p) codes))
929 (setq a (concat (substring a 0 p)
931 (substring a (1+ p)))
932 p (+ p (length (cdr new))))
933 (setq a (concat (substring a 0 p)
934 (format fmt (+ (aref a p) 64))
935 (substring a (1+ p)))
942 (defun math-to-underscores (x)
943 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
945 (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
948 (defun math-to-percentsigns (x)
949 (if (string-match "\\`\\(.*\\)o'o\\(.*\\)\\'" x)
951 (concat (math-match-substring x 1) "%" (math-match-substring x 2)))
954 (defun math-tex-expr-is-flat (a)
955 (or (Math-integerp a)
956 (memq (car a) '(float var))
957 (and (memq (car a) '(+ - * neg))
959 (while (and (setq a (cdr a))
960 (math-tex-expr-is-flat (car a))))
962 (and (memq (car a) '(^ calcFunc-subscr))
963 (math-tex-expr-is-flat (nth 1 a)))))
965 (put 'calcFunc-log 'math-compose-big 'math-compose-log)
966 (defun math-compose-log (a prec)
967 (and (= (length a) 3)
970 (let ((calc-language 'flat))
971 (math-compose-expr (nth 2 a) 1000)))
973 (math-compose-expr (nth 1 a) 1000)
976 (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
977 (defun math-compose-log10 (a prec)
978 (and (= (length a) 2)
980 (list 'subscr "log" "10")
982 (math-compose-expr (nth 1 a) 1000)
985 (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
986 (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
987 (defun math-compose-deriv (a prec)
988 (when (= (length a) 3)
989 (math-compose-expr (list '/
990 (list 'calcFunc-choriz
992 '(calcFunc-string (vec ?d))
994 (list 'calcFunc-choriz
996 '(calcFunc-string (vec ?d))
1000 (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
1001 (defun math-compose-sqrt (a prec)
1002 (when (= (length a) 2)
1003 (let* ((c (math-compose-expr (nth 1 a) 0))
1004 (a (math-comp-ascent c))
1005 (d (math-comp-descent c))
1007 (w (math-comp-width c)))
1010 (concat (if (= h 1) " " " ")
1011 (make-string (+ w 2) ?\_))
1015 (append (list 'vleft (1- a))
1016 (make-list (1- h) " |")
1021 (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
1022 (defun math-compose-choose (a prec)
1023 (let ((a1 (math-compose-expr (nth 1 a) 0))
1024 (a2 (math-compose-expr (nth 2 a) 0)))
1028 (math-comp-height a1)
1032 (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
1033 (defun math-compose-integ (a prec)
1034 (and (memq (length a) '(3 5))
1035 (eq (car-safe (nth 2 a)) 'var)
1036 (let* ((parens (and (>= prec 196) (/= prec 1000)))
1037 (var (math-compose-expr (nth 2 a) 0))
1038 (over (and (eq (car-safe (nth 2 a)) 'var)
1039 (or (and (eq (car-safe (nth 1 a)) '/)
1040 (math-numberp (nth 1 (nth 1 a))))
1041 (and (eq (car-safe (nth 1 a)) '^)
1042 (math-looks-negp (nth 2 (nth 1 a)))))))
1043 (expr (math-compose-expr (if over
1045 (math-build-var-name
1048 (nth 1 (nth 2 a)))))
1050 (calc-language 'flat)
1051 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1052 (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
1055 (append (list 'vcent (if high 3 2))
1056 (and high (list (list 'horiz " " high)))
1062 (and low (list (list 'horiz low " "))))
1066 (list 'horiz " d" var))
1067 (if parens ")" "")))))
1069 (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
1070 (defun math-compose-sum (a prec)
1071 (and (memq (length a) '(3 5 6))
1072 (let* ((expr (math-compose-expr (nth 1 a) 185))
1073 (calc-language 'flat)
1074 (var (math-compose-expr (nth 2 a) 0))
1075 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1076 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1078 (if (memq prec '(180 201)) "(" "")
1079 (append (list 'vcent (if high 3 2))
1080 (and high (list high))
1087 (list (list 'horiz var " = " low))
1089 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1092 (if (memq prec '(180 201)) ")" "")))))
1094 (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
1095 (defun math-compose-prod (a prec)
1096 (and (memq (length a) '(3 5 6))
1097 (let* ((expr (math-compose-expr (nth 1 a) 198))
1098 (calc-language 'flat)
1099 (var (math-compose-expr (nth 2 a) 0))
1100 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1101 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1103 (if (memq prec '(196 201)) "(" "")
1104 (append (list 'vcent (if high 3 2))
1105 (and high (list high))
1111 (list (list 'horiz var " = " low))
1113 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1116 (if (memq prec '(196 201)) ")" "")))))
1118 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1119 ;; to math-stack-value-offset in calc.el, but are used by
1120 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1122 (defvar math-svo-wid)
1123 (defvar math-svo-off)
1125 (defun math-stack-value-offset-fancy ()
1126 (let ((cwid (+ (math-comp-width math-svo-c))))
1127 (cond ((eq calc-display-just 'right)
1128 (if calc-display-origin
1129 (setq math-svo-wid (max calc-display-origin 5))
1130 (if (integerp calc-line-breaking)
1131 (setq math-svo-wid calc-line-breaking)))
1132 (setq math-svo-off (- math-svo-wid cwid
1133 (max (- (length calc-right-label)
1134 (if (and (integerp calc-line-breaking)
1135 calc-display-origin)
1136 (max (- calc-line-breaking
1137 calc-display-origin)
1142 (if calc-display-origin
1144 (setq math-svo-off (- calc-display-origin (/ cwid 2)))
1145 (if (integerp calc-line-breaking)
1146 (setq math-svo-off (min math-svo-off (- calc-line-breaking cwid
1147 (length calc-right-label)))))
1148 (if (>= math-svo-off 0)
1149 (setq math-svo-wid (max math-svo-wid (+ math-svo-off cwid)))))
1150 (if (integerp calc-line-breaking)
1151 (setq math-svo-wid calc-line-breaking))
1152 (setq math-svo-off (/ (- math-svo-wid cwid) 2)))))
1153 (and (integerp calc-line-breaking)
1154 (or (< math-svo-off 0)
1155 (and calc-display-origin
1156 (> calc-line-breaking calc-display-origin)))
1157 (setq math-svo-wid calc-line-breaking))))
1160 ;;; Convert a composition to string form, with embedded \n's if necessary.
1162 (defun math-composition-to-string (c &optional width)
1163 (or width (setq width (calc-window-width)))
1164 (if calc-display-raw
1165 (math-comp-to-string-raw c 0)
1166 (if (math-comp-is-flat c)
1167 (math-comp-to-string-flat c width)
1168 (math-vert-comp-to-string
1169 (math-comp-simplify c width)))))
1171 (defvar math-comp-buf-string (make-vector 10 ""))
1172 (defvar math-comp-buf-margin (make-vector 10 0))
1173 (defvar math-comp-buf-level (make-vector 10 0))
1174 (defun math-comp-is-flat (c) ; check if c's height is 1.
1175 (cond ((not (consp c)) t)
1176 ((memq (car c) '(set break)) t)
1177 ((eq (car c) 'horiz)
1178 (while (and (setq c (cdr c))
1179 (math-comp-is-flat (car c))))
1181 ((memq (car c) '(vleft vcent vright))
1182 (and (= (length c) 3)
1184 (math-comp-is-flat (nth 2 c))))
1186 (math-comp-is-flat (nth 2 c)))
1190 ;;; Convert a one-line composition to a string. Break into multiple
1191 ;;; lines if necessary, choosing break points according to the structure
1194 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1195 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1196 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1197 ;; which is called by math-comp-to-string-flat.
1198 ;; math-comp-highlight and math-comp-buf are also local to
1199 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1200 ;; by math-comp-add-string.
1201 (defvar math-comp-full-width)
1202 (defvar math-comp-highlight)
1203 (defvar math-comp-word)
1204 (defvar math-comp-level)
1205 (defvar math-comp-margin)
1206 (defvar math-comp-buf)
1207 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1208 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1209 ;; which are called by math-comp-to-string-flat.
1210 (defvar math-comp-pos)
1212 (defun math-comp-to-string-flat (c math-comp-full-width)
1213 (if math-comp-sel-hpos
1214 (let ((math-comp-pos 0))
1215 (math-comp-sel-flat-term c))
1216 (let ((math-comp-buf "")
1219 (math-comp-margin 0)
1220 (math-comp-highlight (and math-comp-selected calc-show-selections))
1221 (math-comp-level -1))
1222 (math-comp-to-string-flat-term '(set -1 0))
1223 (math-comp-to-string-flat-term c)
1224 (math-comp-to-string-flat-term '(break -1))
1225 (let ((str (aref math-comp-buf-string 0))
1227 (and (> (length str) 0) (= (aref str 0) ? )
1228 (> (length math-comp-buf) 0)
1229 (let ((k (length math-comp-buf)))
1230 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1231 (aset math-comp-buf k ? )
1232 (if (and (< (1+ k) (length math-comp-buf))
1233 (= (aref math-comp-buf (1+ k)) ? ))
1235 (aset math-comp-buf (1+ k) ?\n)
1237 (setq prefix "\n"))))
1238 (concat math-comp-buf prefix str)))))
1240 (defun math-comp-to-string-flat-term (c)
1241 (cond ((not (consp c))
1242 (if math-comp-highlight
1243 (setq c (math-comp-highlight-string c)))
1244 (setq math-comp-word (if (= (length math-comp-word) 0) c
1245 (concat math-comp-word c))
1246 math-comp-pos (+ math-comp-pos (length c))))
1248 ((eq (car c) 'horiz)
1249 (while (setq c (cdr c))
1250 (math-comp-to-string-flat-term (car c))))
1255 (setq math-comp-level (1+ math-comp-level))
1256 (if (>= math-comp-level (length math-comp-buf-string))
1257 (setq math-comp-buf-string (vconcat math-comp-buf-string
1258 math-comp-buf-string)
1259 math-comp-buf-margin (vconcat math-comp-buf-margin
1260 math-comp-buf-margin)
1261 math-comp-buf-level (vconcat math-comp-buf-level
1262 math-comp-buf-level)))
1263 (aset math-comp-buf-string math-comp-level "")
1264 (aset math-comp-buf-margin math-comp-level (+ math-comp-pos
1266 (aset math-comp-buf-level math-comp-level (nth 1 c)))))
1268 ((eq (car c) 'break)
1269 (if (not calc-line-breaking)
1270 (setq math-comp-buf (concat math-comp-buf math-comp-word)
1273 (if (and (> math-comp-pos math-comp-full-width)
1276 (setq str (aref math-comp-buf-string i))
1277 (and (= (length str) 0) (< i math-comp-level)))
1279 (or (> (length str) 0) (> (length math-comp-buf) 0))))
1280 (let ((prefix "") mrg wid)
1281 (setq mrg (aref math-comp-buf-margin i))
1282 (if (> mrg 12) ; indenting too far, go back to far left
1283 (let ((j i) (new (if calc-line-numbering 5 1)))
1284 '(while (<= j math-comp-level)
1285 (aset math-comp-buf-margin j
1286 (+ (aref math-comp-buf-margin j) (- new mrg)))
1289 (setq wid (+ (length str) math-comp-margin))
1290 (and (> (length str) 0) (= (aref str 0) ? )
1291 (> (length math-comp-buf) 0)
1292 (let ((k (length math-comp-buf)))
1293 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1294 (aset math-comp-buf k ? )
1295 (if (and (< (1+ k) (length math-comp-buf))
1296 (= (aref math-comp-buf (1+ k)) ? ))
1298 (aset math-comp-buf (1+ k) ?\n)
1300 (setq prefix "\n"))))
1301 (setq math-comp-buf (concat math-comp-buf prefix str "\n"
1302 (make-string mrg ? ))
1303 math-comp-pos (+ math-comp-pos (- mrg wid))
1304 math-comp-margin mrg)
1305 (aset math-comp-buf-string i "")
1306 (while (<= (setq i (1+ i)) math-comp-level)
1307 (if (> (aref math-comp-buf-margin i) wid)
1308 (aset math-comp-buf-margin i
1309 (+ (aref math-comp-buf-margin i)
1311 (if (and (= (nth 1 c) (aref math-comp-buf-level math-comp-level))
1312 (< math-comp-pos (+ (aref math-comp-buf-margin math-comp-level) 2)))
1313 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1314 (let ((str (aref math-comp-buf-string math-comp-level)))
1315 (setq str (if (= (length str) 0)
1317 (concat str math-comp-word))
1319 (while (< (nth 1 c) (aref math-comp-buf-level math-comp-level))
1320 (setq math-comp-level (1- math-comp-level))
1321 (or (= (length (aref math-comp-buf-string math-comp-level)) 0)
1322 (setq str (concat (aref math-comp-buf-string math-comp-level)
1324 (aset math-comp-buf-string math-comp-level str)))))
1327 (cond ((eq (nth 1 c) math-comp-selected)
1328 (let ((math-comp-highlight (not calc-show-selections)))
1329 (math-comp-to-string-flat-term (nth 2 c))))
1331 (let ((math-comp-highlight nil))
1332 (math-comp-to-string-flat-term (nth 2 c))))
1333 (t (math-comp-to-string-flat-term (nth 2 c)))))
1335 (t (math-comp-to-string-flat-term (nth 2 c)))))
1337 (defun math-comp-highlight-string (s)
1338 (setq s (copy-sequence s))
1339 (let ((i (length s)))
1340 (while (>= (setq i (1- i)) 0)
1341 (or (memq (aref s i) '(32 ?\n))
1342 (aset s i (if calc-show-selections ?\. ?\#)))))
1346 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1347 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1348 ;; math-comp-add-string-sel, which are called (indirectly) by
1349 ;; calc-find-selected-part.
1350 (defvar math-comp-sel-tag)
1352 (defun math-comp-sel-flat-term (c)
1353 (cond ((not (consp c))
1354 (setq math-comp-pos (+ math-comp-pos (length c))))
1355 ((memq (car c) '(set break)))
1356 ((eq (car c) 'horiz)
1357 (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
1358 (math-comp-sel-flat-term (car c))))
1360 (if (<= math-comp-pos math-comp-sel-cpos)
1362 (math-comp-sel-flat-term (nth 2 c))
1363 (if (> math-comp-pos math-comp-sel-cpos)
1364 (setq math-comp-sel-tag c
1365 math-comp-sel-cpos 1000000)))
1366 (math-comp-sel-flat-term (nth 2 c))))
1367 (t (math-comp-sel-flat-term (nth 2 c)))))
1370 ;;; Simplify a composition to a canonical form consisting of
1371 ;;; (vleft n "string" "string" "string" ...)
1372 ;;; where 0 <= n < number-of-strings.
1374 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1375 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1376 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1377 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1378 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1379 ;; math-comp-simplify.
1380 (defvar math-comp-base)
1381 (defvar math-comp-hgt)
1382 (defvar math-comp-tag)
1383 (defvar math-comp-hpos)
1384 (defvar math-comp-vpos)
1386 (defun math-comp-simplify (c full-width)
1387 (let ((math-comp-buf (list ""))
1392 (math-comp-highlight (and math-comp-selected calc-show-selections))
1393 (math-comp-tag nil))
1394 (math-comp-simplify-term c)
1395 (cons 'vleft (cons math-comp-base math-comp-buf))))
1397 (defun math-comp-add-string (s h v)
1398 (and (> (length s) 0)
1399 (let ((vv (+ v math-comp-base)))
1400 (if math-comp-sel-hpos
1401 (math-comp-add-string-sel h vv (length s) 1)
1403 (setq math-comp-buf (nconc (make-list (- vv) "") math-comp-buf)
1404 math-comp-base (- v)
1405 math-comp-hgt (- math-comp-hgt vv)
1407 (if (>= vv math-comp-hgt)
1408 (setq math-comp-buf (nconc math-comp-buf
1409 (make-list (1+ (- vv math-comp-hgt)) ""))
1410 math-comp-hgt (1+ vv))))
1411 (let ((str (nthcdr vv math-comp-buf)))
1412 (setcar str (concat (car str)
1413 (make-string (- h (length (car str))) 32)
1414 (if math-comp-highlight
1415 (math-comp-highlight-string s)
1418 (defun math-comp-add-string-sel (x y w h)
1419 (if (and (<= y math-comp-sel-vpos)
1420 (> (+ y h) math-comp-sel-vpos)
1421 (<= x math-comp-sel-hpos)
1422 (> (+ x w) math-comp-sel-hpos))
1423 (setq math-comp-sel-tag math-comp-tag
1424 math-comp-sel-vpos 10000)))
1426 (defun math-comp-simplify-term (c)
1428 (math-comp-add-string c math-comp-hpos math-comp-vpos)
1429 (setq math-comp-hpos (+ math-comp-hpos (length c))))
1430 ((memq (car c) '(set break))
1432 ((eq (car c) 'horiz)
1433 (while (setq c (cdr c))
1434 (math-comp-simplify-term (car c))))
1435 ((memq (car c) '(vleft vcent vright))
1436 (let* ((math-comp-vpos (+ (- math-comp-vpos (nth 1 c))
1437 (1- (math-comp-ascent (nth 2 c)))))
1438 (widths (mapcar 'math-comp-width (cdr (cdr c))))
1439 (maxwid (apply 'max widths))
1440 (bias (cond ((eq (car c) 'vleft) 0)
1441 ((eq (car c) 'vcent) 1)
1444 (while (setq c (cdr c))
1445 (if (eq (car-safe (car c)) 'rule)
1446 (math-comp-add-string (make-string maxwid (nth 1 (car c)))
1447 math-comp-hpos math-comp-vpos)
1448 (let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid
1451 (math-comp-simplify-term (car c))))
1453 (setq math-comp-vpos (+ math-comp-vpos
1454 (+ (math-comp-descent (car c))
1455 (math-comp-ascent (nth 1 c))))
1456 widths (cdr widths))))
1457 (setq math-comp-hpos (+ math-comp-hpos maxwid))))
1458 ((eq (car c) 'supscr)
1459 (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
1460 (desc (math-comp-descent (nth 2 c)))
1463 (math-comp-simplify-term (nth 1 c))))
1464 (math-comp-vpos (- math-comp-vpos (+ asc desc))))
1465 (math-comp-simplify-term (nth 2 c))
1466 (if math-comp-sel-hpos
1467 (math-comp-add-string-sel oldh
1470 (math-comp-ascent (nth 2 c)))
1471 (- math-comp-hpos oldh)
1472 (math-comp-height c)))))
1473 ((eq (car c) 'subscr)
1474 (let* ((asc (math-comp-ascent (nth 2 c)))
1475 (desc (math-comp-descent (nth 1 c)))
1476 (oldv math-comp-vpos)
1479 (math-comp-simplify-term (nth 1 c))))
1480 (math-comp-vpos (+ math-comp-vpos (+ asc desc))))
1481 (math-comp-simplify-term (nth 2 c))
1482 (if math-comp-sel-hpos
1483 (math-comp-add-string-sel oldh oldv
1484 (- math-comp-hpos oldh)
1485 (math-comp-height c)))))
1487 (cond ((eq (nth 1 c) math-comp-selected)
1488 (let ((math-comp-highlight (not calc-show-selections)))
1489 (math-comp-simplify-term (nth 2 c))))
1491 (let ((math-comp-highlight nil))
1492 (math-comp-simplify-term (nth 2 c))))
1493 (t (let ((math-comp-tag c))
1494 (math-comp-simplify-term (nth 2 c))))))))
1497 ;;; Measuring a composition.
1499 (defun math-comp-first-char (c)
1501 (and (> (length c) 0)
1503 ((memq (car c) '(horiz subscr supscr))
1504 (while (and (setq c (cdr c))
1505 (math-comp-is-null (car c))))
1506 (and c (math-comp-first-char (car c))))
1508 (math-comp-first-char (nth 2 c)))))
1510 (defun math-comp-first-string (c)
1512 (and (> (length c) 0)
1514 ((eq (car c) 'horiz)
1515 (while (and (setq c (cdr c))
1516 (math-comp-is-null (car c))))
1517 (and c (math-comp-first-string (car c))))
1519 (math-comp-first-string (nth 2 c)))))
1521 (defun math-comp-last-char (c)
1523 (and (> (length c) 0)
1524 (elt c (1- (length c)))))
1525 ((eq (car c) 'horiz)
1526 (let ((c (reverse (cdr c))))
1527 (while (and c (math-comp-is-null (car c)))
1529 (and c (math-comp-last-char (car c)))))
1531 (math-comp-last-char (nth 2 c)))))
1533 (defun math-comp-is-null (c)
1534 (cond ((stringp c) (= (length c) 0))
1535 ((memq (car c) '(horiz subscr supscr))
1536 (while (and (setq c (cdr c))
1537 (math-comp-is-null (car c))))
1540 (math-comp-is-null (nth 2 c)))
1541 ((memq (car c) '(set break)) t)))
1543 (defun math-comp-width (c)
1544 (cond ((not (consp c)) (length c))
1545 ((memq (car c) '(horiz subscr supscr))
1547 (while (setq c (cdr c))
1548 (setq accum (+ accum (math-comp-width (car c)))))
1550 ((memq (car c) '(vcent vleft vright))
1553 (while (setq c (cdr c))
1554 (setq accum (max accum (math-comp-width (car c)))))
1557 (math-comp-width (nth 2 c)))
1560 (defun math-comp-height (c)
1563 (+ (math-comp-ascent c) (math-comp-descent c))))
1565 (defun math-comp-ascent (c)
1566 (cond ((not (consp c)) 1)
1567 ((eq (car c) 'horiz)
1569 (while (setq c (cdr c))
1570 (setq accum (max accum (math-comp-ascent (car c)))))
1572 ((memq (car c) '(vcent vleft vright))
1573 (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
1574 ((eq (car c) 'supscr)
1575 (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
1576 ((eq (car c) 'subscr)
1577 (math-comp-ascent (nth 1 c)))
1579 (math-comp-ascent (nth 2 c)))
1582 (defun math-comp-descent (c)
1583 (cond ((not (consp c)) 0)
1584 ((eq (car c) 'horiz)
1586 (while (setq c (cdr c))
1587 (setq accum (max accum (math-comp-descent (car c)))))
1589 ((memq (car c) '(vcent vleft vright))
1590 (let ((accum (- (nth 1 c))))
1592 (while (setq c (cdr c))
1593 (setq accum (+ accum (math-comp-height (car c)))))
1594 (max (1- accum) 0)))
1595 ((eq (car c) 'supscr)
1596 (math-comp-descent (nth 1 c)))
1597 ((eq (car c) 'subscr)
1598 (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
1600 (math-comp-descent (nth 2 c)))
1603 (defun calcFunc-cwidth (a &optional prec)
1604 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1605 (math-comp-width (math-compose-expr a (or prec 0))))
1607 (defun calcFunc-cheight (a &optional prec)
1608 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1609 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1610 (memq (length a) '(2 3))
1613 (math-comp-height (math-compose-expr a (or prec 0)))))
1615 (defun calcFunc-cascent (a &optional prec)
1616 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1617 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1618 (memq (length a) '(2 3))
1621 (math-comp-ascent (math-compose-expr a (or prec 0)))))
1623 (defun calcFunc-cdescent (a &optional prec)
1624 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1625 (math-comp-descent (math-compose-expr a (or prec 0))))
1628 ;;; Convert a simplified composition into string form.
1630 (defun math-vert-comp-to-string (c)
1633 (math-vert-comp-to-string-step (cdr (cdr c)))))
1635 (defun math-vert-comp-to-string-step (c)
1637 (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
1641 ;;; Convert a composition to a string in "raw" form (for debugging).
1643 (defun math-comp-to-string-raw (c indent)
1644 (cond ((or (not (consp c)) (eq (car c) 'set))
1645 (prin1-to-string c))
1647 (concat "(" (symbol-name (car c)) ")"))
1649 (let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
1651 (symbol-name (car c))
1653 (math-comp-to-string-raw (nth 1 c) next-indent)
1654 (math-comp-to-string-raw-step (cdr (cdr c))
1658 (defun math-comp-to-string-raw-step (cl indent)
1661 (make-string indent 32)
1662 (math-comp-to-string-raw (car cl) indent)
1663 (math-comp-to-string-raw-step (cdr cl) indent))
1668 ;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1669 ;;; calccomp.el ends here