1 ;;; calccomp.el --- composition functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 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, or (at your option)
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; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 ;; This file is autoloaded from calc-ext.el.
35 (defconst math-eqn-special-funcs
37 calcFunc-ln calcFunc-exp
38 calcFunc-sin calcFunc-cos calcFunc-tan
39 calcFunc-sec calcFunc-csc calcFunc-cot
40 calcFunc-sinh calcFunc-cosh calcFunc-tanh
41 calcFunc-sech calcFunc-csch calcFunc-coth
42 calcFunc-arcsin calcFunc-arccos calcFunc-arctan
43 calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
))
45 ;;; A "composition" has one of the following forms:
47 ;;; "string" A literal string
49 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
51 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
52 ;;; (break LEVEL) A potential line-break point
54 ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
55 ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
56 ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
57 ;;; N specifies baseline of the stack, 0=top line.
59 ;;; (supscr C1 C2) Composition C1 with superscript C2
60 ;;; (subscr C1 C2) Composition C1 with subscript C2
61 ;;; (rule X) Horizontal line of X, full width of enclosing comp
63 ;;; (tag X C) Composition C corresponds to sub-expression X
65 ;; math-comp-just and math-comp-comma-spc are local to
66 ;; math-compose-expr, but are used by math-compose-matrix, which is
67 ;; called by math-compose-expr
68 (defvar math-comp-just
)
69 (defvar math-comp-comma-spc
)
71 ;; math-comp-vector-prec is local to math-compose-expr, but is used by
72 ;; math-compose-matrix and math-compose-rows, which are called by
74 (defvar math-comp-vector-prec
)
76 ;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
77 ;; local to math-compose-expr, but are used by math-compose-rows, which is
78 ;; called by math-compose-expr.
79 (defvar math-comp-left-bracket
)
80 (defvar math-comp-right-bracket
)
81 (defvar math-comp-comma
)
84 (defun math-compose-expr (a prec
)
85 (let ((math-compose-level (1+ math-compose-level
))
88 ((or (and (eq a math-comp-selected
) a
)
90 (not (eq math-comp-tagged a
))))
91 (let ((math-comp-selected nil
))
92 (and math-comp-tagged
(setq math-comp-tagged a
))
93 (list 'tag a
(math-compose-expr a prec
))))
94 ((and (not (consp a
)) (not (integerp a
)))
95 (concat "'" (prin1-to-string a
)))
96 ((setq spfn
(assq (car-safe a
) math-expr-special-function-mapping
))
97 (setq spfn
(cdr spfn
))
98 (funcall (car spfn
) a spfn
))
100 (if (or (eq (car-safe a
) 'frac
)
101 (and (nth 1 calc-frac-format
) (Math-integerp a
)))
102 (if (memq calc-language
'(tex latex eqn math maple c fortran pascal
))
103 (let ((aa (math-adjust-fraction a
))
104 (calc-frac-format nil
))
105 (math-compose-expr (list '/
106 (if (memq calc-language
'(c fortran
))
107 (math-float (nth 1 aa
))
110 (if (and (eq calc-language
'big
)
111 (= (length (car calc-frac-format
)) 1))
112 (let* ((aa (math-adjust-fraction a
))
113 (calc-frac-format nil
)
114 (math-radix-explicit-format nil
)
116 (if (math-negp (nth 1 aa
))
120 (math-abs (nth 1 aa
)))
122 (math-format-number (nth 2 aa
))))))
123 (if (= calc-number-radix
10)
127 (int-to-string calc-number-radix
)))))
128 (math-format-number a
)))
129 (if (not (eq calc-language
'big
))
130 (math-format-number a prec
)
131 (if (memq (car-safe a
) '(cplx polar
))
132 (if (math-zerop (nth 2 a
))
133 (math-compose-expr (nth 1 a
) prec
)
135 (math-compose-expr (nth 1 a
) 0)
136 (if (eq (car a
) 'cplx
) ", " "; ")
137 (math-compose-expr (nth 2 a
) 0) ")"))
138 (if (or (= calc-number-radix
10)
140 (and calc-group-digits
141 (not (assoc calc-group-char
'((",") (" "))))))
142 (math-format-number a prec
)
143 (let ((s (math-format-number a prec
))
145 (while (string-match (if (> calc-number-radix
14)
146 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
147 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
149 (setq c
(nconc c
(list (substring s
0 (match-beginning 0))
151 (math-match-substring s
2)
152 (math-match-substring s
1))))
153 s
(substring s
(match-end 0))))
155 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s
)
157 (substring s
0 (match-beginning 0)) " "
159 (math-match-substring s
1)
160 (math-match-substring s
2))
161 (math-match-substring s
3))))
162 (if c
(cons 'horiz
(nconc c
(list s
))) s
)))))))
163 ((and (get (car a
) 'math-compose-forms
)
164 (not (eq calc-language
'unform
))
165 (let ((comps (get (car a
) 'math-compose-forms
))
167 (or (and (setq temp
(assq calc-language comps
))
168 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
169 (setq temp
(apply (cdr temp2
) (cdr a
)))
170 (math-compose-expr temp prec
))
171 (and (setq temp2
(assq nil
(cdr temp
)))
172 (funcall (cdr temp2
) a
))))
173 (and (setq temp
(assq nil comps
))
174 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
175 (setq temp
(apply (cdr temp2
) (cdr a
)))
176 (math-compose-expr temp prec
))
177 (and (setq temp2
(assq nil
(cdr temp
)))
178 (funcall (cdr temp2
) a
))))))))
180 (let* ((math-comp-left-bracket (if calc-vector-brackets
181 (substring calc-vector-brackets
0 1) ""))
182 (math-comp-right-bracket (if calc-vector-brackets
183 (substring calc-vector-brackets
1 2) ""))
184 (inner-brackets (memq 'R calc-matrix-brackets
))
185 (outer-brackets (memq 'O calc-matrix-brackets
))
186 (row-commas (memq 'C calc-matrix-brackets
))
187 (math-comp-comma-spc (or calc-vector-commas
" "))
188 (math-comp-comma (or calc-vector-commas
""))
189 (math-comp-vector-prec (if (or (and calc-vector-commas
190 (math-vector-no-parens a
))
191 (memq 'P calc-matrix-brackets
)) 0 1000))
192 (math-comp-just (cond ((eq calc-matrix-just
'right
) 'vright
)
193 ((eq calc-matrix-just
'center
) 'vcent
)
195 (break calc-break-vectors
))
196 (if (and (memq calc-language
'(nil big
))
197 (not calc-break-vectors
)
198 (math-matrixp a
) (not (math-matrixp (nth 1 a
)))
199 (or calc-full-vectors
200 (and (< (length a
) 7) (< (length (nth 1 a
)) 7))
201 (progn (setq break t
) nil
)))
203 (setq math-comp-vector-prec
(if (or (and calc-vector-commas
204 (math-vector-no-parens
206 (memq 'P calc-matrix-brackets
))
210 (concat math-comp-left-bracket math-comp-left-bracket
" ")
211 (math-compose-vector (cdr (nth 1 a
)) (concat math-comp-comma
" ")
212 math-comp-vector-prec
)
213 (concat " " math-comp-right-bracket math-comp-right-bracket
))
214 (let* ((rows (1- (length a
)))
215 (cols (1- (length (nth 1 a
))))
216 (base (/ (1- rows
) 2))
217 (calc-language 'flat
))
219 (list (append '(vleft)
221 (list (concat (and outer-brackets
222 (concat math-comp-left-bracket
225 (concat math-comp-left-bracket
228 (concat (and outer-brackets
232 math-comp-left-bracket
234 (math-compose-matrix (cdr a
) 1 cols base
)
235 (list (append '(vleft)
240 math-comp-right-bracket
243 (if (and outer-brackets
249 math-comp-right-bracket
))
253 math-comp-right-bracket
)))))))))
254 (if (and calc-display-strings
256 (math-vector-is-string a
))
257 (math-vector-to-string a t
)
258 (if (and break
(cdr a
)
259 (not (eq calc-language
'flat
)))
260 (let* ((full (or calc-full-vectors
(< (length a
) 7)))
261 (rows (if full
(1- (length a
)) 5))
262 (base (/ (1- rows
) 2))
263 (calc-break-vectors nil
))
265 (cons 'vleft
(cons base
268 (if full rows
3) t
)))))
269 (if (or calc-full-vectors
(< (length a
) 7))
270 (if (and (eq calc-language
'tex
)
272 (if (and (integerp calc-language-option
)
273 (or (= calc-language-option
0)
274 (> calc-language-option
1)
275 (< calc-language-option -
1)))
276 (append '(vleft 0 "\\matrix{")
277 (math-compose-tex-matrix (cdr a
))
279 (append '(horiz "\\matrix{ ")
280 (math-compose-tex-matrix (cdr a
))
282 (if (and (eq calc-language
'latex
)
284 (if (and (integerp calc-language-option
)
285 (or (= calc-language-option
0)
286 (> calc-language-option
1)
287 (< calc-language-option -
1)))
288 (append '(vleft 0 "\\begin{pmatrix}")
289 (math-compose-tex-matrix (cdr a
) t
)
291 (append '(horiz "\\begin{pmatrix} ")
292 (math-compose-tex-matrix (cdr a
) t
)
293 '(" \\end{pmatrix}")))
294 (if (and (eq calc-language
'eqn
)
296 (append '(horiz "matrix { ")
297 (math-compose-eqn-matrix
298 (cdr (math-transpose a
)))
300 (if (and (eq calc-language
'maple
)
304 math-comp-left-bracket
305 (math-compose-vector (cdr a
)
306 (concat math-comp-comma
" ")
307 math-comp-vector-prec
)
308 math-comp-right-bracket
311 math-comp-left-bracket
312 (math-compose-vector (cdr a
)
313 (concat math-comp-comma
" ")
314 math-comp-vector-prec
)
315 math-comp-right-bracket
)))))
317 math-comp-left-bracket
318 (math-compose-vector (list (nth 1 a
) (nth 2 a
) (nth 3 a
))
319 (concat math-comp-comma
" ")
320 math-comp-vector-prec
)
321 math-comp-comma
(if (memq calc-language
'(tex latex
))
324 (list 'break math-compose-level
)
325 (math-compose-expr (nth (1- (length a
)) a
)
326 (if (equal math-comp-comma
"") 1000 0))
327 math-comp-right-bracket
)))))))
328 ((eq (car a
) 'incomplete
)
330 (cond ((eq (nth 1 a
) 'vec
)
332 (math-compose-vector (cdr (cdr a
)) ", " 0)
334 ((eq (nth 1 a
) 'cplx
)
336 (math-compose-vector (cdr (cdr a
)) ", " 0)
338 ((eq (nth 1 a
) 'polar
)
340 (math-compose-vector (cdr (cdr a
)) "; " 0)
342 ((eq (nth 1 a
) 'intv
)
344 (if (memq (nth 2 a
) '(0 1)) "(" "[")
345 (math-compose-vector (cdr (cdr (cdr a
))) " .. " 0)
348 (cond ((eq (nth 1 a
) 'vec
) "[ ...")
349 ((eq (nth 1 a
) 'intv
)
350 (if (memq (nth 2 a
) '(0 1)) "( ..." "[ ..."))
353 (let ((v (rassq (nth 2 a
) math-expr-variable-mapping
)))
355 (symbol-name (car v
))
356 (if (and (memq calc-language
'(tex latex
))
358 (not (= calc-language-option
0))
359 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
360 (symbol-name (nth 1 a
))))
361 (if (eq calc-language
'latex
)
362 (format "\\text{%s}" (symbol-name (nth 1 a
)))
363 (format "\\hbox{%s}" (symbol-name (nth 1 a
))))
364 (if (and math-compose-hash-args
365 (let ((p calc-arg-values
))
367 (while (and p
(not (equal (car p
) a
)))
368 (setq p
(and (eq math-compose-hash-args t
) (cdr p
))
371 (if (eq math-compose-hash-args
1)
374 (if (memq calc-language
'(c fortran pascal maple
))
375 (math-to-underscores (symbol-name (nth 1 a
)))
376 (if (and (eq calc-language
'eqn
)
377 (string-match ".'\\'" (symbol-name (nth 2 a
))))
379 (list 'calcFunc-Prime
382 (intern (substring (symbol-name (nth 1 a
)) 0 -
1))
383 (intern (substring (symbol-name (nth 2 a
)) 0 -
1))))
385 (symbol-name (nth 1 a
)))))))))
388 (if (eq calc-language
'maple
) ""
389 (if (memq (nth 1 a
) '(0 1)) "(" "["))
390 (math-compose-expr (nth 2 a
) 0)
391 (if (memq calc-language
'(tex latex
)) " \\ldots "
392 (if (eq calc-language
'eqn
) " ... " " .. "))
393 (math-compose-expr (nth 3 a
) 0)
394 (if (eq calc-language
'maple
) ""
395 (if (memq (nth 1 a
) '(0 2)) ")" "]"))))
397 (if (eq (car calc-date-format
) 'X
)
399 (concat "<" (math-format-date a
) ">")))
400 ((and (eq (car a
) 'calcFunc-subscr
) (cdr (cdr a
))
401 (memq calc-language
'(c pascal fortran maple
)))
402 (let ((args (cdr (cdr a
))))
403 (while (and (memq calc-language
'(pascal fortran
))
404 (eq (car-safe (nth 1 a
)) 'calcFunc-subscr
))
405 (setq args
(append (cdr (cdr (nth 1 a
))) args
)
408 (math-compose-expr (nth 1 a
) 1000)
409 (if (eq calc-language
'fortran
) "(" "[")
410 (math-compose-vector args
", " 0)
411 (if (eq calc-language
'fortran
) ")" "]"))))
412 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
413 (eq calc-language
'big
))
414 (let* ((a1 (math-compose-expr (nth 1 a
) 1000))
415 (calc-language 'flat
)
416 (a2 (math-compose-expr (nth 2 a
) 0)))
417 (if (or (eq (car-safe a1
) 'subscr
)
418 (and (eq (car-safe a1
) 'tag
)
419 (eq (car-safe (nth 2 a1
)) 'subscr
)
420 (setq a1
(nth 2 a1
))))
427 (list 'subscr a1 a2
))))
428 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
429 (eq calc-language
'math
))
431 (math-compose-expr (nth 1 a
) 1000)
433 (math-compose-expr (nth 2 a
) 0)
435 ((and (eq (car a
) 'calcFunc-sqrt
)
436 (memq calc-language
'(tex latex
)))
439 (math-compose-expr (nth 1 a
) 0)
441 ((and nil
(eq (car a
) 'calcFunc-sqrt
)
442 (eq calc-language
'eqn
))
445 (math-compose-expr (nth 1 a
) -
1)
447 ((and (eq (car a
) '^
)
448 (eq calc-language
'big
))
450 (if (or (math-looks-negp (nth 1 a
))
451 (memq (car-safe (nth 1 a
)) '(^
/ frac calcFunc-sqrt
))
452 (and (eq (car-safe (nth 1 a
)) 'cplx
)
453 (math-negp (nth 1 (nth 1 a
)))
454 (eq (nth 2 (nth 1 a
)) 0)))
455 (list 'horiz
"(" (math-compose-expr (nth 1 a
) 0) ")")
456 (math-compose-expr (nth 1 a
) 201))
457 (let ((calc-language 'flat
)
458 (calc-number-radix 10))
459 (math-compose-expr (nth 2 a
) 0))))
460 ((and (eq (car a
) '/)
461 (eq calc-language
'big
))
462 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a
)) '(/ frac
))
464 (math-compose-expr (nth 1 a
) 0)))
465 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a
)) '(/ frac
))
467 (math-compose-expr (nth 2 a
) 0))))
469 (math-comp-height a1
)
471 ((and (memq (car a
) '(calcFunc-sum calcFunc-prod
))
472 (memq calc-language
'(tex latex
))
474 (list 'horiz
(if (eq (car a
) 'calcFunc-sum
) "\\sum" "\\prod")
475 "_{" (math-compose-expr (nth 2 a
) 0)
476 "=" (math-compose-expr (nth 3 a
) 0)
477 "}^{" (math-compose-expr (nth 4 a
) 0)
478 "}{" (math-compose-expr (nth 1 a
) 0) "}"))
479 ((and (eq (car a
) 'calcFunc-lambda
)
481 (memq calc-language
'(nil flat big
)))
484 (math-compose-hash-args (if (= (length a
) 3) 1 t
)))
485 (while (and (cdr p
) (equal (car p
) (car ap
)))
486 (setq p
(cdr p
) ap
(cdr ap
)))
489 (list (math-compose-vector
490 (nreverse (cdr (reverse (cdr a
)))) ", " 0)
493 (list (math-compose-expr (nth (1- (length a
)) a
) 0)
495 ((and (eq (car a
) 'calcFunc-string
)
497 (math-vectorp (nth 1 a
))
498 (math-vector-is-string (nth 1 a
)))
499 (if (eq calc-language
'unform
)
500 (concat "string(" (math-vector-to-string (nth 1 a
) t
) ")")
501 (math-vector-to-string (nth 1 a
) nil
)))
502 ((and (eq (car a
) 'calcFunc-bstring
)
504 (math-vectorp (nth 1 a
))
505 (math-vector-is-string (nth 1 a
)))
506 (if (eq calc-language
'unform
)
507 (concat "bstring(" (math-vector-to-string (nth 1 a
) t
) ")")
509 (s (math-vector-to-string (nth 1 a
) nil
))
511 (while (string-match "[^ ] +[^ ]" s
)
512 (setq p
(1- (match-end 0))
513 c
(cons (list 'break math-compose-level
)
514 (cons (substring s
0 p
)
517 (setq c
(nreverse (cons s c
)))
519 (setq c
(cons (list 'set math-compose-level
2) c
)))
521 ((and (eq (car a
) 'calcFunc-cprec
)
522 (not (eq calc-language
'unform
))
524 (integerp (nth 2 a
)))
525 (let ((c (math-compose-expr (nth 1 a
) -
1)))
526 (if (> prec
(nth 2 a
))
527 (if (memq calc-language
'(tex latex
))
528 (list 'horiz
"\\left( " c
" \\right)")
529 (if (eq calc-language
'eqn
)
530 (list 'horiz
"{left ( " c
" right )}")
531 (list 'horiz
"(" c
")")))
533 ((and (eq (car a
) 'calcFunc-choriz
)
534 (not (eq calc-language
'unform
))
535 (memq (length a
) '(2 3 4))
536 (math-vectorp (nth 1 a
))
537 (if (integerp (nth 2 a
))
539 (and (math-vectorp (nth 3 a
))
540 (math-vector-is-string (nth 3 a
))))
542 (and (math-vectorp (nth 2 a
))
543 (math-vector-is-string (nth 2 a
))))))
544 (let* ((cprec (and (integerp (nth 2 a
)) (nth 2 a
)))
545 (sep (nth (if cprec
3 2) a
))
548 (math-compose-vector (cdr (nth 1 a
))
549 (math-vector-to-string sep nil
)
551 (cons 'horiz
(mapcar (function
553 (if (eq (car-safe x
) 'calcFunc-bstring
)
556 x
(or bprec cprec prec
))
558 (math-compose-expr x
(or cprec prec
)))))
560 ((and (memq (car a
) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert
))
561 (not (eq calc-language
'unform
))
562 (memq (length a
) '(2 3))
563 (math-vectorp (nth 1 a
))
565 (integerp (nth 2 a
))))
568 (prec (or (nth 2 a
) prec
))
571 (let ((b nil
) (cc nil
) a d
)
572 (if (and (memq (car-safe x
) '(calcFunc-cbase
575 (memq (length x
) '(1 2)))
578 (if (and (eq (car-safe x
) 'calcFunc-crule
)
579 (memq (length x
) '(1 2))
581 (and (math-vectorp (nth 1 x
))
582 (= (length (nth 1 x
)) 2)
583 (math-vector-is-string
585 (and (natnump (nth 1 x
))
586 (<= (nth 1 x
) 255))))
589 (if (math-vectorp (nth 1 x
))
590 (aref (math-vector-to-string
593 (or (and (memq (car-safe x
) '(calcFunc-cvspace
596 (memq (length x
) '(2 3))
599 (setq cc
(math-compose-expr x prec
))))
600 (setq a
(if cc
(math-comp-ascent cc
) 0)
601 d
(if cc
(math-comp-descent cc
) 0))
602 (if (eq b
'calcFunc-cbase
)
603 (setq base
(+ v a -
1))
604 (if (eq b
'calcFunc-ctbase
)
606 (if (eq b
'calcFunc-cbbase
)
607 (setq base
(+ v a d -
1)))))
611 (setq c
(delq nil c
))
613 (cons (if (eq (car a
) 'calcFunc-cvert
) 'vcent
614 (if (eq (car a
) 'calcFunc-clvert
) 'vleft
'vright
))
617 ((and (memq (car a
) '(calcFunc-csup calcFunc-csub
))
618 (not (eq calc-language
'unform
))
619 (memq (length a
) '(3 4))
621 (integerp (nth 3 a
))))
622 (list (if (eq (car a
) 'calcFunc-csup
) 'supscr
'subscr
)
623 (math-compose-expr (nth 1 a
) (or (nth 3 a
) 0))
624 (math-compose-expr (nth 2 a
) 0)))
625 ((and (eq (car a
) 'calcFunc-cflat
)
626 (not (eq calc-language
'unform
))
627 (memq (length a
) '(2 3))
629 (integerp (nth 2 a
))))
630 (let ((calc-language (if (memq calc-language
'(nil big
))
631 'flat calc-language
)))
632 (math-compose-expr (nth 1 a
) (or (nth 2 a
) 0))))
633 ((and (eq (car a
) 'calcFunc-cspace
)
634 (memq (length a
) '(2 3))
637 (cons 'horiz
(make-list (nth 1 a
)
638 (if (and (math-vectorp (nth 2 a
))
639 (math-vector-is-string (nth 2 a
)))
640 (math-vector-to-string (nth 2 a
) nil
)
641 (math-compose-expr (nth 2 a
) 0))))
642 (make-string (nth 1 a
) ?\
)))
643 ((and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
644 (memq (length a
) '(2 3))
648 (let* ((c (if (nth 2 a
)
649 (if (and (math-vectorp (nth 2 a
))
650 (math-vector-is-string (nth 2 a
)))
651 (math-vector-to-string (nth 2 a
) nil
)
652 (math-compose-expr (nth 2 a
) 0))
654 (ca (math-comp-ascent c
))
655 (cd (math-comp-descent c
)))
657 (cons (if (eq (car a
) 'calcFunc-ctspace
)
659 (if (eq (car a
) 'calcFunc-cbspace
)
660 (+ (* (1- (nth 1 a
)) (+ ca cd
)) (1- ca
))
661 (/ (1- (* (nth 1 a
) (+ ca cd
))) 2)))
662 (make-list (nth 1 a
) c
))))))
663 ((and (eq (car a
) 'calcFunc-evalto
)
664 (setq calc-any-evaltos t
)
665 (memq calc-language
'(tex latex eqn
))
666 (= math-compose-level
(if math-comp-tagged
2 1))
669 (if (memq calc-language
'(tex latex
)) "\\evalto " "evalto ")
670 (math-compose-expr (nth 1 a
) 0)
671 (if (memq calc-language
'(tex latex
)) " \\to " " -> ")
672 (math-compose-expr (nth 2 a
) 0)))
674 (let ((op (and (not (eq calc-language
'unform
))
675 (if (and (eq (car a
) 'calcFunc-if
) (= (length a
) 4))
676 (assoc "?" math-expr-opers
)
677 (math-assq2 (car a
) math-expr-opers
)))))
679 (or (= (length a
) 3) (eq (car a
) 'calcFunc-if
))
682 ((> prec
(or (nth 4 op
) (min (nth 2 op
) (nth 3 op
))))
683 (if (and (memq calc-language
'(tex latex
))
684 (not (math-tex-expr-is-flat a
)))
685 (if (eq (car-safe a
) '/)
686 (list 'horiz
"{" (math-compose-expr a -
1) "}")
687 (list 'horiz
"\\left( "
688 (math-compose-expr a -
1)
690 (if (eq calc-language
'eqn
)
691 (if (or (eq (car-safe a
) '/)
693 (list 'horiz
"{" (math-compose-expr a -
1) "}")
694 (if (math-tex-expr-is-flat a
)
695 (list 'horiz
"( " (math-compose-expr a -
1) " )")
696 (list 'horiz
"{left ( "
697 (math-compose-expr a -
1)
699 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
700 ((and (memq calc-language
'(tex latex
))
701 (memq (car a
) '(/ calcFunc-choose calcFunc-evalto
))
703 (list 'horiz
"{" (math-compose-expr a -
1) "}"))
704 ((eq (car a
) 'calcFunc-if
)
706 (math-compose-expr (nth 1 a
) (nth 2 op
))
708 (math-compose-expr (nth 2 a
) 0)
710 (math-compose-expr (nth 3 a
) (nth 3 op
))))
712 (let* ((math-comp-tagged (and math-comp-tagged
715 (setlev (if (= prec
(min (nth 2 op
) (nth 3 op
)))
717 (setq math-compose-level
718 (1- math-compose-level
))
721 (lhs (math-compose-expr (nth 1 a
) (nth 2 op
)))
722 (rhs (math-compose-expr (nth 2 a
) (nth 3 op
))))
723 (and (equal (car op
) "^")
724 (eq (math-comp-first-char lhs
) ?-
)
725 (setq lhs
(list 'horiz
"(" lhs
")")))
726 (and (memq calc-language
'(tex latex
))
727 (or (equal (car op
) "^") (equal (car op
) "_"))
728 (not (and (stringp rhs
) (= (length rhs
) 1)))
729 (setq rhs
(list 'horiz
"{" rhs
"}")))
730 (or (and (eq (car a
) '*)
731 (or (null calc-language
)
732 (assoc "2x" math-expr-opers
))
733 (let* ((prevt (math-prod-last-term (nth 1 a
)))
734 (nextt (math-prod-first-term (nth 2 a
)))
735 (prevc (or (math-comp-last-char lhs
)
736 (and (memq (car-safe prevt
)
740 (eq calc-language
'big
)
742 (nextc (or (math-comp-first-char rhs
)
743 (and (memq (car-safe nextt
)
748 (eq calc-language
'big
)
751 (or (and (>= nextc ?a
) (<= nextc ?z
))
752 (and (>= nextc ?A
) (<= nextc ?Z
))
753 (and (>= nextc ?
0) (<= nextc ?
9))
754 (memq nextc
'(?. ?_ ?
#
759 (math-comp-first-string
761 (not (and (eq (car-safe prevt
) 'var
)
766 (list 'break math-compose-level
)
772 (list 'break math-compose-level
)
773 (if (or (equal (car op
) "^")
775 (equal (car op
) "**")
776 (and (equal (car op
) "*")
777 (math-comp-last-char lhs
)
778 (math-comp-first-char rhs
))
779 (and (equal (car op
) "/")
780 (math-num-integerp (nth 1 a
))
781 (math-integerp (nth 2 a
))))
783 (if (and (eq calc-language
'big
)
784 (equal (car op
) "=>"))
786 (concat " " (car op
) " ")))
788 ((and op
(= (length a
) 2) (= (nth 3 op
) -
1))
790 ((or (> prec
(or (nth 4 op
) (nth 2 op
)))
791 (and (not (eq (assoc (car op
) math-expr-opers
) op
))
792 (> prec
0))) ; don't write x% + y
793 (if (and (memq calc-language
'(tex latex
))
794 (not (math-tex-expr-is-flat a
)))
795 (list 'horiz
"\\left( "
796 (math-compose-expr a -
1)
798 (if (eq calc-language
'eqn
)
799 (if (= (/ prec
100) 9)
800 (list 'horiz
"{" (math-compose-expr a -
1) "}")
801 (if (math-tex-expr-is-flat a
)
802 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
803 (list 'horiz
"{left ( "
804 (math-compose-expr a -
1)
806 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
808 (let ((lhs (math-compose-expr (nth 1 a
) (nth 2 op
))))
811 (if (or (> (length (car op
)) 1)
812 (not (math-comp-is-flat lhs
)))
813 (concat " " (car op
))
815 ((and op
(= (length a
) 2) (= (nth 2 op
) -
1))
818 (let ((lr (and (memq calc-language
'(tex latex
))
819 (not (math-tex-expr-is-flat (nth 1 a
))))))
822 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op
))
823 (substring (car op
) 1)
825 (if (or lr
(> (length (car op
)) 2)) " " "")
826 (math-compose-expr (nth 1 a
) -
1)
827 (if (or lr
(> (length (car op
)) 2)) " " "")
829 (car (nth 1 (memq op math-expr-opers
))))))
830 ((> prec
(or (nth 4 op
) (nth 3 op
)))
831 (if (and (memq calc-language
'(tex latex
))
832 (not (math-tex-expr-is-flat a
)))
833 (list 'horiz
"\\left( "
834 (math-compose-expr a -
1)
836 (if (eq calc-language
'eqn
)
837 (if (= (/ prec
100) 9)
838 (list 'horiz
"{" (math-compose-expr a -
1) "}")
839 (if (math-tex-expr-is-flat a
)
840 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
841 (list 'horiz
"{left ( "
842 (math-compose-expr a -
1)
844 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
846 (let ((rhs (math-compose-expr (nth 1 a
) (nth 3 op
))))
848 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
850 (substring (car op
) 1)
852 (if (or (> (length ops
) 1)
853 (not (math-comp-is-flat rhs
)))
857 ((and (eq calc-language
'big
)
858 (setq op
(get (car a
) 'math-compose-big
))
859 (funcall op a prec
)))
860 ((and (setq op
(assq calc-language
861 '( ( nil . math-compose-normal
)
862 ( flat . math-compose-normal
)
863 ( big . math-compose-normal
)
864 ( c . math-compose-c
)
865 ( pascal . math-compose-pascal
)
866 ( fortran . math-compose-fortran
)
867 ( tex . math-compose-tex
)
868 ( latex . math-compose-latex
)
869 ( eqn . math-compose-eqn
)
870 ( math . math-compose-math
)
871 ( maple . math-compose-maple
))))
872 (setq op
(get (car a
) (cdr op
)))
873 (funcall op a prec
)))
875 (let* ((func (car a
))
876 (func2 (assq func
'(( mod . calcFunc-makemod
)
877 ( sdev . calcFunc-sdev
)
884 ( neg . calcFunc-neg
)
885 ( | . calcFunc-vconcat
))))
888 (setq func
(cdr func2
)))
889 (if (setq func2
(rassq func math-expr-function-mapping
))
890 (setq func
(car func2
)))
891 (setq func
(math-remove-dashes
893 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
895 (math-match-substring (symbol-name func
) 1)
896 (symbol-name func
))))
897 (if (memq calc-language
'(c fortran pascal maple
))
898 (setq func
(math-to-underscores func
)))
899 (if (and (memq calc-language
'(tex latex
))
901 (not (= calc-language-option
0))
902 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func
))
903 (if (< (prefix-numeric-value calc-language-option
) 0)
904 (setq func
(format "\\%s" func
))
905 (setq func
(if (eq calc-language
'latex
)
906 (format "\\text{%s}" func
)
907 (format "\\hbox{%s}" func
)))))
908 (if (and (eq calc-language
'eqn
)
909 (string-match "[^']'+\\'" func
))
910 (let ((n (- (length func
) (match-beginning 0) 1)))
911 (setq func
(substring func
0 (- n
)))
912 (while (>= (setq n
(1- n
)) 0)
913 (setq func
(concat func
" prime")))))
914 (cond ((and (memq calc-language
'(tex latex
))
916 (not (math-tex-expr-is-flat (nth 1 a
)))))
917 (setq left
"\\left( "
919 ((and (eq calc-language
'eqn
)
921 (not (math-tex-expr-is-flat (nth 1 a
)))))
922 (setq left
"{left ( "
924 ((and (or (and (memq calc-language
'(tex latex
))
925 (eq (aref func
0) ?
\\))
926 (and (eq calc-language
'eqn
)
927 (memq (car a
) math-eqn-special-funcs
)))
929 (string-match "\\hbox{" func
)
930 (string-match "\\text{" func
)))
932 (or (Math-realp (nth 1 a
))
933 (memq (car (nth 1 a
)) '(var *))))
934 (setq left
(if (eq calc-language
'eqn
) "~{" "{")
936 ((eq calc-language
'eqn
)
939 (t (setq left calc-function-open
940 right calc-function-close
)))
941 (list 'horiz func left
942 (math-compose-vector (cdr a
)
943 (if (eq calc-language
'eqn
)
949 (defun math-prod-first-term (x)
950 (while (eq (car-safe x
) '*)
954 (defun math-prod-last-term (x)
955 (while (eq (car-safe x
) '*)
959 (defun math-compose-vector (a sep prec
)
962 (cons (list 'set math-compose-level
)
963 (let ((c (list (math-compose-expr (car a
) prec
))))
964 (while (setq a
(cdr a
))
965 (setq c
(cons (if (eq (car-safe (car a
))
967 (let ((math-compose-level
968 (1- math-compose-level
)))
969 (math-compose-expr (car a
) -
123))
970 (math-compose-expr (car a
) prec
))
971 (cons (list 'break math-compose-level
)
976 (defun math-vector-no-parens (a)
978 (not (eq (car-safe (nth 1 a
)) '*))))
980 (defun math-compose-matrix (a col cols base
)
983 (while (<= (setq col
(1+ col
)) cols
)
984 (setq res
(cons (cons math-comp-just
991 math-comp-vector-prec
)
995 math-comp-comma-spc
" ")))))
1000 (defun math-compose-rows (a count first
)
1004 (math-compose-rows (cdr a
) -
1 nil
)
1005 (cons (concat (if (memq calc-language
'(tex latex
)) " \\ldots" " ...")
1007 (math-compose-rows (cdr a
) -
1 nil
)))
1009 (if first
(concat math-comp-left-bracket
" ") " ")
1010 (math-compose-expr (car a
) math-comp-vector-prec
)
1012 (math-compose-rows (cdr a
) (1- count
) nil
)))
1014 (if first
(concat math-comp-left-bracket
" ") " ")
1015 (math-compose-expr (car a
) math-comp-vector-prec
)
1016 (concat " " math-comp-right-bracket
)))))
1018 (defun math-compose-tex-matrix (a &optional ltx
)
1020 (cons (append (math-compose-vector (cdr (car a
)) " & " 0)
1021 (if ltx
'(" \\\\ ") '(" \\cr ")))
1022 (math-compose-tex-matrix (cdr a
) ltx
))
1023 (list (math-compose-vector (cdr (car a
)) " & " 0))))
1025 (defun math-compose-eqn-matrix (a)
1028 (cond ((eq calc-matrix-just
'right
) "rcol ")
1029 ((eq calc-matrix-just
'center
) "ccol ")
1032 (list 'break math-compose-level
)
1036 (let ((math-compose-level (1+ math-compose-level
)))
1037 (math-compose-vector (cdr (car a
)) " above " 1000))
1040 (math-compose-eqn-matrix (cdr a
)))))))
1043 (defun math-vector-is-string (a)
1044 (while (and (setq a
(cdr a
))
1045 (or (and (natnump (car a
))
1047 (and (eq (car-safe (car a
)) 'cplx
)
1048 (natnump (nth 1 (car a
)))
1049 (eq (nth 2 (car a
)) 0)
1050 (<= (nth 1 (car a
)) 255)))))
1053 (defconst math-vector-to-string-chars
'( ( ?
\" .
"\\\"" )
1064 (defun math-vector-to-string (a &optional quoted
)
1065 (setq a
(concat (mapcar (function (lambda (x) (if (consp x
) (nth 1 x
) x
)))
1067 (if (string-match "[\000-\037\177\\\"]" a
)
1069 (pat (if quoted
"[\000-\037\177\\\"]" "[\000-\037\177]"))
1070 (codes (if quoted math-vector-to-string-chars
'((?\^? .
"^?"))))
1071 (fmt (if quoted
"\\^%c" "^%c"))
1073 (while (setq p
(string-match pat a p
))
1074 (if (setq new
(assq (aref a p
) codes
))
1075 (setq a
(concat (substring a
0 p
)
1077 (substring a
(1+ p
)))
1078 p
(+ p
(length (cdr new
))))
1079 (setq a
(concat (substring a
0 p
)
1080 (format fmt
(+ (aref a p
) 64))
1081 (substring a
(1+ p
)))
1084 (concat "\"" a
"\"")
1088 (defun math-to-underscores (x)
1089 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x
)
1090 (math-to-underscores
1091 (concat (math-match-substring x
1) "_" (math-match-substring x
2)))
1094 (defun math-tex-expr-is-flat (a)
1095 (or (Math-integerp a
)
1096 (memq (car a
) '(float var
))
1097 (and (memq (car a
) '(+ -
* neg
))
1099 (while (and (setq a
(cdr a
))
1100 (math-tex-expr-is-flat (car a
))))
1102 (and (memq (car a
) '(^ calcFunc-subscr
))
1103 (math-tex-expr-is-flat (nth 1 a
)))))
1105 (put 'calcFunc-log
'math-compose-big
'math-compose-log
)
1106 (defun math-compose-log (a prec
)
1107 (and (= (length a
) 3)
1110 (let ((calc-language 'flat
))
1111 (math-compose-expr (nth 2 a
) 1000)))
1113 (math-compose-expr (nth 1 a
) 1000)
1116 (put 'calcFunc-log10
'math-compose-big
'math-compose-log10
)
1117 (defun math-compose-log10 (a prec
)
1118 (and (= (length a
) 2)
1120 (list 'subscr
"log" "10")
1122 (math-compose-expr (nth 1 a
) 1000)
1125 (put 'calcFunc-deriv
'math-compose-big
'math-compose-deriv
)
1126 (put 'calcFunc-tderiv
'math-compose-big
'math-compose-deriv
)
1127 (defun math-compose-deriv (a prec
)
1128 (when (= (length a
) 3)
1129 (math-compose-expr (list '/
1130 (list 'calcFunc-choriz
1132 '(calcFunc-string (vec ?d
))
1134 (list 'calcFunc-choriz
1136 '(calcFunc-string (vec ?d
))
1140 (put 'calcFunc-sqrt
'math-compose-big
'math-compose-sqrt
)
1141 (defun math-compose-sqrt (a prec
)
1142 (when (= (length a
) 2)
1143 (let* ((c (math-compose-expr (nth 1 a
) 0))
1144 (a (math-comp-ascent c
))
1145 (d (math-comp-descent c
))
1147 (w (math-comp-width c
)))
1150 (concat (if (= h
1) " " " ")
1151 (make-string (+ w
2) ?\_
))
1155 (append (list 'vleft
(1- a
))
1156 (make-list (1- h
) " |")
1161 (put 'calcFunc-choose
'math-compose-big
'math-compose-choose
)
1162 (defun math-compose-choose (a prec
)
1163 (let ((a1 (math-compose-expr (nth 1 a
) 0))
1164 (a2 (math-compose-expr (nth 2 a
) 0)))
1168 (math-comp-height a1
)
1172 (put 'calcFunc-integ
'math-compose-big
'math-compose-integ
)
1173 (defun math-compose-integ (a prec
)
1174 (and (memq (length a
) '(3 5))
1175 (eq (car-safe (nth 2 a
)) 'var
)
1176 (let* ((parens (and (>= prec
196) (/= prec
1000)))
1177 (var (math-compose-expr (nth 2 a
) 0))
1178 (over (and (eq (car-safe (nth 2 a
)) 'var
)
1179 (or (and (eq (car-safe (nth 1 a
)) '/)
1180 (math-numberp (nth 1 (nth 1 a
))))
1181 (and (eq (car-safe (nth 1 a
)) '^
)
1182 (math-looks-negp (nth 2 (nth 1 a
)))))))
1183 (expr (math-compose-expr (if over
1185 (math-build-var-name
1188 (nth 1 (nth 2 a
)))))
1190 (calc-language 'flat
)
1191 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1192 (high (and (nth 4 a
) (math-compose-expr (nth 4 a
) 0))))
1195 (append (list 'vcent
(if high
3 2))
1196 (and high
(list (list 'horiz
" " high
)))
1202 (and low
(list (list 'horiz low
" "))))
1206 (list 'horiz
" d" var
))
1207 (if parens
")" "")))))
1209 (put 'calcFunc-sum
'math-compose-big
'math-compose-sum
)
1210 (defun math-compose-sum (a prec
)
1211 (and (memq (length a
) '(3 5 6))
1212 (let* ((expr (math-compose-expr (nth 1 a
) 185))
1213 (calc-language 'flat
)
1214 (var (math-compose-expr (nth 2 a
) 0))
1215 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1216 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1218 (if (memq prec
'(180 201)) "(" "")
1219 (append (list 'vcent
(if high
3 2))
1220 (and high
(list high
))
1227 (list (list 'horiz var
" = " low
))
1229 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1232 (if (memq prec
'(180 201)) ")" "")))))
1234 (put 'calcFunc-prod
'math-compose-big
'math-compose-prod
)
1235 (defun math-compose-prod (a prec
)
1236 (and (memq (length a
) '(3 5 6))
1237 (let* ((expr (math-compose-expr (nth 1 a
) 198))
1238 (calc-language 'flat
)
1239 (var (math-compose-expr (nth 2 a
) 0))
1240 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1241 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1243 (if (memq prec
'(196 201)) "(" "")
1244 (append (list 'vcent
(if high
3 2))
1245 (and high
(list high
))
1251 (list (list 'horiz var
" = " low
))
1253 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1256 (if (memq prec
'(196 201)) ")" "")))))
1258 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1259 ;; to math-stack-value-offset in calc.el, but are used by
1260 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1262 (defvar math-svo-wid
)
1263 (defvar math-svo-off
)
1265 (defun math-stack-value-offset-fancy ()
1266 (let ((cwid (+ (math-comp-width math-svo-c
))))
1267 (cond ((eq calc-display-just
'right
)
1268 (if calc-display-origin
1269 (setq math-svo-wid
(max calc-display-origin
5))
1270 (if (integerp calc-line-breaking
)
1271 (setq math-svo-wid calc-line-breaking
)))
1272 (setq math-svo-off
(- math-svo-wid cwid
1273 (max (- (length calc-right-label
)
1274 (if (and (integerp calc-line-breaking
)
1275 calc-display-origin
)
1276 (max (- calc-line-breaking
1277 calc-display-origin
)
1282 (if calc-display-origin
1284 (setq math-svo-off
(- calc-display-origin
(/ cwid
2)))
1285 (if (integerp calc-line-breaking
)
1286 (setq math-svo-off
(min math-svo-off
(- calc-line-breaking cwid
1287 (length calc-right-label
)))))
1288 (if (>= math-svo-off
0)
1289 (setq math-svo-wid
(max math-svo-wid
(+ math-svo-off cwid
)))))
1290 (if (integerp calc-line-breaking
)
1291 (setq math-svo-wid calc-line-breaking
))
1292 (setq math-svo-off
(/ (- math-svo-wid cwid
) 2)))))
1293 (and (integerp calc-line-breaking
)
1294 (or (< math-svo-off
0)
1295 (and calc-display-origin
1296 (> calc-line-breaking calc-display-origin
)))
1297 (setq math-svo-wid calc-line-breaking
))))
1300 ;;; Convert a composition to string form, with embedded \n's if necessary.
1302 (defun math-composition-to-string (c &optional width
)
1303 (or width
(setq width
(calc-window-width)))
1304 (if calc-display-raw
1305 (math-comp-to-string-raw c
0)
1306 (if (math-comp-is-flat c
)
1307 (math-comp-to-string-flat c width
)
1308 (math-vert-comp-to-string
1309 (math-comp-simplify c width
)))))
1311 (defvar math-comp-buf-string
(make-vector 10 ""))
1312 (defvar math-comp-buf-margin
(make-vector 10 0))
1313 (defvar math-comp-buf-level
(make-vector 10 0))
1314 (defun math-comp-is-flat (c) ; check if c's height is 1.
1315 (cond ((not (consp c
)) t
)
1316 ((memq (car c
) '(set break
)) t
)
1317 ((eq (car c
) 'horiz
)
1318 (while (and (setq c
(cdr c
))
1319 (math-comp-is-flat (car c
))))
1321 ((memq (car c
) '(vleft vcent vright
))
1322 (and (= (length c
) 3)
1324 (math-comp-is-flat (nth 2 c
))))
1326 (math-comp-is-flat (nth 2 c
)))
1330 ;;; Convert a one-line composition to a string. Break into multiple
1331 ;;; lines if necessary, choosing break points according to the structure
1334 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1335 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1336 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1337 ;; which is called by math-comp-to-string-flat.
1338 ;; math-comp-highlight and math-comp-buf are also local to
1339 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1340 ;; by math-comp-add-string.
1341 (defvar math-comp-full-width
)
1342 (defvar math-comp-highlight
)
1343 (defvar math-comp-word
)
1344 (defvar math-comp-level
)
1345 (defvar math-comp-margin
)
1346 (defvar math-comp-buf
)
1347 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1348 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1349 ;; which are called by math-comp-to-string-flat.
1350 (defvar math-comp-pos
)
1352 (defun math-comp-to-string-flat (c math-comp-full-width
)
1353 (if math-comp-sel-hpos
1354 (let ((math-comp-pos 0))
1355 (math-comp-sel-flat-term c
))
1356 (let ((math-comp-buf "")
1359 (math-comp-margin 0)
1360 (math-comp-highlight (and math-comp-selected calc-show-selections
))
1361 (math-comp-level -
1))
1362 (math-comp-to-string-flat-term '(set -
1 0))
1363 (math-comp-to-string-flat-term c
)
1364 (math-comp-to-string-flat-term '(break -
1))
1365 (let ((str (aref math-comp-buf-string
0))
1367 (and (> (length str
) 0) (= (aref str
0) ?
)
1368 (> (length math-comp-buf
) 0)
1369 (let ((k (length math-comp-buf
)))
1370 (while (not (= (aref math-comp-buf
(setq k
(1- k
))) ?
\n)))
1371 (aset math-comp-buf k ?
)
1372 (if (and (< (1+ k
) (length math-comp-buf
))
1373 (= (aref math-comp-buf
(1+ k
)) ?
))
1375 (aset math-comp-buf
(1+ k
) ?
\n)
1377 (setq prefix
"\n"))))
1378 (concat math-comp-buf prefix str
)))))
1380 (defun math-comp-to-string-flat-term (c)
1381 (cond ((not (consp c
))
1382 (if math-comp-highlight
1383 (setq c
(math-comp-highlight-string c
)))
1384 (setq math-comp-word
(if (= (length math-comp-word
) 0) c
1385 (concat math-comp-word c
))
1386 math-comp-pos
(+ math-comp-pos
(length c
))))
1388 ((eq (car c
) 'horiz
)
1389 (while (setq c
(cdr c
))
1390 (math-comp-to-string-flat-term (car c
))))
1395 (setq math-comp-level
(1+ math-comp-level
))
1396 (if (>= math-comp-level
(length math-comp-buf-string
))
1397 (setq math-comp-buf-string
(vconcat math-comp-buf-string
1398 math-comp-buf-string
)
1399 math-comp-buf-margin
(vconcat math-comp-buf-margin
1400 math-comp-buf-margin
)
1401 math-comp-buf-level
(vconcat math-comp-buf-level
1402 math-comp-buf-level
)))
1403 (aset math-comp-buf-string math-comp-level
"")
1404 (aset math-comp-buf-margin math-comp-level
(+ math-comp-pos
1406 (aset math-comp-buf-level math-comp-level
(nth 1 c
)))))
1408 ((eq (car c
) 'break
)
1409 (if (not calc-line-breaking
)
1410 (setq math-comp-buf
(concat math-comp-buf math-comp-word
)
1413 (if (and (> math-comp-pos math-comp-full-width
)
1416 (setq str
(aref math-comp-buf-string i
))
1417 (and (= (length str
) 0) (< i math-comp-level
)))
1419 (or (> (length str
) 0) (> (length math-comp-buf
) 0))))
1420 (let ((prefix "") mrg wid
)
1421 (setq mrg
(aref math-comp-buf-margin i
))
1422 (if (> mrg
12) ; indenting too far, go back to far left
1423 (let ((j i
) (new (if calc-line-numbering
5 1)))
1424 '(while (<= j math-comp-level
)
1425 (aset math-comp-buf-margin j
1426 (+ (aref math-comp-buf-margin j
) (- new mrg
)))
1429 (setq wid
(+ (length str
) math-comp-margin
))
1430 (and (> (length str
) 0) (= (aref str
0) ?
)
1431 (> (length math-comp-buf
) 0)
1432 (let ((k (length math-comp-buf
)))
1433 (while (not (= (aref math-comp-buf
(setq k
(1- k
))) ?
\n)))
1434 (aset math-comp-buf k ?
)
1435 (if (and (< (1+ k
) (length math-comp-buf
))
1436 (= (aref math-comp-buf
(1+ k
)) ?
))
1438 (aset math-comp-buf
(1+ k
) ?
\n)
1440 (setq prefix
"\n"))))
1441 (setq math-comp-buf
(concat math-comp-buf prefix str
"\n"
1442 (make-string mrg ?
))
1443 math-comp-pos
(+ math-comp-pos
(- mrg wid
))
1444 math-comp-margin mrg
)
1445 (aset math-comp-buf-string i
"")
1446 (while (<= (setq i
(1+ i
)) math-comp-level
)
1447 (if (> (aref math-comp-buf-margin i
) wid
)
1448 (aset math-comp-buf-margin i
1449 (+ (aref math-comp-buf-margin i
)
1451 (if (and (= (nth 1 c
) (aref math-comp-buf-level math-comp-level
))
1452 (< math-comp-pos
(+ (aref math-comp-buf-margin math-comp-level
) 2)))
1453 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1454 (let ((str (aref math-comp-buf-string math-comp-level
)))
1455 (setq str
(if (= (length str
) 0)
1457 (concat str math-comp-word
))
1459 (while (< (nth 1 c
) (aref math-comp-buf-level math-comp-level
))
1460 (setq math-comp-level
(1- math-comp-level
))
1461 (or (= (length (aref math-comp-buf-string math-comp-level
)) 0)
1462 (setq str
(concat (aref math-comp-buf-string math-comp-level
)
1464 (aset math-comp-buf-string math-comp-level str
)))))
1467 (cond ((eq (nth 1 c
) math-comp-selected
)
1468 (let ((math-comp-highlight (not calc-show-selections
)))
1469 (math-comp-to-string-flat-term (nth 2 c
))))
1471 (let ((math-comp-highlight nil
))
1472 (math-comp-to-string-flat-term (nth 2 c
))))
1473 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1475 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1477 (defun math-comp-highlight-string (s)
1478 (setq s
(copy-sequence s
))
1479 (let ((i (length s
)))
1480 (while (>= (setq i
(1- i
)) 0)
1481 (or (memq (aref s i
) '(32 ?
\n))
1482 (aset s i
(if calc-show-selections ?\. ?\
#)))))
1486 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1487 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1488 ;; math-comp-add-string-sel, which are called (indirectly) by
1489 ;; calc-find-selected-part.
1490 (defvar math-comp-sel-tag
)
1492 (defun math-comp-sel-flat-term (c)
1493 (cond ((not (consp c
))
1494 (setq math-comp-pos
(+ math-comp-pos
(length c
))))
1495 ((memq (car c
) '(set break
)))
1496 ((eq (car c
) 'horiz
)
1497 (while (and (setq c
(cdr c
)) (< math-comp-sel-cpos
1000000))
1498 (math-comp-sel-flat-term (car c
))))
1500 (if (<= math-comp-pos math-comp-sel-cpos
)
1502 (math-comp-sel-flat-term (nth 2 c
))
1503 (if (> math-comp-pos math-comp-sel-cpos
)
1504 (setq math-comp-sel-tag c
1505 math-comp-sel-cpos
1000000)))
1506 (math-comp-sel-flat-term (nth 2 c
))))
1507 (t (math-comp-sel-flat-term (nth 2 c
)))))
1510 ;;; Simplify a composition to a canonical form consisting of
1511 ;;; (vleft n "string" "string" "string" ...)
1512 ;;; where 0 <= n < number-of-strings.
1514 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1515 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1516 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1517 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1518 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1519 ;; math-comp-simplify.
1520 (defvar math-comp-base
)
1521 (defvar math-comp-hgt
)
1522 (defvar math-comp-tag
)
1523 (defvar math-comp-hpos
)
1524 (defvar math-comp-vpos
)
1526 (defun math-comp-simplify (c full-width
)
1527 (let ((math-comp-buf (list ""))
1532 (math-comp-highlight (and math-comp-selected calc-show-selections
))
1533 (math-comp-tag nil
))
1534 (math-comp-simplify-term c
)
1535 (cons 'vleft
(cons math-comp-base math-comp-buf
))))
1537 (defun math-comp-add-string (s h v
)
1538 (and (> (length s
) 0)
1539 (let ((vv (+ v math-comp-base
)))
1540 (if math-comp-sel-hpos
1541 (math-comp-add-string-sel h vv
(length s
) 1)
1543 (setq math-comp-buf
(nconc (make-list (- vv
) "") math-comp-buf
)
1544 math-comp-base
(- v
)
1545 math-comp-hgt
(- math-comp-hgt vv
)
1547 (if (>= vv math-comp-hgt
)
1548 (setq math-comp-buf
(nconc math-comp-buf
1549 (make-list (1+ (- vv math-comp-hgt
)) ""))
1550 math-comp-hgt
(1+ vv
))))
1551 (let ((str (nthcdr vv math-comp-buf
)))
1552 (setcar str
(concat (car str
)
1553 (make-string (- h
(length (car str
))) 32)
1554 (if math-comp-highlight
1555 (math-comp-highlight-string s
)
1558 (defun math-comp-add-string-sel (x y w h
)
1559 (if (and (<= y math-comp-sel-vpos
)
1560 (> (+ y h
) math-comp-sel-vpos
)
1561 (<= x math-comp-sel-hpos
)
1562 (> (+ x w
) math-comp-sel-hpos
))
1563 (setq math-comp-sel-tag math-comp-tag
1564 math-comp-sel-vpos
10000)))
1566 (defun math-comp-simplify-term (c)
1568 (math-comp-add-string c math-comp-hpos math-comp-vpos
)
1569 (setq math-comp-hpos
(+ math-comp-hpos
(length c
))))
1570 ((memq (car c
) '(set break
))
1572 ((eq (car c
) 'horiz
)
1573 (while (setq c
(cdr c
))
1574 (math-comp-simplify-term (car c
))))
1575 ((memq (car c
) '(vleft vcent vright
))
1576 (let* ((math-comp-vpos (+ (- math-comp-vpos
(nth 1 c
))
1577 (1- (math-comp-ascent (nth 2 c
)))))
1578 (widths (mapcar 'math-comp-width
(cdr (cdr c
))))
1579 (maxwid (apply 'max widths
))
1580 (bias (cond ((eq (car c
) 'vleft
) 0)
1581 ((eq (car c
) 'vcent
) 1)
1584 (while (setq c
(cdr c
))
1585 (if (eq (car-safe (car c
)) 'rule
)
1586 (math-comp-add-string (make-string maxwid
(nth 1 (car c
)))
1587 math-comp-hpos math-comp-vpos
)
1588 (let ((math-comp-hpos (+ math-comp-hpos
(/ (* bias
(- maxwid
1591 (math-comp-simplify-term (car c
))))
1593 (setq math-comp-vpos
(+ math-comp-vpos
1594 (+ (math-comp-descent (car c
))
1595 (math-comp-ascent (nth 1 c
))))
1596 widths
(cdr widths
))))
1597 (setq math-comp-hpos
(+ math-comp-hpos maxwid
))))
1598 ((eq (car c
) 'supscr
)
1599 (let* ((asc (or 1 (math-comp-ascent (nth 1 c
))))
1600 (desc (math-comp-descent (nth 2 c
)))
1603 (math-comp-simplify-term (nth 1 c
))))
1604 (math-comp-vpos (- math-comp-vpos
(+ asc desc
))))
1605 (math-comp-simplify-term (nth 2 c
))
1606 (if math-comp-sel-hpos
1607 (math-comp-add-string-sel oldh
1610 (math-comp-ascent (nth 2 c
)))
1611 (- math-comp-hpos oldh
)
1612 (math-comp-height c
)))))
1613 ((eq (car c
) 'subscr
)
1614 (let* ((asc (math-comp-ascent (nth 2 c
)))
1615 (desc (math-comp-descent (nth 1 c
)))
1616 (oldv math-comp-vpos
)
1619 (math-comp-simplify-term (nth 1 c
))))
1620 (math-comp-vpos (+ math-comp-vpos
(+ asc desc
))))
1621 (math-comp-simplify-term (nth 2 c
))
1622 (if math-comp-sel-hpos
1623 (math-comp-add-string-sel oldh oldv
1624 (- math-comp-hpos oldh
)
1625 (math-comp-height c
)))))
1627 (cond ((eq (nth 1 c
) math-comp-selected
)
1628 (let ((math-comp-highlight (not calc-show-selections
)))
1629 (math-comp-simplify-term (nth 2 c
))))
1631 (let ((math-comp-highlight nil
))
1632 (math-comp-simplify-term (nth 2 c
))))
1633 (t (let ((math-comp-tag c
))
1634 (math-comp-simplify-term (nth 2 c
))))))))
1637 ;;; Measuring a composition.
1639 (defun math-comp-first-char (c)
1641 (and (> (length c
) 0)
1643 ((memq (car c
) '(horiz subscr supscr
))
1644 (while (and (setq c
(cdr c
))
1645 (math-comp-is-null (car c
))))
1646 (and c
(math-comp-first-char (car c
))))
1648 (math-comp-first-char (nth 2 c
)))))
1650 (defun math-comp-first-string (c)
1652 (and (> (length c
) 0)
1654 ((eq (car c
) 'horiz
)
1655 (while (and (setq c
(cdr c
))
1656 (math-comp-is-null (car c
))))
1657 (and c
(math-comp-first-string (car c
))))
1659 (math-comp-first-string (nth 2 c
)))))
1661 (defun math-comp-last-char (c)
1663 (and (> (length c
) 0)
1664 (elt c
(1- (length c
)))))
1665 ((eq (car c
) 'horiz
)
1666 (let ((c (reverse (cdr c
))))
1667 (while (and c
(math-comp-is-null (car c
)))
1669 (and c
(math-comp-last-char (car c
)))))
1671 (math-comp-last-char (nth 2 c
)))))
1673 (defun math-comp-is-null (c)
1674 (cond ((stringp c
) (= (length c
) 0))
1675 ((memq (car c
) '(horiz subscr supscr
))
1676 (while (and (setq c
(cdr c
))
1677 (math-comp-is-null (car c
))))
1680 (math-comp-is-null (nth 2 c
)))
1681 ((memq (car c
) '(set break
)) t
)))
1683 (defun math-comp-width (c)
1684 (cond ((not (consp c
)) (length c
))
1685 ((memq (car c
) '(horiz subscr supscr
))
1687 (while (setq c
(cdr c
))
1688 (setq accum
(+ accum
(math-comp-width (car c
)))))
1690 ((memq (car c
) '(vcent vleft vright
))
1693 (while (setq c
(cdr c
))
1694 (setq accum
(max accum
(math-comp-width (car c
)))))
1697 (math-comp-width (nth 2 c
)))
1700 (defun math-comp-height (c)
1703 (+ (math-comp-ascent c
) (math-comp-descent c
))))
1705 (defun math-comp-ascent (c)
1706 (cond ((not (consp c
)) 1)
1707 ((eq (car c
) 'horiz
)
1709 (while (setq c
(cdr c
))
1710 (setq accum
(max accum
(math-comp-ascent (car c
)))))
1712 ((memq (car c
) '(vcent vleft vright
))
1713 (if (> (nth 1 c
) 0) (1+ (nth 1 c
)) 1))
1714 ((eq (car c
) 'supscr
)
1715 (max (math-comp-ascent (nth 1 c
)) (1+ (math-comp-height (nth 2 c
)))))
1716 ((eq (car c
) 'subscr
)
1717 (math-comp-ascent (nth 1 c
)))
1719 (math-comp-ascent (nth 2 c
)))
1722 (defun math-comp-descent (c)
1723 (cond ((not (consp c
)) 0)
1724 ((eq (car c
) 'horiz
)
1726 (while (setq c
(cdr c
))
1727 (setq accum
(max accum
(math-comp-descent (car c
)))))
1729 ((memq (car c
) '(vcent vleft vright
))
1730 (let ((accum (- (nth 1 c
))))
1732 (while (setq c
(cdr c
))
1733 (setq accum
(+ accum
(math-comp-height (car c
)))))
1734 (max (1- accum
) 0)))
1735 ((eq (car c
) 'supscr
)
1736 (math-comp-descent (nth 1 c
)))
1737 ((eq (car c
) 'subscr
)
1738 (+ (math-comp-descent (nth 1 c
)) (math-comp-height (nth 2 c
))))
1740 (math-comp-descent (nth 2 c
)))
1743 (defun calcFunc-cwidth (a &optional prec
)
1744 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1745 (math-comp-width (math-compose-expr a
(or prec
0))))
1747 (defun calcFunc-cheight (a &optional prec
)
1748 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1749 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1750 (memq (length a
) '(2 3))
1753 (math-comp-height (math-compose-expr a
(or prec
0)))))
1755 (defun calcFunc-cascent (a &optional prec
)
1756 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1757 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1758 (memq (length a
) '(2 3))
1761 (math-comp-ascent (math-compose-expr a
(or prec
0)))))
1763 (defun calcFunc-cdescent (a &optional prec
)
1764 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1765 (math-comp-descent (math-compose-expr a
(or prec
0))))
1768 ;;; Convert a simplified composition into string form.
1770 (defun math-vert-comp-to-string (c)
1773 (math-vert-comp-to-string-step (cdr (cdr c
)))))
1775 (defun math-vert-comp-to-string-step (c)
1777 (concat (car c
) "\n" (math-vert-comp-to-string-step (cdr c
)))
1781 ;;; Convert a composition to a string in "raw" form (for debugging).
1783 (defun math-comp-to-string-raw (c indent
)
1784 (cond ((or (not (consp c
)) (eq (car c
) 'set
))
1785 (prin1-to-string c
))
1787 (concat "(" (symbol-name (car c
)) ")"))
1789 (let ((next-indent (+ indent
2 (length (symbol-name (car c
))))))
1791 (symbol-name (car c
))
1793 (math-comp-to-string-raw (nth 1 c
) next-indent
)
1794 (math-comp-to-string-raw-step (cdr (cdr c
))
1798 (defun math-comp-to-string-raw-step (cl indent
)
1801 (make-string indent
32)
1802 (math-comp-to-string-raw (car cl
) indent
)
1803 (math-comp-to-string-raw-step (cdr cl
) indent
))
1808 ;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1809 ;;; calccomp.el ends here