1 ;;; calccomp.el --- composition functions for Calc
3 ;; Copyright (C) 1990-1993, 2001-2016 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This file is autoloaded from calc-ext.el.
31 ;;; A "composition" has one of the following forms:
33 ;;; "string" A literal string
35 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
37 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
38 ;;; (break LEVEL) A potential line-break point
40 ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
41 ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
42 ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
43 ;;; N specifies baseline of the stack, 0=top line.
45 ;;; (supscr C1 C2) Composition C1 with superscript C2
46 ;;; (subscr C1 C2) Composition C1 with subscript C2
47 ;;; (rule X) Horizontal line of X, full width of enclosing comp
49 ;;; (tag X C) Composition C corresponds to sub-expression X
51 ;; math-comp-just and math-comp-comma-spc are local to
52 ;; math-compose-expr, but are used by math-compose-matrix, which is
53 ;; called by math-compose-expr
54 (defvar math-comp-just)
55 (defvar math-comp-comma-spc)
57 ;; math-comp-vector-prec is local to math-compose-expr, but is used by
58 ;; math-compose-matrix and math-compose-rows, which are called by
60 (defvar math-comp-vector-prec)
62 ;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
63 ;; local to math-compose-expr, but are used by math-compose-rows, which is
64 ;; called by math-compose-expr.
65 (defvar math-comp-left-bracket)
66 (defvar math-comp-right-bracket)
67 (defvar math-comp-comma)
69 (defun math-compose-var (a)
71 (if (and math-compose-hash-args
72 (let ((p calc-arg-values))
74 (while (and p (not (equal (car p) a)))
75 (setq p (and (eq math-compose-hash-args t) (cdr p))
78 (if (eq math-compose-hash-args 1)
81 (setq sn (symbol-name (nth 1 a)))
82 (if (memq calc-language calc-lang-allow-percentsigns)
83 (setq sn (math-to-percentsigns sn)))
84 (if (memq calc-language calc-lang-allow-underscores)
85 (setq sn (math-to-underscores sn)))
88 ;;; Give multiplication precedence when composing to avoid
89 ;;; writing a*(b c) instead of a b c
90 (defun math-compose-expr (a prec &optional div)
91 (let ((calc-multiplication-has-precedence t)
92 (math-compose-level (1+ math-compose-level))
93 (math-expr-opers (math-expr-ops))
96 ((or (and (eq a math-comp-selected) a)
98 (not (eq math-comp-tagged a))))
99 (let ((math-comp-selected nil))
100 (and math-comp-tagged (setq math-comp-tagged a))
101 (list 'tag a (math-compose-expr a prec))))
102 ((and (not (consp a)) (not (integerp a)))
103 (concat "'" (prin1-to-string a)))
104 ((setq spfn (assq (car-safe a)
105 (get calc-language 'math-special-function-table)))
106 (setq spfn (cdr spfn))
108 (funcall (car spfn) a spfn)
111 (if (or (eq (car-safe a) 'frac)
112 (and (nth 1 calc-frac-format) (Math-integerp a)))
115 (not (memq calc-language
116 '(flat big unform))))
117 (let ((aa (math-adjust-fraction a))
118 (calc-frac-format nil))
119 (math-compose-expr (list '/
120 (if (memq calc-language
121 calc-lang-slash-idiv)
122 (math-float (nth 1 aa))
125 (if (and (eq calc-language 'big)
126 (= (length (car calc-frac-format)) 1))
127 (let* ((aa (math-adjust-fraction a))
128 (calc-frac-format nil)
129 (math-radix-explicit-format nil)
131 (if (math-negp (nth 1 aa))
135 (math-abs (nth 1 aa)))
137 (math-format-number (nth 2 aa))))))
138 (if (= calc-number-radix 10)
142 (int-to-string calc-number-radix)))))
143 (math-format-number a)))
144 (if (not (eq calc-language 'big))
145 (math-format-number a prec)
146 (if (memq (car-safe a) '(cplx polar))
147 (if (math-zerop (nth 2 a))
148 (math-compose-expr (nth 1 a) prec)
150 (math-compose-expr (nth 1 a) 0)
151 (if (eq (car a) 'cplx) ", " "; ")
152 (math-compose-expr (nth 2 a) 0) ")"))
153 (if (or (= calc-number-radix 10)
155 (and calc-group-digits
156 (not (assoc calc-group-char '((",") (" "))))))
157 (math-format-number a prec)
158 (let ((s (math-format-number a prec))
160 (while (string-match (if (> calc-number-radix 14)
161 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
162 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
164 (setq c (nconc c (list (substring s 0 (match-beginning 0))
166 (math-match-substring s 2)
167 (math-match-substring s 1))))
168 s (substring s (match-end 0))))
170 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
172 (substring s 0 (match-beginning 0)) " "
174 (math-match-substring s 1)
175 (math-match-substring s 2))
176 (math-match-substring s 3))))
177 (if c (cons 'horiz (nconc c (list s))) s)))))))
178 ((and (get (car a) 'math-compose-forms)
179 (not (eq calc-language 'unform))
180 (let ((comps (get (car a) 'math-compose-forms))
182 (or (and (setq temp (assq calc-language comps))
183 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
184 (setq temp (apply (cdr temp2) (cdr a)))
185 (math-compose-expr temp prec))
186 (and (setq temp2 (assq nil (cdr temp)))
187 (funcall (cdr temp2) a))))
188 (and (setq temp (assq nil comps))
189 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
190 (setq temp (apply (cdr temp2) (cdr a)))
191 (math-compose-expr temp prec))
192 (and (setq temp2 (assq nil (cdr temp)))
193 (funcall (cdr temp2) a))))))))
195 (let* ((math-comp-left-bracket (if calc-vector-brackets
196 (substring calc-vector-brackets 0 1) ""))
197 (math-comp-right-bracket (if calc-vector-brackets
198 (substring calc-vector-brackets 1 2) ""))
199 (inner-brackets (memq 'R calc-matrix-brackets))
200 (outer-brackets (memq 'O calc-matrix-brackets))
201 (row-commas (memq 'C calc-matrix-brackets))
202 (math-comp-comma-spc (or calc-vector-commas " "))
203 (math-comp-comma (or calc-vector-commas ""))
204 (math-comp-vector-prec (if (or (and calc-vector-commas
205 (math-vector-no-parens a))
206 (memq 'P calc-matrix-brackets)) 0 1000))
207 (math-comp-just (cond ((eq calc-matrix-just 'right) 'vright)
208 ((eq calc-matrix-just 'center) 'vcent)
210 (break calc-break-vectors))
211 (if (and (memq calc-language '(nil big))
212 (not calc-break-vectors)
213 (math-matrixp a) (not (math-matrixp (nth 1 a)))
214 (or calc-full-vectors
215 (and (< (length a) 7) (< (length (nth 1 a)) 7))
216 (progn (setq break t) nil)))
218 (setq math-comp-vector-prec (if (or (and calc-vector-commas
219 (math-vector-no-parens
221 (memq 'P calc-matrix-brackets))
225 (concat math-comp-left-bracket math-comp-left-bracket " ")
226 (math-compose-vector (cdr (nth 1 a)) (concat math-comp-comma " ")
227 math-comp-vector-prec)
228 (concat " " math-comp-right-bracket math-comp-right-bracket))
229 (let* ((rows (1- (length a)))
230 (cols (1- (length (nth 1 a))))
231 (base (/ (1- rows) 2))
232 (calc-language 'flat))
234 (list (append '(vleft)
236 (list (concat (and outer-brackets
237 (concat math-comp-left-bracket
240 (concat math-comp-left-bracket
243 (concat (and outer-brackets
247 math-comp-left-bracket
249 (math-compose-matrix (cdr a) 1 cols base)
250 (list (append '(vleft)
255 math-comp-right-bracket
258 (if (and outer-brackets
264 math-comp-right-bracket))
268 math-comp-right-bracket)))))))))
269 (if (and calc-display-strings
271 (math-vector-is-string a))
272 (math-vector-to-string a t)
273 (if (and break (cdr a)
274 (not (eq calc-language 'flat)))
275 (let* ((full (or calc-full-vectors (< (length a) 7)))
276 (rows (if full (1- (length a)) 5))
277 (base (/ (1- rows) 2))
278 (calc-break-vectors nil))
280 (cons 'vleft (cons base
283 (if full rows 3) t)))))
284 (if (or calc-full-vectors (< (length a) 7))
286 (setq spfn (get calc-language 'math-matrix-formatter))
290 math-comp-left-bracket
291 (math-compose-vector (cdr a)
292 (concat math-comp-comma " ")
293 math-comp-vector-prec)
294 math-comp-right-bracket))
296 math-comp-left-bracket
297 (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
298 (concat math-comp-comma " ")
299 math-comp-vector-prec)
301 (if (setq spfn (get calc-language 'math-dots))
305 (list 'break math-compose-level)
306 (math-compose-expr (nth (1- (length a)) a)
307 (if (equal math-comp-comma "") 1000 0))
308 math-comp-right-bracket)))))))
309 ((eq (car a) 'incomplete)
311 (cond ((eq (nth 1 a) 'vec)
313 (math-compose-vector (cdr (cdr a)) ", " 0)
315 ((eq (nth 1 a) 'cplx)
317 (math-compose-vector (cdr (cdr a)) ", " 0)
319 ((eq (nth 1 a) 'polar)
321 (math-compose-vector (cdr (cdr a)) "; " 0)
323 ((eq (nth 1 a) 'intv)
325 (if (memq (nth 2 a) '(0 1)) "(" "[")
326 (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
329 (cond ((eq (nth 1 a) 'vec) "[ ...")
330 ((eq (nth 1 a) 'intv)
331 (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
334 (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
336 (symbol-name (car v))
337 (if (setq spfn (get calc-language 'math-var-formatter))
338 (funcall spfn a prec)
339 (math-compose-var a)))))
342 (if (memq (nth 1 a) '(0 1)) "(" "[")
343 (math-compose-expr (nth 2 a) 0)
345 (math-compose-expr (nth 3 a) 0)
346 (if (memq (nth 1 a) '(0 2)) ")" "]")))
348 (if (eq (car calc-date-format) 'X)
350 (concat "<" (math-format-date a) ">")))
351 ((and (eq (car a) 'calcFunc-subscr)
352 (setq spfn (get calc-language 'math-compose-subscr)))
354 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
355 (eq calc-language 'big))
356 (let* ((a1 (math-compose-expr (nth 1 a) 1000))
357 (calc-language 'flat)
358 (a2 (math-compose-expr (nth 2 a) 0)))
359 (if (or (eq (car-safe a1) 'subscr)
360 (and (eq (car-safe a1) 'tag)
361 (eq (car-safe (nth 2 a1)) 'subscr)
362 (setq a1 (nth 2 a1))))
369 (list 'subscr a1 a2))))
370 ((and (eq (car a) '^)
371 (eq calc-language 'big))
373 (if (or (math-looks-negp (nth 1 a))
374 (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
375 (and (eq (car-safe (nth 1 a)) 'cplx)
376 (math-negp (nth 1 (nth 1 a)))
377 (eq (nth 2 (nth 1 a)) 0)))
378 (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
379 (math-compose-expr (nth 1 a) 201))
380 (let ((calc-language 'flat)
381 (calc-number-radix 10)
382 (calc-twos-complement-mode nil))
383 (math-compose-expr (nth 2 a) 0))))
384 ((and (eq (car a) '/)
385 (eq calc-language 'big))
386 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
388 (math-compose-expr (nth 1 a) 0)))
389 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
391 (math-compose-expr (nth 2 a) 0))))
393 (math-comp-height a1)
395 ((and (eq (car a) 'calcFunc-lambda)
397 (memq calc-language '(nil flat big)))
400 (math-compose-hash-args (if (= (length a) 3) 1 t)))
401 (while (and (cdr p) (equal (car p) (car ap)))
402 (setq p (cdr p) ap (cdr ap)))
405 (list (math-compose-vector
406 (nreverse (cdr (reverse (cdr a)))) ", " 0)
409 (list (math-compose-expr (nth (1- (length a)) a) 0)
411 ((and (eq (car a) 'calcFunc-string)
413 (math-vectorp (nth 1 a))
414 (math-vector-is-string (nth 1 a)))
415 (if (eq calc-language 'unform)
416 (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
417 (math-vector-to-string (nth 1 a) nil)))
418 ((and (eq (car a) 'calcFunc-bstring)
420 (math-vectorp (nth 1 a))
421 (math-vector-is-string (nth 1 a)))
422 (if (eq calc-language 'unform)
423 (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
425 (s (math-vector-to-string (nth 1 a) nil))
427 (while (string-match "[^ ] +[^ ]" s)
428 (setq p (1- (match-end 0))
429 c (cons (list 'break math-compose-level)
430 (cons (substring s 0 p)
433 (setq c (nreverse (cons s c)))
435 (setq c (cons (list 'set math-compose-level 2) c)))
437 ((and (eq (car a) 'calcFunc-cprec)
438 (not (eq calc-language 'unform))
440 (integerp (nth 2 a)))
441 (let ((c (math-compose-expr (nth 1 a) -1)))
442 (if (> prec (nth 2 a))
443 (if (setq spfn (get calc-language 'math-big-parens))
444 (list 'horiz (car spfn) c (cdr spfn))
445 (list 'horiz "(" c ")"))
447 ((and (eq (car a) 'calcFunc-choriz)
448 (not (eq calc-language 'unform))
449 (memq (length a) '(2 3 4))
450 (math-vectorp (nth 1 a))
451 (if (integerp (nth 2 a))
453 (and (math-vectorp (nth 3 a))
454 (math-vector-is-string (nth 3 a))))
456 (and (math-vectorp (nth 2 a))
457 (math-vector-is-string (nth 2 a))))))
458 (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
459 (sep (nth (if cprec 3 2) a))
462 (math-compose-vector (cdr (nth 1 a))
463 (math-vector-to-string sep nil)
465 (cons 'horiz (mapcar (function
467 (if (eq (car-safe x) 'calcFunc-bstring)
470 x (or bprec cprec prec))
472 (math-compose-expr x (or cprec prec)))))
474 ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
475 (not (eq calc-language 'unform))
476 (memq (length a) '(2 3))
477 (math-vectorp (nth 1 a))
479 (integerp (nth 2 a))))
482 (prec (or (nth 2 a) prec))
485 (let ((b nil) (cc nil) a d)
486 (if (and (memq (car-safe x) '(calcFunc-cbase
489 (memq (length x) '(1 2)))
492 (if (and (eq (car-safe x) 'calcFunc-crule)
493 (memq (length x) '(1 2))
495 (and (math-vectorp (nth 1 x))
496 (= (length (nth 1 x)) 2)
497 (math-vector-is-string
499 (and (natnump (nth 1 x))
500 (<= (nth 1 x) 255))))
503 (if (math-vectorp (nth 1 x))
504 (aref (math-vector-to-string
507 (or (and (memq (car-safe x) '(calcFunc-cvspace
510 (memq (length x) '(2 3))
513 (setq cc (math-compose-expr x prec))))
514 (setq a (if cc (math-comp-ascent cc) 0)
515 d (if cc (math-comp-descent cc) 0))
516 (if (eq b 'calcFunc-cbase)
517 (setq base (+ v a -1))
518 (if (eq b 'calcFunc-ctbase)
520 (if (eq b 'calcFunc-cbbase)
521 (setq base (+ v a d -1)))))
525 (setq c (delq nil c))
527 (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
528 (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
531 ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
532 (not (eq calc-language 'unform))
533 (memq (length a) '(3 4))
535 (integerp (nth 3 a))))
536 (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
537 (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
538 (math-compose-expr (nth 2 a) 0)))
539 ((and (eq (car a) 'calcFunc-cflat)
540 (not (eq calc-language 'unform))
541 (memq (length a) '(2 3))
543 (integerp (nth 2 a))))
544 (let ((calc-language (if (memq calc-language '(nil big))
545 'flat calc-language)))
546 (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
547 ((and (eq (car a) 'calcFunc-cspace)
548 (memq (length a) '(2 3))
551 (cons 'horiz (make-list (nth 1 a)
552 (if (and (math-vectorp (nth 2 a))
553 (math-vector-is-string (nth 2 a)))
554 (math-vector-to-string (nth 2 a) nil)
555 (math-compose-expr (nth 2 a) 0))))
556 (make-string (nth 1 a) ?\ )))
557 ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
558 (memq (length a) '(2 3))
562 (let* ((c (if (nth 2 a)
563 (if (and (math-vectorp (nth 2 a))
564 (math-vector-is-string (nth 2 a)))
565 (math-vector-to-string (nth 2 a) nil)
566 (math-compose-expr (nth 2 a) 0))
568 (ca (math-comp-ascent c))
569 (cd (math-comp-descent c)))
571 (cons (if (eq (car a) 'calcFunc-ctspace)
573 (if (eq (car a) 'calcFunc-cbspace)
574 (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
575 (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
576 (make-list (nth 1 a) c))))))
577 ((and (eq (car a) 'calcFunc-evalto)
578 (setq calc-any-evaltos t)
579 (setq spfn (get calc-language 'math-evalto))
580 (= math-compose-level (if math-comp-tagged 2 1))
584 (math-compose-expr (nth 1 a) 0)
586 (math-compose-expr (nth 2 a) 0)))
588 (let ((op (and (not (eq calc-language 'unform))
589 (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
590 (assoc "?" math-expr-opers)
591 (math-assq2 (car a) math-expr-opers)))))
593 (or (= (length a) 3) (eq (car a) 'calcFunc-if))
597 (> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
598 (and div (eq (car a) '*)))
599 (if (and (memq calc-language '(tex latex))
600 (not (math-tex-expr-is-flat a)))
601 (if (eq (car-safe a) '/)
602 (list 'horiz "{" (math-compose-expr a -1) "}")
603 (list 'horiz "\\left( "
604 (math-compose-expr a -1)
606 (if (eq calc-language 'eqn)
607 (if (or (eq (car-safe a) '/)
609 (list 'horiz "{" (math-compose-expr a -1) "}")
610 (if (math-tex-expr-is-flat a)
611 (list 'horiz "( " (math-compose-expr a -1) " )")
612 (list 'horiz "{left ( "
613 (math-compose-expr a -1)
615 (list 'horiz "(" (math-compose-expr a 0) ")"))))
616 ((and (memq calc-language '(tex latex))
617 (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
619 (list 'horiz "{" (math-compose-expr a -1) "}"))
620 ((eq (car a) 'calcFunc-if)
622 (math-compose-expr (nth 1 a) (nth 2 op))
624 (math-compose-expr (nth 2 a) 0)
626 (math-compose-expr (nth 3 a) (nth 3 op))))
628 (let* ((math-comp-tagged (and math-comp-tagged
631 (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
633 (setq math-compose-level
634 (1- math-compose-level))
637 (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
638 (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/))))
639 (and (equal (car op) "^")
640 (eq (math-comp-first-char lhs) ?-)
641 (setq lhs (list 'horiz "(" lhs ")")))
642 (and (memq calc-language '(tex latex))
643 (or (equal (car op) "^") (equal (car op) "_"))
644 (not (and (stringp rhs) (= (length rhs) 1)))
645 (setq rhs (list 'horiz "{" rhs "}")))
646 (or (and (eq (car a) '*)
647 (or (null calc-language)
648 (assoc "2x" math-expr-opers))
649 (let* ((prevt (math-prod-last-term (nth 1 a)))
650 (nextt (math-prod-first-term (nth 2 a)))
651 (prevc (or (math-comp-last-char lhs)
652 (and (memq (car-safe prevt)
656 (eq calc-language 'big)
658 (nextc (or (math-comp-first-char rhs)
659 (and (memq (car-safe nextt)
664 (eq calc-language 'big)
667 (or (and (>= nextc ?a) (<= nextc ?z))
668 (and (>= nextc ?A) (<= nextc ?Z))
669 (and (>= nextc ?α) (<= nextc ?ω))
670 (and (>= nextc ?Α) (<= nextc ?Ω))
671 (and (>= nextc ?0) (<= nextc ?9))
672 (memq nextc '(?. ?_ ?#
677 (math-comp-first-string
679 (not (and (eq (car-safe prevt) 'var)
684 (list 'break math-compose-level)
690 (list 'break math-compose-level)
691 (if (or (equal (car op) "^")
693 (equal (car op) "**")
694 (and (equal (car op) "*")
695 (math-comp-last-char lhs)
696 (math-comp-first-char rhs))
697 (and (equal (car op) "/")
698 (math-num-integerp (nth 1 a))
699 (math-integerp (nth 2 a))))
701 (if (and (eq calc-language 'big)
702 (equal (car op) "=>"))
704 (concat " " (car op) " ")))
706 ((and op (= (length a) 2) (= (nth 3 op) -1))
708 ((or (> prec (or (nth 4 op) (nth 2 op)))
709 (and (not (eq (assoc (car op) math-expr-opers) op))
710 (> prec 0))) ; don't write x% + y
711 (if (and (memq calc-language '(tex latex))
712 (not (math-tex-expr-is-flat a)))
713 (list 'horiz "\\left( "
714 (math-compose-expr a -1)
716 (if (eq calc-language 'eqn)
717 (if (= (/ prec 100) 9)
718 (list 'horiz "{" (math-compose-expr a -1) "}")
719 (if (math-tex-expr-is-flat a)
720 (list 'horiz "{( " (math-compose-expr a -1) " )}")
721 (list 'horiz "{left ( "
722 (math-compose-expr a -1)
724 (list 'horiz "(" (math-compose-expr a 0) ")"))))
726 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
729 (if (or (> (length (car op)) 1)
730 (not (math-comp-is-flat lhs)))
731 (concat " " (car op))
733 ((and op (= (length a) 2) (= (nth 2 op) -1))
736 (let ((lr (and (memq calc-language '(tex latex))
737 (not (math-tex-expr-is-flat (nth 1 a))))))
740 (if (string-match "\\`u\\([^a-zA-Zα-ωΑ-Ω]\\)\\'" (car op))
741 (substring (car op) 1)
743 (if (or lr (> (length (car op)) 2)) " " "")
744 (math-compose-expr (nth 1 a) -1)
745 (if (or lr (> (length (car op)) 2)) " " "")
747 (car (nth 1 (memq op math-expr-opers))))))
748 ((> prec (or (nth 4 op) (nth 3 op)))
749 (if (and (memq calc-language '(tex latex))
750 (not (math-tex-expr-is-flat a)))
751 (list 'horiz "\\left( "
752 (math-compose-expr a -1)
754 (if (eq calc-language 'eqn)
755 (if (= (/ prec 100) 9)
756 (list 'horiz "{" (math-compose-expr a -1) "}")
757 (if (math-tex-expr-is-flat a)
758 (list 'horiz "{( " (math-compose-expr a -1) " )}")
759 (list 'horiz "{left ( "
760 (math-compose-expr a -1)
762 (list 'horiz "(" (math-compose-expr a 0) ")"))))
764 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
766 (let ((ops (if (string-match "\\`u\\([^a-zA-Zα-ωΑ-Ω]\\)\\'"
768 (substring (car op) 1)
770 (if (or (> (length ops) 1)
771 (not (math-comp-is-flat rhs)))
775 ((and (eq calc-language 'big)
776 (setq op (get (car a) 'math-compose-big))
777 (funcall op a prec)))
778 ((and (setq op (assq calc-language
779 '( ( nil . math-compose-normal )
780 ( flat . math-compose-normal )
781 ( big . math-compose-normal )
782 ( c . math-compose-c )
783 ( pascal . math-compose-pascal )
784 ( fortran . math-compose-fortran )
785 ( tex . math-compose-tex )
786 ( latex . math-compose-latex )
787 ( eqn . math-compose-eqn )
788 ( yacas . math-compose-yacas )
789 ( maxima . math-compose-maxima )
790 ( giac . math-compose-giac )
791 ( math . math-compose-math )
792 ( maple . math-compose-maple ))))
793 (setq op (get (car a) (cdr op)))
794 (funcall op a prec)))
796 (let* ((func (car a))
797 (func2 (assq func '(( mod . calcFunc-makemod )
798 ( sdev . calcFunc-sdev )
805 ( neg . calcFunc-neg )
806 ( | . calcFunc-vconcat ))))
809 (setq func (cdr func2)))
810 (if (setq func2 (rassq func math-expr-function-mapping))
811 (setq func (car func2)))
812 (setq func (math-remove-dashes
814 "\\`calcFunc-\\([a-zA-Zα-ωΑ-Ω0-9']+\\)\\'"
816 (math-match-substring (symbol-name func) 1)
817 (symbol-name func))))
818 (if (memq calc-language calc-lang-allow-percentsigns)
819 (setq func (math-to-percentsigns func)))
820 (if (memq calc-language calc-lang-allow-underscores)
821 (setq func (math-to-underscores func)))
822 (if (setq spfn (get calc-language 'math-func-formatter))
823 (funcall spfn func a)
825 (list 'horiz func calc-function-open
826 (math-compose-vector (cdr a) ", " 0)
827 calc-function-close))))))))))
830 (defun math-prod-first-term (x)
831 (while (eq (car-safe x) '*)
835 (defun math-prod-last-term (x)
836 (while (eq (car-safe x) '*)
840 (defun math-compose-vector (a sep prec)
843 (cons (list 'set math-compose-level)
844 (let ((c (list (math-compose-expr (car a) prec))))
845 (while (setq a (cdr a))
846 (setq c (cons (if (eq (car-safe (car a))
848 (let ((math-compose-level
849 (1- math-compose-level)))
850 (math-compose-expr (car a) -123))
851 (math-compose-expr (car a) prec))
852 (cons (list 'break math-compose-level)
857 (defun math-vector-no-parens (a)
859 (not (eq (car-safe (nth 1 a)) '*))))
861 (defun math-compose-matrix (a col cols base)
864 (while (<= (setq col (1+ col)) cols)
865 (setq res (cons (cons math-comp-just
872 math-comp-vector-prec)
876 math-comp-comma-spc " ")))))
881 (defun math-compose-rows (a count first)
885 (math-compose-rows (cdr a) -1 nil)
887 (let ((mdots (get calc-language 'math-dots)))
892 (math-compose-rows (cdr a) -1 nil)))
894 (if first (concat math-comp-left-bracket " ") " ")
895 (math-compose-expr (car a) math-comp-vector-prec)
897 (math-compose-rows (cdr a) (1- count) nil)))
899 (if first (concat math-comp-left-bracket " ") " ")
900 (math-compose-expr (car a) math-comp-vector-prec)
901 (concat " " math-comp-right-bracket)))))
903 (defun math-vector-is-string (a)
904 (while (and (setq a (cdr a))
905 (or (and (natnump (car a))
907 (and (eq (car-safe (car a)) 'cplx)
908 (natnump (nth 1 (car a)))
909 (eq (nth 2 (car a)) 0)
910 (<= (nth 1 (car a)) 255)))))
913 (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
924 (defun math-vector-to-string (a &optional quoted)
925 (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
927 (if (string-match "[\000-\037\177\\\"]" a)
929 (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
930 (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
931 (fmt (if quoted "\\^%c" "^%c"))
933 (while (setq p (string-match pat a p))
934 (if (setq new (assq (aref a p) codes))
935 (setq a (concat (substring a 0 p)
937 (substring a (1+ p)))
938 p (+ p (length (cdr new))))
939 (setq a (concat (substring a 0 p)
940 (format fmt (+ (aref a p) 64))
941 (substring a (1+ p)))
948 (defun math-to-underscores (x)
949 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
951 (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
954 (defun math-to-percentsigns (x)
955 (if (string-match "\\`\\(.*\\)o'o\\(.*\\)\\'" x)
957 (concat (math-match-substring x 1) "%" (math-match-substring x 2)))
960 (defun math-tex-expr-is-flat (a)
961 (or (Math-integerp a)
962 (memq (car a) '(float var))
963 (and (memq (car a) '(+ - * neg))
965 (while (and (setq a (cdr a))
966 (math-tex-expr-is-flat (car a))))
968 (and (memq (car a) '(^ calcFunc-subscr))
969 (math-tex-expr-is-flat (nth 1 a)))))
971 (put 'calcFunc-log 'math-compose-big 'math-compose-log)
972 (defun math-compose-log (a prec)
973 (and (= (length a) 3)
976 (let ((calc-language 'flat))
977 (math-compose-expr (nth 2 a) 1000)))
979 (math-compose-expr (nth 1 a) 1000)
982 (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
983 (defun math-compose-log10 (a prec)
984 (and (= (length a) 2)
986 (list 'subscr "log" "10")
988 (math-compose-expr (nth 1 a) 1000)
991 (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
992 (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
993 (defun math-compose-deriv (a prec)
994 (when (= (length a) 3)
995 (math-compose-expr (list '/
996 (list 'calcFunc-choriz
998 '(calcFunc-string (vec ?d))
1000 (list 'calcFunc-choriz
1002 '(calcFunc-string (vec ?d))
1006 (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
1007 (defun math-compose-sqrt (a prec)
1008 (when (= (length a) 2)
1009 (let* ((c (math-compose-expr (nth 1 a) 0))
1010 (a (math-comp-ascent c))
1011 (d (math-comp-descent c))
1013 (w (math-comp-width c)))
1016 (concat (if (= h 1) " " " ")
1017 (make-string (+ w 2) ?\_))
1021 (append (list 'vleft (1- a))
1022 (make-list (1- h) " |")
1027 (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
1028 (defun math-compose-choose (a prec)
1029 (let ((a1 (math-compose-expr (nth 1 a) 0))
1030 (a2 (math-compose-expr (nth 2 a) 0)))
1034 (math-comp-height a1)
1038 (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
1039 (defun math-compose-integ (a prec)
1040 (and (memq (length a) '(3 5))
1041 (eq (car-safe (nth 2 a)) 'var)
1042 (let* ((parens (and (>= prec 196) (/= prec 1000)))
1043 (var (math-compose-expr (nth 2 a) 0))
1044 (over (and (eq (car-safe (nth 2 a)) 'var)
1045 (or (and (eq (car-safe (nth 1 a)) '/)
1046 (math-numberp (nth 1 (nth 1 a))))
1047 (and (eq (car-safe (nth 1 a)) '^)
1048 (math-looks-negp (nth 2 (nth 1 a)))))))
1049 (expr (math-compose-expr (if over
1051 (math-build-var-name
1054 (nth 1 (nth 2 a)))))
1056 (calc-language 'flat)
1057 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1058 (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
1061 (append (list 'vcent (if high 3 2))
1062 (and high (list (list 'horiz " " high)))
1068 (and low (list (list 'horiz low " "))))
1072 (list 'horiz " d" var))
1073 (if parens ")" "")))))
1075 (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
1076 (defun math-compose-sum (a prec)
1077 (and (memq (length a) '(3 5 6))
1078 (let* ((expr (math-compose-expr (nth 1 a) 185))
1079 (calc-language 'flat)
1080 (var (math-compose-expr (nth 2 a) 0))
1081 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1082 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1084 (if (memq prec '(180 201)) "(" "")
1085 (append (list 'vcent (if high 3 2))
1086 (and high (list high))
1093 (list (list 'horiz var " = " low))
1095 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1098 (if (memq prec '(180 201)) ")" "")))))
1100 (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
1101 (defun math-compose-prod (a prec)
1102 (and (memq (length a) '(3 5 6))
1103 (let* ((expr (math-compose-expr (nth 1 a) 198))
1104 (calc-language 'flat)
1105 (var (math-compose-expr (nth 2 a) 0))
1106 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
1107 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
1109 (if (memq prec '(196 201)) "(" "")
1110 (append (list 'vcent (if high 3 2))
1111 (and high (list high))
1117 (list (list 'horiz var " = " low))
1119 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
1122 (if (memq prec '(196 201)) ")" "")))))
1124 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1125 ;; to math-stack-value-offset in calc.el, but are used by
1126 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1128 (defvar math-svo-wid)
1129 (defvar math-svo-off)
1131 (defun math-stack-value-offset-fancy ()
1132 (let ((cwid (+ (math-comp-width math-svo-c))))
1133 (cond ((eq calc-display-just 'right)
1134 (if calc-display-origin
1135 (setq math-svo-wid (max calc-display-origin 5))
1136 (if (integerp calc-line-breaking)
1137 (setq math-svo-wid calc-line-breaking)))
1138 (setq math-svo-off (- math-svo-wid cwid
1139 (max (- (length calc-right-label)
1140 (if (and (integerp calc-line-breaking)
1141 calc-display-origin)
1142 (max (- calc-line-breaking
1143 calc-display-origin)
1148 (if calc-display-origin
1150 (setq math-svo-off (- calc-display-origin (/ cwid 2)))
1151 (if (integerp calc-line-breaking)
1152 (setq math-svo-off (min math-svo-off (- calc-line-breaking cwid
1153 (length calc-right-label)))))
1154 (if (>= math-svo-off 0)
1155 (setq math-svo-wid (max math-svo-wid (+ math-svo-off cwid)))))
1156 (if (integerp calc-line-breaking)
1157 (setq math-svo-wid calc-line-breaking))
1158 (setq math-svo-off (/ (- math-svo-wid cwid) 2)))))
1159 (and (integerp calc-line-breaking)
1160 (or (< math-svo-off 0)
1161 (and calc-display-origin
1162 (> calc-line-breaking calc-display-origin)))
1163 (setq math-svo-wid calc-line-breaking))))
1166 ;;; Convert a composition to string form, with embedded \n's if necessary.
1168 (defun math-composition-to-string (c &optional width)
1169 (or width (setq width (calc-window-width)))
1170 (if calc-display-raw
1171 (math-comp-to-string-raw c 0)
1172 (if (math-comp-is-flat c)
1173 (math-comp-to-string-flat c width)
1174 (math-vert-comp-to-string
1175 (math-comp-simplify c width)))))
1177 (defvar math-comp-buf-string (make-vector 10 ""))
1178 (defvar math-comp-buf-margin (make-vector 10 0))
1179 (defvar math-comp-buf-level (make-vector 10 0))
1180 (defun math-comp-is-flat (c) ; check if c's height is 1.
1181 (cond ((not (consp c)) t)
1182 ((memq (car c) '(set break)) t)
1183 ((eq (car c) 'horiz)
1184 (while (and (setq c (cdr c))
1185 (math-comp-is-flat (car c))))
1187 ((memq (car c) '(vleft vcent vright))
1188 (and (= (length c) 3)
1190 (math-comp-is-flat (nth 2 c))))
1192 (math-comp-is-flat (nth 2 c)))
1196 ;;; Convert a one-line composition to a string. Break into multiple
1197 ;;; lines if necessary, choosing break points according to the structure
1200 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1201 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1202 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1203 ;; which is called by math-comp-to-string-flat.
1204 ;; math-comp-highlight and math-comp-buf are also local to
1205 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1206 ;; by math-comp-add-string.
1207 (defvar math-comp-full-width)
1208 (defvar math-comp-highlight)
1209 (defvar math-comp-word)
1210 (defvar math-comp-level)
1211 (defvar math-comp-margin)
1212 (defvar math-comp-buf)
1213 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1214 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1215 ;; which are called by math-comp-to-string-flat.
1216 (defvar math-comp-pos)
1218 (defun math-comp-to-string-flat (c math-comp-full-width)
1219 (if math-comp-sel-hpos
1220 (let ((math-comp-pos 0))
1221 (math-comp-sel-flat-term c))
1222 (let ((math-comp-buf "")
1225 (math-comp-margin 0)
1226 (math-comp-highlight (and math-comp-selected calc-show-selections))
1227 (math-comp-level -1))
1228 (math-comp-to-string-flat-term '(set -1 0))
1229 (math-comp-to-string-flat-term c)
1230 (math-comp-to-string-flat-term '(break -1))
1231 (let ((str (aref math-comp-buf-string 0))
1233 (and (> (length str) 0) (= (aref str 0) ? )
1234 (> (length math-comp-buf) 0)
1235 (let ((k (length math-comp-buf)))
1236 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1237 (aset math-comp-buf k ? )
1238 (if (and (< (1+ k) (length math-comp-buf))
1239 (= (aref math-comp-buf (1+ k)) ? ))
1241 (aset math-comp-buf (1+ k) ?\n)
1243 (setq prefix "\n"))))
1244 (concat math-comp-buf prefix str)))))
1246 (defun math-comp-to-string-flat-term (c)
1247 (cond ((not (consp c))
1248 (if math-comp-highlight
1249 (setq c (math-comp-highlight-string c)))
1250 (setq math-comp-word (if (= (length math-comp-word) 0) c
1251 (concat math-comp-word c))
1252 math-comp-pos (+ math-comp-pos (length c))))
1254 ((eq (car c) 'horiz)
1255 (while (setq c (cdr c))
1256 (math-comp-to-string-flat-term (car c))))
1261 (setq math-comp-level (1+ math-comp-level))
1262 (if (>= math-comp-level (length math-comp-buf-string))
1263 (setq math-comp-buf-string (vconcat math-comp-buf-string
1264 math-comp-buf-string)
1265 math-comp-buf-margin (vconcat math-comp-buf-margin
1266 math-comp-buf-margin)
1267 math-comp-buf-level (vconcat math-comp-buf-level
1268 math-comp-buf-level)))
1269 (aset math-comp-buf-string math-comp-level "")
1270 (aset math-comp-buf-margin math-comp-level (+ math-comp-pos
1272 (aset math-comp-buf-level math-comp-level (nth 1 c)))))
1274 ((eq (car c) 'break)
1275 (if (not calc-line-breaking)
1276 (setq math-comp-buf (concat math-comp-buf math-comp-word)
1279 (if (and (> math-comp-pos math-comp-full-width)
1282 (setq str (aref math-comp-buf-string i))
1283 (and (= (length str) 0) (< i math-comp-level)))
1285 (or (> (length str) 0) (> (length math-comp-buf) 0))))
1286 (let ((prefix "") mrg wid)
1287 (setq mrg (aref math-comp-buf-margin i))
1288 (if (> mrg 12) ; indenting too far, go back to far left
1289 (setq mrg (if calc-line-numbering 5 1)))
1290 (setq wid (+ (length str) math-comp-margin))
1291 (and (> (length str) 0) (= (aref str 0) ? )
1292 (> (length math-comp-buf) 0)
1293 (let ((k (length math-comp-buf)))
1294 (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
1295 (aset math-comp-buf k ? )
1296 (if (and (< (1+ k) (length math-comp-buf))
1297 (= (aref math-comp-buf (1+ k)) ? ))
1299 (aset math-comp-buf (1+ k) ?\n)
1301 (setq prefix "\n"))))
1302 (setq math-comp-buf (concat math-comp-buf prefix str "\n"
1303 (make-string mrg ? ))
1304 math-comp-pos (+ math-comp-pos (- mrg wid))
1305 math-comp-margin mrg)
1306 (aset math-comp-buf-string i "")
1307 (while (<= (setq i (1+ i)) math-comp-level)
1308 (if (> (aref math-comp-buf-margin i) wid)
1309 (aset math-comp-buf-margin i
1310 (+ (aref math-comp-buf-margin i)
1312 (if (and (= (nth 1 c) (aref math-comp-buf-level math-comp-level))
1313 (< math-comp-pos (+ (aref math-comp-buf-margin math-comp-level) 2)))
1314 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1315 (let ((str (aref math-comp-buf-string math-comp-level)))
1316 (setq str (if (= (length str) 0)
1318 (concat str math-comp-word))
1320 (while (< (nth 1 c) (aref math-comp-buf-level math-comp-level))
1321 (setq math-comp-level (1- math-comp-level))
1322 (or (= (length (aref math-comp-buf-string math-comp-level)) 0)
1323 (setq str (concat (aref math-comp-buf-string math-comp-level)
1325 (aset math-comp-buf-string math-comp-level str)))))
1328 (cond ((eq (nth 1 c) math-comp-selected)
1329 (let ((math-comp-highlight (not calc-show-selections)))
1330 (math-comp-to-string-flat-term (nth 2 c))))
1332 (let ((math-comp-highlight nil))
1333 (math-comp-to-string-flat-term (nth 2 c))))
1334 (t (math-comp-to-string-flat-term (nth 2 c)))))
1336 (t (math-comp-to-string-flat-term (nth 2 c)))))
1338 (defun math-comp-highlight-string (s)
1339 (setq s (copy-sequence s))
1340 (if calc-highlight-selections-with-faces
1341 (if (not calc-show-selections)
1342 (propertize s 'face 'calc-selected-face)
1343 (propertize s 'face 'calc-nonselected-face))
1344 (let ((i (length s)))
1345 (while (>= (setq i (1- i)) 0)
1346 (or (memq (aref s i) '(32 ?\n))
1347 (aset s i (if calc-show-selections ?\. ?\#)))))
1350 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1351 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1352 ;; math-comp-add-string-sel, which are called (indirectly) by
1353 ;; calc-find-selected-part.
1354 (defvar math-comp-sel-tag)
1356 (defun math-comp-sel-flat-term (c)
1357 (cond ((not (consp c))
1358 (setq math-comp-pos (+ math-comp-pos (length c))))
1359 ((memq (car c) '(set break)))
1360 ((eq (car c) 'horiz)
1361 (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
1362 (math-comp-sel-flat-term (car c))))
1364 (if (<= math-comp-pos math-comp-sel-cpos)
1366 (math-comp-sel-flat-term (nth 2 c))
1367 (if (> math-comp-pos math-comp-sel-cpos)
1368 (setq math-comp-sel-tag c
1369 math-comp-sel-cpos 1000000)))
1370 (math-comp-sel-flat-term (nth 2 c))))
1371 (t (math-comp-sel-flat-term (nth 2 c)))))
1374 ;;; Simplify a composition to a canonical form consisting of
1375 ;;; (vleft n "string" "string" "string" ...)
1376 ;;; where 0 <= n < number-of-strings.
1378 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1379 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1380 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1381 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1382 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1383 ;; math-comp-simplify.
1384 (defvar math-comp-base)
1385 (defvar math-comp-hgt)
1386 (defvar math-comp-tag)
1387 (defvar math-comp-hpos)
1388 (defvar math-comp-vpos)
1390 (defun math-comp-simplify (c full-width)
1391 (let ((math-comp-buf (list ""))
1396 (math-comp-highlight (and math-comp-selected calc-show-selections))
1397 (math-comp-tag nil))
1398 (math-comp-simplify-term c)
1399 (cons 'vleft (cons math-comp-base math-comp-buf))))
1401 (defun math-comp-add-string (s h v)
1402 (and (> (length s) 0)
1403 (let ((vv (+ v math-comp-base)))
1404 (if math-comp-sel-hpos
1405 (math-comp-add-string-sel h vv (length s) 1)
1407 (setq math-comp-buf (nconc (make-list (- vv) "") math-comp-buf)
1408 math-comp-base (- v)
1409 math-comp-hgt (- math-comp-hgt vv)
1411 (if (>= vv math-comp-hgt)
1412 (setq math-comp-buf (nconc math-comp-buf
1413 (make-list (1+ (- vv math-comp-hgt)) ""))
1414 math-comp-hgt (1+ vv))))
1415 (let ((str (nthcdr vv math-comp-buf)))
1416 (setcar str (concat (car str)
1417 (make-string (- h (length (car str))) 32)
1418 (if math-comp-highlight
1419 (math-comp-highlight-string s)
1422 (defun math-comp-add-string-sel (x y w h)
1423 (if (and (<= y math-comp-sel-vpos)
1424 (> (+ y h) math-comp-sel-vpos)
1425 (<= x math-comp-sel-hpos)
1426 (> (+ x w) math-comp-sel-hpos))
1427 (setq math-comp-sel-tag math-comp-tag
1428 math-comp-sel-vpos 10000)))
1430 (defun math-comp-simplify-term (c)
1432 (math-comp-add-string c math-comp-hpos math-comp-vpos)
1433 (setq math-comp-hpos (+ math-comp-hpos (length c))))
1434 ((memq (car c) '(set break))
1436 ((eq (car c) 'horiz)
1437 (while (setq c (cdr c))
1438 (math-comp-simplify-term (car c))))
1439 ((memq (car c) '(vleft vcent vright))
1440 (let* ((math-comp-vpos (+ (- math-comp-vpos (nth 1 c))
1441 (1- (math-comp-ascent (nth 2 c)))))
1442 (widths (mapcar 'math-comp-width (cdr (cdr c))))
1443 (maxwid (apply 'max widths))
1444 (bias (cond ((eq (car c) 'vleft) 0)
1445 ((eq (car c) 'vcent) 1)
1448 (while (setq c (cdr c))
1449 (if (eq (car-safe (car c)) 'rule)
1450 (math-comp-add-string (make-string maxwid (nth 1 (car c)))
1451 math-comp-hpos math-comp-vpos)
1452 (let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid
1455 (math-comp-simplify-term (car c))))
1457 (setq math-comp-vpos (+ math-comp-vpos
1458 (+ (math-comp-descent (car c))
1459 (math-comp-ascent (nth 1 c))))
1460 widths (cdr widths))))
1461 (setq math-comp-hpos (+ math-comp-hpos maxwid))))
1462 ((eq (car c) 'supscr)
1463 (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
1464 (desc (math-comp-descent (nth 2 c)))
1467 (math-comp-simplify-term (nth 1 c))))
1468 (math-comp-vpos (- math-comp-vpos (+ asc desc))))
1469 (math-comp-simplify-term (nth 2 c))
1470 (if math-comp-sel-hpos
1471 (math-comp-add-string-sel oldh
1474 (math-comp-ascent (nth 2 c)))
1475 (- math-comp-hpos oldh)
1476 (math-comp-height c)))))
1477 ((eq (car c) 'subscr)
1478 (let* ((asc (math-comp-ascent (nth 2 c)))
1479 (desc (math-comp-descent (nth 1 c)))
1480 (oldv math-comp-vpos)
1483 (math-comp-simplify-term (nth 1 c))))
1484 (math-comp-vpos (+ math-comp-vpos (+ asc desc))))
1485 (math-comp-simplify-term (nth 2 c))
1486 (if math-comp-sel-hpos
1487 (math-comp-add-string-sel oldh oldv
1488 (- math-comp-hpos oldh)
1489 (math-comp-height c)))))
1491 (cond ((eq (nth 1 c) math-comp-selected)
1492 (let ((math-comp-highlight (not calc-show-selections)))
1493 (math-comp-simplify-term (nth 2 c))))
1495 (let ((math-comp-highlight nil))
1496 (math-comp-simplify-term (nth 2 c))))
1497 (t (let ((math-comp-tag c))
1498 (math-comp-simplify-term (nth 2 c))))))))
1501 ;;; Measuring a composition.
1503 (defun math-comp-first-char (c)
1505 (and (> (length c) 0)
1507 ((memq (car c) '(horiz subscr supscr))
1508 (while (and (setq c (cdr c))
1509 (math-comp-is-null (car c))))
1510 (and c (math-comp-first-char (car c))))
1512 (math-comp-first-char (nth 2 c)))))
1514 (defun math-comp-first-string (c)
1516 (and (> (length c) 0)
1518 ((eq (car c) 'horiz)
1519 (while (and (setq c (cdr c))
1520 (math-comp-is-null (car c))))
1521 (and c (math-comp-first-string (car c))))
1523 (math-comp-first-string (nth 2 c)))))
1525 (defun math-comp-last-char (c)
1527 (and (> (length c) 0)
1528 (elt c (1- (length c)))))
1529 ((eq (car c) 'horiz)
1530 (let ((c (reverse (cdr c))))
1531 (while (and c (math-comp-is-null (car c)))
1533 (and c (math-comp-last-char (car c)))))
1535 (math-comp-last-char (nth 2 c)))))
1537 (defun math-comp-is-null (c)
1538 (cond ((stringp c) (= (length c) 0))
1539 ((memq (car c) '(horiz subscr supscr))
1540 (while (and (setq c (cdr c))
1541 (math-comp-is-null (car c))))
1544 (math-comp-is-null (nth 2 c)))
1545 ((memq (car c) '(set break)) t)))
1547 (defun math-comp-width (c)
1548 (cond ((not (consp c)) (length c))
1549 ((memq (car c) '(horiz subscr supscr))
1551 (while (setq c (cdr c))
1552 (setq accum (+ accum (math-comp-width (car c)))))
1554 ((memq (car c) '(vcent vleft vright))
1557 (while (setq c (cdr c))
1558 (setq accum (max accum (math-comp-width (car c)))))
1561 (math-comp-width (nth 2 c)))
1564 (defun math-comp-height (c)
1567 (+ (math-comp-ascent c) (math-comp-descent c))))
1569 (defun math-comp-ascent (c)
1570 (cond ((not (consp c)) 1)
1571 ((eq (car c) 'horiz)
1573 (while (setq c (cdr c))
1574 (setq accum (max accum (math-comp-ascent (car c)))))
1576 ((memq (car c) '(vcent vleft vright))
1577 (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
1578 ((eq (car c) 'supscr)
1579 (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
1580 ((eq (car c) 'subscr)
1581 (math-comp-ascent (nth 1 c)))
1583 (math-comp-ascent (nth 2 c)))
1586 (defun math-comp-descent (c)
1587 (cond ((not (consp c)) 0)
1588 ((eq (car c) 'horiz)
1590 (while (setq c (cdr c))
1591 (setq accum (max accum (math-comp-descent (car c)))))
1593 ((memq (car c) '(vcent vleft vright))
1594 (let ((accum (- (nth 1 c))))
1596 (while (setq c (cdr c))
1597 (setq accum (+ accum (math-comp-height (car c)))))
1598 (max (1- accum) 0)))
1599 ((eq (car c) 'supscr)
1600 (math-comp-descent (nth 1 c)))
1601 ((eq (car c) 'subscr)
1602 (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
1604 (math-comp-descent (nth 2 c)))
1607 (defun calcFunc-cwidth (a &optional prec)
1608 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1609 (math-comp-width (math-compose-expr a (or prec 0))))
1611 (defun calcFunc-cheight (a &optional prec)
1612 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1613 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1614 (memq (length a) '(2 3))
1617 (math-comp-height (math-compose-expr a (or prec 0)))))
1619 (defun calcFunc-cascent (a &optional prec)
1620 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1621 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
1622 (memq (length a) '(2 3))
1625 (math-comp-ascent (math-compose-expr a (or prec 0)))))
1627 (defun calcFunc-cdescent (a &optional prec)
1628 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
1629 (math-comp-descent (math-compose-expr a (or prec 0))))
1632 ;;; Convert a simplified composition into string form.
1634 (defun math-vert-comp-to-string (c)
1637 (math-vert-comp-to-string-step (cdr (cdr c)))))
1639 (defun math-vert-comp-to-string-step (c)
1641 (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
1645 ;;; Convert a composition to a string in "raw" form (for debugging).
1647 (defun math-comp-to-string-raw (c indent)
1648 (cond ((or (not (consp c)) (eq (car c) 'set))
1649 (prin1-to-string c))
1651 (concat "(" (symbol-name (car c)) ")"))
1653 (let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
1655 (symbol-name (car c))
1657 (math-comp-to-string-raw (nth 1 c) next-indent)
1658 (math-comp-to-string-raw-step (cdr (cdr c))
1662 (defun math-comp-to-string-raw-step (cl indent)
1665 (make-string indent 32)
1666 (math-comp-to-string-raw (car cl) indent)
1667 (math-comp-to-string-raw-step (cdr cl) indent))
1672 ;;; calccomp.el ends here