1 ;;; calccomp.el --- composition functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007 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
))
86 (math-expr-opers (math-expr-ops))
89 ((or (and (eq a math-comp-selected
) a
)
91 (not (eq math-comp-tagged a
))))
92 (let ((math-comp-selected nil
))
93 (and math-comp-tagged
(setq math-comp-tagged a
))
94 (list 'tag a
(math-compose-expr a prec
))))
95 ((and (not (consp a
)) (not (integerp a
)))
96 (concat "'" (prin1-to-string a
)))
97 ((setq spfn
(assq (car-safe a
) math-expr-special-function-mapping
))
98 (setq spfn
(cdr spfn
))
99 (funcall (car spfn
) a spfn
))
101 (if (or (eq (car-safe a
) 'frac
)
102 (and (nth 1 calc-frac-format
) (Math-integerp a
)))
103 (if (memq calc-language
'(tex latex eqn math maple c fortran pascal
))
104 (let ((aa (math-adjust-fraction a
))
105 (calc-frac-format nil
))
106 (math-compose-expr (list '/
107 (if (memq calc-language
'(c fortran
))
108 (math-float (nth 1 aa
))
111 (if (and (eq calc-language
'big
)
112 (= (length (car calc-frac-format
)) 1))
113 (let* ((aa (math-adjust-fraction a
))
114 (calc-frac-format nil
)
115 (math-radix-explicit-format nil
)
117 (if (math-negp (nth 1 aa
))
121 (math-abs (nth 1 aa
)))
123 (math-format-number (nth 2 aa
))))))
124 (if (= calc-number-radix
10)
128 (int-to-string calc-number-radix
)))))
129 (math-format-number a
)))
130 (if (not (eq calc-language
'big
))
131 (math-format-number a prec
)
132 (if (memq (car-safe a
) '(cplx polar
))
133 (if (math-zerop (nth 2 a
))
134 (math-compose-expr (nth 1 a
) prec
)
136 (math-compose-expr (nth 1 a
) 0)
137 (if (eq (car a
) 'cplx
) ", " "; ")
138 (math-compose-expr (nth 2 a
) 0) ")"))
139 (if (or (= calc-number-radix
10)
141 (and calc-group-digits
142 (not (assoc calc-group-char
'((",") (" "))))))
143 (math-format-number a prec
)
144 (let ((s (math-format-number a prec
))
146 (while (string-match (if (> calc-number-radix
14)
147 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
148 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
150 (setq c
(nconc c
(list (substring s
0 (match-beginning 0))
152 (math-match-substring s
2)
153 (math-match-substring s
1))))
154 s
(substring s
(match-end 0))))
156 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s
)
158 (substring s
0 (match-beginning 0)) " "
160 (math-match-substring s
1)
161 (math-match-substring s
2))
162 (math-match-substring s
3))))
163 (if c
(cons 'horiz
(nconc c
(list s
))) s
)))))))
164 ((and (get (car a
) 'math-compose-forms
)
165 (not (eq calc-language
'unform
))
166 (let ((comps (get (car a
) 'math-compose-forms
))
168 (or (and (setq temp
(assq calc-language comps
))
169 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
170 (setq temp
(apply (cdr temp2
) (cdr a
)))
171 (math-compose-expr temp prec
))
172 (and (setq temp2
(assq nil
(cdr temp
)))
173 (funcall (cdr temp2
) a
))))
174 (and (setq temp
(assq nil comps
))
175 (or (and (setq temp2
(assq (1- (length a
)) (cdr temp
)))
176 (setq temp
(apply (cdr temp2
) (cdr a
)))
177 (math-compose-expr temp prec
))
178 (and (setq temp2
(assq nil
(cdr temp
)))
179 (funcall (cdr temp2
) a
))))))))
181 (let* ((math-comp-left-bracket (if calc-vector-brackets
182 (substring calc-vector-brackets
0 1) ""))
183 (math-comp-right-bracket (if calc-vector-brackets
184 (substring calc-vector-brackets
1 2) ""))
185 (inner-brackets (memq 'R calc-matrix-brackets
))
186 (outer-brackets (memq 'O calc-matrix-brackets
))
187 (row-commas (memq 'C calc-matrix-brackets
))
188 (math-comp-comma-spc (or calc-vector-commas
" "))
189 (math-comp-comma (or calc-vector-commas
""))
190 (math-comp-vector-prec (if (or (and calc-vector-commas
191 (math-vector-no-parens a
))
192 (memq 'P calc-matrix-brackets
)) 0 1000))
193 (math-comp-just (cond ((eq calc-matrix-just
'right
) 'vright
)
194 ((eq calc-matrix-just
'center
) 'vcent
)
196 (break calc-break-vectors
))
197 (if (and (memq calc-language
'(nil big
))
198 (not calc-break-vectors
)
199 (math-matrixp a
) (not (math-matrixp (nth 1 a
)))
200 (or calc-full-vectors
201 (and (< (length a
) 7) (< (length (nth 1 a
)) 7))
202 (progn (setq break t
) nil
)))
204 (setq math-comp-vector-prec
(if (or (and calc-vector-commas
205 (math-vector-no-parens
207 (memq 'P calc-matrix-brackets
))
211 (concat math-comp-left-bracket math-comp-left-bracket
" ")
212 (math-compose-vector (cdr (nth 1 a
)) (concat math-comp-comma
" ")
213 math-comp-vector-prec
)
214 (concat " " math-comp-right-bracket math-comp-right-bracket
))
215 (let* ((rows (1- (length a
)))
216 (cols (1- (length (nth 1 a
))))
217 (base (/ (1- rows
) 2))
218 (calc-language 'flat
))
220 (list (append '(vleft)
222 (list (concat (and outer-brackets
223 (concat math-comp-left-bracket
226 (concat math-comp-left-bracket
229 (concat (and outer-brackets
233 math-comp-left-bracket
235 (math-compose-matrix (cdr a
) 1 cols base
)
236 (list (append '(vleft)
241 math-comp-right-bracket
244 (if (and outer-brackets
250 math-comp-right-bracket
))
254 math-comp-right-bracket
)))))))))
255 (if (and calc-display-strings
257 (math-vector-is-string a
))
258 (math-vector-to-string a t
)
259 (if (and break
(cdr a
)
260 (not (eq calc-language
'flat
)))
261 (let* ((full (or calc-full-vectors
(< (length a
) 7)))
262 (rows (if full
(1- (length a
)) 5))
263 (base (/ (1- rows
) 2))
264 (calc-break-vectors nil
))
266 (cons 'vleft
(cons base
269 (if full rows
3) t
)))))
270 (if (or calc-full-vectors
(< (length a
) 7))
271 (if (and (eq calc-language
'tex
)
273 (if (and (integerp calc-language-option
)
274 (or (= calc-language-option
0)
275 (> calc-language-option
1)
276 (< calc-language-option -
1)))
277 (append '(vleft 0 "\\matrix{")
278 (math-compose-tex-matrix (cdr a
))
280 (append '(horiz "\\matrix{ ")
281 (math-compose-tex-matrix (cdr a
))
283 (if (and (eq calc-language
'latex
)
285 (if (and (integerp calc-language-option
)
286 (or (= calc-language-option
0)
287 (> calc-language-option
1)
288 (< calc-language-option -
1)))
289 (append '(vleft 0 "\\begin{pmatrix}")
290 (math-compose-tex-matrix (cdr a
) t
)
292 (append '(horiz "\\begin{pmatrix} ")
293 (math-compose-tex-matrix (cdr a
) t
)
294 '(" \\end{pmatrix}")))
295 (if (and (eq calc-language
'eqn
)
297 (append '(horiz "matrix { ")
298 (math-compose-eqn-matrix
299 (cdr (math-transpose a
)))
301 (if (and (eq calc-language
'maple
)
305 math-comp-left-bracket
306 (math-compose-vector (cdr a
)
307 (concat math-comp-comma
" ")
308 math-comp-vector-prec
)
309 math-comp-right-bracket
312 math-comp-left-bracket
313 (math-compose-vector (cdr a
)
314 (concat math-comp-comma
" ")
315 math-comp-vector-prec
)
316 math-comp-right-bracket
)))))
318 math-comp-left-bracket
319 (math-compose-vector (list (nth 1 a
) (nth 2 a
) (nth 3 a
))
320 (concat math-comp-comma
" ")
321 math-comp-vector-prec
)
322 math-comp-comma
(if (memq calc-language
'(tex latex
))
325 (list 'break math-compose-level
)
326 (math-compose-expr (nth (1- (length a
)) a
)
327 (if (equal math-comp-comma
"") 1000 0))
328 math-comp-right-bracket
)))))))
329 ((eq (car a
) 'incomplete
)
331 (cond ((eq (nth 1 a
) 'vec
)
333 (math-compose-vector (cdr (cdr a
)) ", " 0)
335 ((eq (nth 1 a
) 'cplx
)
337 (math-compose-vector (cdr (cdr a
)) ", " 0)
339 ((eq (nth 1 a
) 'polar
)
341 (math-compose-vector (cdr (cdr a
)) "; " 0)
343 ((eq (nth 1 a
) 'intv
)
345 (if (memq (nth 2 a
) '(0 1)) "(" "[")
346 (math-compose-vector (cdr (cdr (cdr a
))) " .. " 0)
349 (cond ((eq (nth 1 a
) 'vec
) "[ ...")
350 ((eq (nth 1 a
) 'intv
)
351 (if (memq (nth 2 a
) '(0 1)) "( ..." "[ ..."))
354 (let ((v (rassq (nth 2 a
) math-expr-variable-mapping
)))
356 (symbol-name (car v
))
357 (if (and (memq calc-language
'(tex latex
))
359 (not (= calc-language-option
0))
360 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
361 (symbol-name (nth 1 a
))))
362 (if (eq calc-language
'latex
)
363 (format "\\text{%s}" (symbol-name (nth 1 a
)))
364 (format "\\hbox{%s}" (symbol-name (nth 1 a
))))
365 (if (and math-compose-hash-args
366 (let ((p calc-arg-values
))
368 (while (and p
(not (equal (car p
) a
)))
369 (setq p
(and (eq math-compose-hash-args t
) (cdr p
))
372 (if (eq math-compose-hash-args
1)
375 (if (memq calc-language
'(c fortran pascal maple
))
376 (math-to-underscores (symbol-name (nth 1 a
)))
377 (if (and (eq calc-language
'eqn
)
378 (string-match ".'\\'" (symbol-name (nth 2 a
))))
380 (list 'calcFunc-Prime
383 (intern (substring (symbol-name (nth 1 a
)) 0 -
1))
384 (intern (substring (symbol-name (nth 2 a
)) 0 -
1))))
386 (symbol-name (nth 1 a
)))))))))
389 (if (eq calc-language
'maple
) ""
390 (if (memq (nth 1 a
) '(0 1)) "(" "["))
391 (math-compose-expr (nth 2 a
) 0)
392 (if (memq calc-language
'(tex latex
)) " \\ldots "
393 (if (eq calc-language
'eqn
) " ... " " .. "))
394 (math-compose-expr (nth 3 a
) 0)
395 (if (eq calc-language
'maple
) ""
396 (if (memq (nth 1 a
) '(0 2)) ")" "]"))))
398 (if (eq (car calc-date-format
) 'X
)
400 (concat "<" (math-format-date a
) ">")))
401 ((and (eq (car a
) 'calcFunc-subscr
) (cdr (cdr a
))
402 (memq calc-language
'(c pascal fortran maple
)))
403 (let ((args (cdr (cdr a
))))
404 (while (and (memq calc-language
'(pascal fortran
))
405 (eq (car-safe (nth 1 a
)) 'calcFunc-subscr
))
406 (setq args
(append (cdr (cdr (nth 1 a
))) args
)
409 (math-compose-expr (nth 1 a
) 1000)
410 (if (eq calc-language
'fortran
) "(" "[")
411 (math-compose-vector args
", " 0)
412 (if (eq calc-language
'fortran
) ")" "]"))))
413 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
414 (eq calc-language
'big
))
415 (let* ((a1 (math-compose-expr (nth 1 a
) 1000))
416 (calc-language 'flat
)
417 (a2 (math-compose-expr (nth 2 a
) 0)))
418 (if (or (eq (car-safe a1
) 'subscr
)
419 (and (eq (car-safe a1
) 'tag
)
420 (eq (car-safe (nth 2 a1
)) 'subscr
)
421 (setq a1
(nth 2 a1
))))
428 (list 'subscr a1 a2
))))
429 ((and (eq (car a
) 'calcFunc-subscr
) (= (length a
) 3)
430 (eq calc-language
'math
))
432 (math-compose-expr (nth 1 a
) 1000)
434 (math-compose-expr (nth 2 a
) 0)
436 ((and (eq (car a
) 'calcFunc-sqrt
)
437 (memq calc-language
'(tex latex
)))
440 (math-compose-expr (nth 1 a
) 0)
442 ((and nil
(eq (car a
) 'calcFunc-sqrt
)
443 (eq calc-language
'eqn
))
446 (math-compose-expr (nth 1 a
) -
1)
448 ((and (eq (car a
) '^
)
449 (eq calc-language
'big
))
451 (if (or (math-looks-negp (nth 1 a
))
452 (memq (car-safe (nth 1 a
)) '(^
/ frac calcFunc-sqrt
))
453 (and (eq (car-safe (nth 1 a
)) 'cplx
)
454 (math-negp (nth 1 (nth 1 a
)))
455 (eq (nth 2 (nth 1 a
)) 0)))
456 (list 'horiz
"(" (math-compose-expr (nth 1 a
) 0) ")")
457 (math-compose-expr (nth 1 a
) 201))
458 (let ((calc-language 'flat
)
459 (calc-number-radix 10))
460 (math-compose-expr (nth 2 a
) 0))))
461 ((and (eq (car a
) '/)
462 (eq calc-language
'big
))
463 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a
)) '(/ frac
))
465 (math-compose-expr (nth 1 a
) 0)))
466 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a
)) '(/ frac
))
468 (math-compose-expr (nth 2 a
) 0))))
470 (math-comp-height a1
)
472 ((and (memq (car a
) '(calcFunc-sum calcFunc-prod
))
473 (memq calc-language
'(tex latex
))
475 (list 'horiz
(if (eq (car a
) 'calcFunc-sum
) "\\sum" "\\prod")
476 "_{" (math-compose-expr (nth 2 a
) 0)
477 "=" (math-compose-expr (nth 3 a
) 0)
478 "}^{" (math-compose-expr (nth 4 a
) 0)
479 "}{" (math-compose-expr (nth 1 a
) 0) "}"))
480 ((and (eq (car a
) 'calcFunc-lambda
)
482 (memq calc-language
'(nil flat big
)))
485 (math-compose-hash-args (if (= (length a
) 3) 1 t
)))
486 (while (and (cdr p
) (equal (car p
) (car ap
)))
487 (setq p
(cdr p
) ap
(cdr ap
)))
490 (list (math-compose-vector
491 (nreverse (cdr (reverse (cdr a
)))) ", " 0)
494 (list (math-compose-expr (nth (1- (length a
)) a
) 0)
496 ((and (eq (car a
) 'calcFunc-string
)
498 (math-vectorp (nth 1 a
))
499 (math-vector-is-string (nth 1 a
)))
500 (if (eq calc-language
'unform
)
501 (concat "string(" (math-vector-to-string (nth 1 a
) t
) ")")
502 (math-vector-to-string (nth 1 a
) nil
)))
503 ((and (eq (car a
) 'calcFunc-bstring
)
505 (math-vectorp (nth 1 a
))
506 (math-vector-is-string (nth 1 a
)))
507 (if (eq calc-language
'unform
)
508 (concat "bstring(" (math-vector-to-string (nth 1 a
) t
) ")")
510 (s (math-vector-to-string (nth 1 a
) nil
))
512 (while (string-match "[^ ] +[^ ]" s
)
513 (setq p
(1- (match-end 0))
514 c
(cons (list 'break math-compose-level
)
515 (cons (substring s
0 p
)
518 (setq c
(nreverse (cons s c
)))
520 (setq c
(cons (list 'set math-compose-level
2) c
)))
522 ((and (eq (car a
) 'calcFunc-cprec
)
523 (not (eq calc-language
'unform
))
525 (integerp (nth 2 a
)))
526 (let ((c (math-compose-expr (nth 1 a
) -
1)))
527 (if (> prec
(nth 2 a
))
528 (if (memq calc-language
'(tex latex
))
529 (list 'horiz
"\\left( " c
" \\right)")
530 (if (eq calc-language
'eqn
)
531 (list 'horiz
"{left ( " c
" right )}")
532 (list 'horiz
"(" c
")")))
534 ((and (eq (car a
) 'calcFunc-choriz
)
535 (not (eq calc-language
'unform
))
536 (memq (length a
) '(2 3 4))
537 (math-vectorp (nth 1 a
))
538 (if (integerp (nth 2 a
))
540 (and (math-vectorp (nth 3 a
))
541 (math-vector-is-string (nth 3 a
))))
543 (and (math-vectorp (nth 2 a
))
544 (math-vector-is-string (nth 2 a
))))))
545 (let* ((cprec (and (integerp (nth 2 a
)) (nth 2 a
)))
546 (sep (nth (if cprec
3 2) a
))
549 (math-compose-vector (cdr (nth 1 a
))
550 (math-vector-to-string sep nil
)
552 (cons 'horiz
(mapcar (function
554 (if (eq (car-safe x
) 'calcFunc-bstring
)
557 x
(or bprec cprec prec
))
559 (math-compose-expr x
(or cprec prec
)))))
561 ((and (memq (car a
) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert
))
562 (not (eq calc-language
'unform
))
563 (memq (length a
) '(2 3))
564 (math-vectorp (nth 1 a
))
566 (integerp (nth 2 a
))))
569 (prec (or (nth 2 a
) prec
))
572 (let ((b nil
) (cc nil
) a d
)
573 (if (and (memq (car-safe x
) '(calcFunc-cbase
576 (memq (length x
) '(1 2)))
579 (if (and (eq (car-safe x
) 'calcFunc-crule
)
580 (memq (length x
) '(1 2))
582 (and (math-vectorp (nth 1 x
))
583 (= (length (nth 1 x
)) 2)
584 (math-vector-is-string
586 (and (natnump (nth 1 x
))
587 (<= (nth 1 x
) 255))))
590 (if (math-vectorp (nth 1 x
))
591 (aref (math-vector-to-string
594 (or (and (memq (car-safe x
) '(calcFunc-cvspace
597 (memq (length x
) '(2 3))
600 (setq cc
(math-compose-expr x prec
))))
601 (setq a
(if cc
(math-comp-ascent cc
) 0)
602 d
(if cc
(math-comp-descent cc
) 0))
603 (if (eq b
'calcFunc-cbase
)
604 (setq base
(+ v a -
1))
605 (if (eq b
'calcFunc-ctbase
)
607 (if (eq b
'calcFunc-cbbase
)
608 (setq base
(+ v a d -
1)))))
612 (setq c
(delq nil c
))
614 (cons (if (eq (car a
) 'calcFunc-cvert
) 'vcent
615 (if (eq (car a
) 'calcFunc-clvert
) 'vleft
'vright
))
618 ((and (memq (car a
) '(calcFunc-csup calcFunc-csub
))
619 (not (eq calc-language
'unform
))
620 (memq (length a
) '(3 4))
622 (integerp (nth 3 a
))))
623 (list (if (eq (car a
) 'calcFunc-csup
) 'supscr
'subscr
)
624 (math-compose-expr (nth 1 a
) (or (nth 3 a
) 0))
625 (math-compose-expr (nth 2 a
) 0)))
626 ((and (eq (car a
) 'calcFunc-cflat
)
627 (not (eq calc-language
'unform
))
628 (memq (length a
) '(2 3))
630 (integerp (nth 2 a
))))
631 (let ((calc-language (if (memq calc-language
'(nil big
))
632 'flat calc-language
)))
633 (math-compose-expr (nth 1 a
) (or (nth 2 a
) 0))))
634 ((and (eq (car a
) 'calcFunc-cspace
)
635 (memq (length a
) '(2 3))
638 (cons 'horiz
(make-list (nth 1 a
)
639 (if (and (math-vectorp (nth 2 a
))
640 (math-vector-is-string (nth 2 a
)))
641 (math-vector-to-string (nth 2 a
) nil
)
642 (math-compose-expr (nth 2 a
) 0))))
643 (make-string (nth 1 a
) ?\
)))
644 ((and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
645 (memq (length a
) '(2 3))
649 (let* ((c (if (nth 2 a
)
650 (if (and (math-vectorp (nth 2 a
))
651 (math-vector-is-string (nth 2 a
)))
652 (math-vector-to-string (nth 2 a
) nil
)
653 (math-compose-expr (nth 2 a
) 0))
655 (ca (math-comp-ascent c
))
656 (cd (math-comp-descent c
)))
658 (cons (if (eq (car a
) 'calcFunc-ctspace
)
660 (if (eq (car a
) 'calcFunc-cbspace
)
661 (+ (* (1- (nth 1 a
)) (+ ca cd
)) (1- ca
))
662 (/ (1- (* (nth 1 a
) (+ ca cd
))) 2)))
663 (make-list (nth 1 a
) c
))))))
664 ((and (eq (car a
) 'calcFunc-evalto
)
665 (setq calc-any-evaltos t
)
666 (memq calc-language
'(tex latex eqn
))
667 (= math-compose-level
(if math-comp-tagged
2 1))
670 (if (memq calc-language
'(tex latex
)) "\\evalto " "evalto ")
671 (math-compose-expr (nth 1 a
) 0)
672 (if (memq calc-language
'(tex latex
)) " \\to " " -> ")
673 (math-compose-expr (nth 2 a
) 0)))
675 (let ((op (and (not (eq calc-language
'unform
))
676 (if (and (eq (car a
) 'calcFunc-if
) (= (length a
) 4))
677 (assoc "?" math-expr-opers
)
678 (math-assq2 (car a
) math-expr-opers
)))))
680 (or (= (length a
) 3) (eq (car a
) 'calcFunc-if
))
683 ((> prec
(or (nth 4 op
) (min (nth 2 op
) (nth 3 op
))))
684 (if (and (memq calc-language
'(tex latex
))
685 (not (math-tex-expr-is-flat a
)))
686 (if (eq (car-safe a
) '/)
687 (list 'horiz
"{" (math-compose-expr a -
1) "}")
688 (list 'horiz
"\\left( "
689 (math-compose-expr a -
1)
691 (if (eq calc-language
'eqn
)
692 (if (or (eq (car-safe a
) '/)
694 (list 'horiz
"{" (math-compose-expr a -
1) "}")
695 (if (math-tex-expr-is-flat a
)
696 (list 'horiz
"( " (math-compose-expr a -
1) " )")
697 (list 'horiz
"{left ( "
698 (math-compose-expr a -
1)
700 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
701 ((and (memq calc-language
'(tex latex
))
702 (memq (car a
) '(/ calcFunc-choose calcFunc-evalto
))
704 (list 'horiz
"{" (math-compose-expr a -
1) "}"))
705 ((eq (car a
) 'calcFunc-if
)
707 (math-compose-expr (nth 1 a
) (nth 2 op
))
709 (math-compose-expr (nth 2 a
) 0)
711 (math-compose-expr (nth 3 a
) (nth 3 op
))))
713 (let* ((math-comp-tagged (and math-comp-tagged
716 (setlev (if (= prec
(min (nth 2 op
) (nth 3 op
)))
718 (setq math-compose-level
719 (1- math-compose-level
))
722 (lhs (math-compose-expr (nth 1 a
) (nth 2 op
)))
723 (rhs (math-compose-expr (nth 2 a
) (nth 3 op
))))
724 (and (equal (car op
) "^")
725 (eq (math-comp-first-char lhs
) ?-
)
726 (setq lhs
(list 'horiz
"(" lhs
")")))
727 (and (memq calc-language
'(tex latex
))
728 (or (equal (car op
) "^") (equal (car op
) "_"))
729 (not (and (stringp rhs
) (= (length rhs
) 1)))
730 (setq rhs
(list 'horiz
"{" rhs
"}")))
731 (or (and (eq (car a
) '*)
732 (or (null calc-language
)
733 (assoc "2x" math-expr-opers
))
734 (let* ((prevt (math-prod-last-term (nth 1 a
)))
735 (nextt (math-prod-first-term (nth 2 a
)))
736 (prevc (or (math-comp-last-char lhs
)
737 (and (memq (car-safe prevt
)
741 (eq calc-language
'big
)
743 (nextc (or (math-comp-first-char rhs
)
744 (and (memq (car-safe nextt
)
749 (eq calc-language
'big
)
752 (or (and (>= nextc ?a
) (<= nextc ?z
))
753 (and (>= nextc ?A
) (<= nextc ?Z
))
754 (and (>= nextc ?
0) (<= nextc ?
9))
755 (memq nextc
'(?. ?_ ?
#
760 (math-comp-first-string
762 (not (and (eq (car-safe prevt
) 'var
)
767 (list 'break math-compose-level
)
773 (list 'break math-compose-level
)
774 (if (or (equal (car op
) "^")
776 (equal (car op
) "**")
777 (and (equal (car op
) "*")
778 (math-comp-last-char lhs
)
779 (math-comp-first-char rhs
))
780 (and (equal (car op
) "/")
781 (math-num-integerp (nth 1 a
))
782 (math-integerp (nth 2 a
))))
784 (if (and (eq calc-language
'big
)
785 (equal (car op
) "=>"))
787 (concat " " (car op
) " ")))
789 ((and op
(= (length a
) 2) (= (nth 3 op
) -
1))
791 ((or (> prec
(or (nth 4 op
) (nth 2 op
)))
792 (and (not (eq (assoc (car op
) math-expr-opers
) op
))
793 (> prec
0))) ; don't write x% + y
794 (if (and (memq calc-language
'(tex latex
))
795 (not (math-tex-expr-is-flat a
)))
796 (list 'horiz
"\\left( "
797 (math-compose-expr a -
1)
799 (if (eq calc-language
'eqn
)
800 (if (= (/ prec
100) 9)
801 (list 'horiz
"{" (math-compose-expr a -
1) "}")
802 (if (math-tex-expr-is-flat a
)
803 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
804 (list 'horiz
"{left ( "
805 (math-compose-expr a -
1)
807 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
809 (let ((lhs (math-compose-expr (nth 1 a
) (nth 2 op
))))
812 (if (or (> (length (car op
)) 1)
813 (not (math-comp-is-flat lhs
)))
814 (concat " " (car op
))
816 ((and op
(= (length a
) 2) (= (nth 2 op
) -
1))
819 (let ((lr (and (memq calc-language
'(tex latex
))
820 (not (math-tex-expr-is-flat (nth 1 a
))))))
823 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op
))
824 (substring (car op
) 1)
826 (if (or lr
(> (length (car op
)) 2)) " " "")
827 (math-compose-expr (nth 1 a
) -
1)
828 (if (or lr
(> (length (car op
)) 2)) " " "")
830 (car (nth 1 (memq op math-expr-opers
))))))
831 ((> prec
(or (nth 4 op
) (nth 3 op
)))
832 (if (and (memq calc-language
'(tex latex
))
833 (not (math-tex-expr-is-flat a
)))
834 (list 'horiz
"\\left( "
835 (math-compose-expr a -
1)
837 (if (eq calc-language
'eqn
)
838 (if (= (/ prec
100) 9)
839 (list 'horiz
"{" (math-compose-expr a -
1) "}")
840 (if (math-tex-expr-is-flat a
)
841 (list 'horiz
"{( " (math-compose-expr a -
1) " )}")
842 (list 'horiz
"{left ( "
843 (math-compose-expr a -
1)
845 (list 'horiz
"(" (math-compose-expr a
0) ")"))))
847 (let ((rhs (math-compose-expr (nth 1 a
) (nth 3 op
))))
849 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
851 (substring (car op
) 1)
853 (if (or (> (length ops
) 1)
854 (not (math-comp-is-flat rhs
)))
858 ((and (eq calc-language
'big
)
859 (setq op
(get (car a
) 'math-compose-big
))
860 (funcall op a prec
)))
861 ((and (setq op
(assq calc-language
862 '( ( nil . math-compose-normal
)
863 ( flat . math-compose-normal
)
864 ( big . math-compose-normal
)
865 ( c . math-compose-c
)
866 ( pascal . math-compose-pascal
)
867 ( fortran . math-compose-fortran
)
868 ( tex . math-compose-tex
)
869 ( latex . math-compose-latex
)
870 ( eqn . math-compose-eqn
)
871 ( math . math-compose-math
)
872 ( maple . math-compose-maple
))))
873 (setq op
(get (car a
) (cdr op
)))
874 (funcall op a prec
)))
876 (let* ((func (car a
))
877 (func2 (assq func
'(( mod . calcFunc-makemod
)
878 ( sdev . calcFunc-sdev
)
885 ( neg . calcFunc-neg
)
886 ( | . calcFunc-vconcat
))))
889 (setq func
(cdr func2
)))
890 (if (setq func2
(rassq func math-expr-function-mapping
))
891 (setq func
(car func2
)))
892 (setq func
(math-remove-dashes
894 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
896 (math-match-substring (symbol-name func
) 1)
897 (symbol-name func
))))
898 (if (memq calc-language
'(c fortran pascal maple
))
899 (setq func
(math-to-underscores func
)))
900 (if (and (memq calc-language
'(tex latex
))
902 (not (= calc-language-option
0))
903 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func
))
904 (if (< (prefix-numeric-value calc-language-option
) 0)
905 (setq func
(format "\\%s" func
))
906 (setq func
(if (eq calc-language
'latex
)
907 (format "\\text{%s}" func
)
908 (format "\\hbox{%s}" func
)))))
909 (if (and (eq calc-language
'eqn
)
910 (string-match "[^']'+\\'" func
))
911 (let ((n (- (length func
) (match-beginning 0) 1)))
912 (setq func
(substring func
0 (- n
)))
913 (while (>= (setq n
(1- n
)) 0)
914 (setq func
(concat func
" prime")))))
915 (cond ((and (memq calc-language
'(tex latex
))
917 (not (math-tex-expr-is-flat (nth 1 a
)))))
918 (setq left
"\\left( "
920 ((and (eq calc-language
'eqn
)
922 (not (math-tex-expr-is-flat (nth 1 a
)))))
923 (setq left
"{left ( "
925 ((and (or (and (memq calc-language
'(tex latex
))
926 (eq (aref func
0) ?
\\))
927 (and (eq calc-language
'eqn
)
928 (memq (car a
) math-eqn-special-funcs
)))
930 (string-match "\\hbox{" func
)
931 (string-match "\\text{" func
)))
933 (or (Math-realp (nth 1 a
))
934 (memq (car (nth 1 a
)) '(var *))))
935 (setq left
(if (eq calc-language
'eqn
) "~{" "{")
937 ((eq calc-language
'eqn
)
940 (t (setq left calc-function-open
941 right calc-function-close
)))
942 (list 'horiz func left
943 (math-compose-vector (cdr a
)
944 (if (eq calc-language
'eqn
)
950 (defun math-prod-first-term (x)
951 (while (eq (car-safe x
) '*)
955 (defun math-prod-last-term (x)
956 (while (eq (car-safe x
) '*)
960 (defun math-compose-vector (a sep prec
)
963 (cons (list 'set math-compose-level
)
964 (let ((c (list (math-compose-expr (car a
) prec
))))
965 (while (setq a
(cdr a
))
966 (setq c
(cons (if (eq (car-safe (car a
))
968 (let ((math-compose-level
969 (1- math-compose-level
)))
970 (math-compose-expr (car a
) -
123))
971 (math-compose-expr (car a
) prec
))
972 (cons (list 'break math-compose-level
)
977 (defun math-vector-no-parens (a)
979 (not (eq (car-safe (nth 1 a
)) '*))))
981 (defun math-compose-matrix (a col cols base
)
984 (while (<= (setq col
(1+ col
)) cols
)
985 (setq res
(cons (cons math-comp-just
992 math-comp-vector-prec
)
996 math-comp-comma-spc
" ")))))
1001 (defun math-compose-rows (a count first
)
1005 (math-compose-rows (cdr a
) -
1 nil
)
1006 (cons (concat (if (memq calc-language
'(tex latex
)) " \\ldots" " ...")
1008 (math-compose-rows (cdr a
) -
1 nil
)))
1010 (if first
(concat math-comp-left-bracket
" ") " ")
1011 (math-compose-expr (car a
) math-comp-vector-prec
)
1013 (math-compose-rows (cdr a
) (1- count
) nil
)))
1015 (if first
(concat math-comp-left-bracket
" ") " ")
1016 (math-compose-expr (car a
) math-comp-vector-prec
)
1017 (concat " " math-comp-right-bracket
)))))
1019 (defun math-compose-tex-matrix (a &optional ltx
)
1021 (cons (append (math-compose-vector (cdr (car a
)) " & " 0)
1022 (if ltx
'(" \\\\ ") '(" \\cr ")))
1023 (math-compose-tex-matrix (cdr a
) ltx
))
1024 (list (math-compose-vector (cdr (car a
)) " & " 0))))
1026 (defun math-compose-eqn-matrix (a)
1029 (cond ((eq calc-matrix-just
'right
) "rcol ")
1030 ((eq calc-matrix-just
'center
) "ccol ")
1033 (list 'break math-compose-level
)
1037 (let ((math-compose-level (1+ math-compose-level
)))
1038 (math-compose-vector (cdr (car a
)) " above " 1000))
1041 (math-compose-eqn-matrix (cdr a
)))))))
1044 (defun math-vector-is-string (a)
1045 (while (and (setq a
(cdr a
))
1046 (or (and (natnump (car a
))
1048 (and (eq (car-safe (car a
)) 'cplx
)
1049 (natnump (nth 1 (car a
)))
1050 (eq (nth 2 (car a
)) 0)
1051 (<= (nth 1 (car a
)) 255)))))
1054 (defconst math-vector-to-string-chars
'( ( ?
\" .
"\\\"" )
1065 (defun math-vector-to-string (a &optional quoted
)
1066 (setq a
(concat (mapcar (function (lambda (x) (if (consp x
) (nth 1 x
) x
)))
1068 (if (string-match "[\000-\037\177\\\"]" a
)
1070 (pat (if quoted
"[\000-\037\177\\\"]" "[\000-\037\177]"))
1071 (codes (if quoted math-vector-to-string-chars
'((?\^? .
"^?"))))
1072 (fmt (if quoted
"\\^%c" "^%c"))
1074 (while (setq p
(string-match pat a p
))
1075 (if (setq new
(assq (aref a p
) codes
))
1076 (setq a
(concat (substring a
0 p
)
1078 (substring a
(1+ p
)))
1079 p
(+ p
(length (cdr new
))))
1080 (setq a
(concat (substring a
0 p
)
1081 (format fmt
(+ (aref a p
) 64))
1082 (substring a
(1+ p
)))
1085 (concat "\"" a
"\"")
1089 (defun math-to-underscores (x)
1090 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x
)
1091 (math-to-underscores
1092 (concat (math-match-substring x
1) "_" (math-match-substring x
2)))
1095 (defun math-tex-expr-is-flat (a)
1096 (or (Math-integerp a
)
1097 (memq (car a
) '(float var
))
1098 (and (memq (car a
) '(+ -
* neg
))
1100 (while (and (setq a
(cdr a
))
1101 (math-tex-expr-is-flat (car a
))))
1103 (and (memq (car a
) '(^ calcFunc-subscr
))
1104 (math-tex-expr-is-flat (nth 1 a
)))))
1106 (put 'calcFunc-log
'math-compose-big
'math-compose-log
)
1107 (defun math-compose-log (a prec
)
1108 (and (= (length a
) 3)
1111 (let ((calc-language 'flat
))
1112 (math-compose-expr (nth 2 a
) 1000)))
1114 (math-compose-expr (nth 1 a
) 1000)
1117 (put 'calcFunc-log10
'math-compose-big
'math-compose-log10
)
1118 (defun math-compose-log10 (a prec
)
1119 (and (= (length a
) 2)
1121 (list 'subscr
"log" "10")
1123 (math-compose-expr (nth 1 a
) 1000)
1126 (put 'calcFunc-deriv
'math-compose-big
'math-compose-deriv
)
1127 (put 'calcFunc-tderiv
'math-compose-big
'math-compose-deriv
)
1128 (defun math-compose-deriv (a prec
)
1129 (when (= (length a
) 3)
1130 (math-compose-expr (list '/
1131 (list 'calcFunc-choriz
1133 '(calcFunc-string (vec ?d
))
1135 (list 'calcFunc-choriz
1137 '(calcFunc-string (vec ?d
))
1141 (put 'calcFunc-sqrt
'math-compose-big
'math-compose-sqrt
)
1142 (defun math-compose-sqrt (a prec
)
1143 (when (= (length a
) 2)
1144 (let* ((c (math-compose-expr (nth 1 a
) 0))
1145 (a (math-comp-ascent c
))
1146 (d (math-comp-descent c
))
1148 (w (math-comp-width c
)))
1151 (concat (if (= h
1) " " " ")
1152 (make-string (+ w
2) ?\_
))
1156 (append (list 'vleft
(1- a
))
1157 (make-list (1- h
) " |")
1162 (put 'calcFunc-choose
'math-compose-big
'math-compose-choose
)
1163 (defun math-compose-choose (a prec
)
1164 (let ((a1 (math-compose-expr (nth 1 a
) 0))
1165 (a2 (math-compose-expr (nth 2 a
) 0)))
1169 (math-comp-height a1
)
1173 (put 'calcFunc-integ
'math-compose-big
'math-compose-integ
)
1174 (defun math-compose-integ (a prec
)
1175 (and (memq (length a
) '(3 5))
1176 (eq (car-safe (nth 2 a
)) 'var
)
1177 (let* ((parens (and (>= prec
196) (/= prec
1000)))
1178 (var (math-compose-expr (nth 2 a
) 0))
1179 (over (and (eq (car-safe (nth 2 a
)) 'var
)
1180 (or (and (eq (car-safe (nth 1 a
)) '/)
1181 (math-numberp (nth 1 (nth 1 a
))))
1182 (and (eq (car-safe (nth 1 a
)) '^
)
1183 (math-looks-negp (nth 2 (nth 1 a
)))))))
1184 (expr (math-compose-expr (if over
1186 (math-build-var-name
1189 (nth 1 (nth 2 a
)))))
1191 (calc-language 'flat
)
1192 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1193 (high (and (nth 4 a
) (math-compose-expr (nth 4 a
) 0))))
1196 (append (list 'vcent
(if high
3 2))
1197 (and high
(list (list 'horiz
" " high
)))
1203 (and low
(list (list 'horiz low
" "))))
1207 (list 'horiz
" d" var
))
1208 (if parens
")" "")))))
1210 (put 'calcFunc-sum
'math-compose-big
'math-compose-sum
)
1211 (defun math-compose-sum (a prec
)
1212 (and (memq (length a
) '(3 5 6))
1213 (let* ((expr (math-compose-expr (nth 1 a
) 185))
1214 (calc-language 'flat
)
1215 (var (math-compose-expr (nth 2 a
) 0))
1216 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1217 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1219 (if (memq prec
'(180 201)) "(" "")
1220 (append (list 'vcent
(if high
3 2))
1221 (and high
(list high
))
1228 (list (list 'horiz var
" = " low
))
1230 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1233 (if (memq prec
'(180 201)) ")" "")))))
1235 (put 'calcFunc-prod
'math-compose-big
'math-compose-prod
)
1236 (defun math-compose-prod (a prec
)
1237 (and (memq (length a
) '(3 5 6))
1238 (let* ((expr (math-compose-expr (nth 1 a
) 198))
1239 (calc-language 'flat
)
1240 (var (math-compose-expr (nth 2 a
) 0))
1241 (low (and (nth 3 a
) (math-compose-expr (nth 3 a
) 0)))
1242 (high (and (nth 4 a
) (math-compose-vector (nthcdr 4 a
) ", " 0))))
1244 (if (memq prec
'(196 201)) "(" "")
1245 (append (list 'vcent
(if high
3 2))
1246 (and high
(list high
))
1252 (list (list 'horiz var
" = " low
))
1254 (if (memq (car-safe (nth 1 a
)) '(calcFunc-sum calcFunc-prod
))
1257 (if (memq prec
'(196 201)) ")" "")))))
1259 ;; The variables math-svo-c, math-svo-wid and math-svo-off are local
1260 ;; to math-stack-value-offset in calc.el, but are used by
1261 ;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
1263 (defvar math-svo-wid
)
1264 (defvar math-svo-off
)
1266 (defun math-stack-value-offset-fancy ()
1267 (let ((cwid (+ (math-comp-width math-svo-c
))))
1268 (cond ((eq calc-display-just
'right
)
1269 (if calc-display-origin
1270 (setq math-svo-wid
(max calc-display-origin
5))
1271 (if (integerp calc-line-breaking
)
1272 (setq math-svo-wid calc-line-breaking
)))
1273 (setq math-svo-off
(- math-svo-wid cwid
1274 (max (- (length calc-right-label
)
1275 (if (and (integerp calc-line-breaking
)
1276 calc-display-origin
)
1277 (max (- calc-line-breaking
1278 calc-display-origin
)
1283 (if calc-display-origin
1285 (setq math-svo-off
(- calc-display-origin
(/ cwid
2)))
1286 (if (integerp calc-line-breaking
)
1287 (setq math-svo-off
(min math-svo-off
(- calc-line-breaking cwid
1288 (length calc-right-label
)))))
1289 (if (>= math-svo-off
0)
1290 (setq math-svo-wid
(max math-svo-wid
(+ math-svo-off cwid
)))))
1291 (if (integerp calc-line-breaking
)
1292 (setq math-svo-wid calc-line-breaking
))
1293 (setq math-svo-off
(/ (- math-svo-wid cwid
) 2)))))
1294 (and (integerp calc-line-breaking
)
1295 (or (< math-svo-off
0)
1296 (and calc-display-origin
1297 (> calc-line-breaking calc-display-origin
)))
1298 (setq math-svo-wid calc-line-breaking
))))
1301 ;;; Convert a composition to string form, with embedded \n's if necessary.
1303 (defun math-composition-to-string (c &optional width
)
1304 (or width
(setq width
(calc-window-width)))
1305 (if calc-display-raw
1306 (math-comp-to-string-raw c
0)
1307 (if (math-comp-is-flat c
)
1308 (math-comp-to-string-flat c width
)
1309 (math-vert-comp-to-string
1310 (math-comp-simplify c width
)))))
1312 (defvar math-comp-buf-string
(make-vector 10 ""))
1313 (defvar math-comp-buf-margin
(make-vector 10 0))
1314 (defvar math-comp-buf-level
(make-vector 10 0))
1315 (defun math-comp-is-flat (c) ; check if c's height is 1.
1316 (cond ((not (consp c
)) t
)
1317 ((memq (car c
) '(set break
)) t
)
1318 ((eq (car c
) 'horiz
)
1319 (while (and (setq c
(cdr c
))
1320 (math-comp-is-flat (car c
))))
1322 ((memq (car c
) '(vleft vcent vright
))
1323 (and (= (length c
) 3)
1325 (math-comp-is-flat (nth 2 c
))))
1327 (math-comp-is-flat (nth 2 c
)))
1331 ;;; Convert a one-line composition to a string. Break into multiple
1332 ;;; lines if necessary, choosing break points according to the structure
1335 ;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
1336 ;; math-comp-level, math-comp-margin and math-comp-buf are local to
1337 ;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
1338 ;; which is called by math-comp-to-string-flat.
1339 ;; math-comp-highlight and math-comp-buf are also local to
1340 ;; math-comp-simplify-term and math-comp-simplify respectively, but are used
1341 ;; by math-comp-add-string.
1342 (defvar math-comp-full-width
)
1343 (defvar math-comp-highlight
)
1344 (defvar math-comp-word
)
1345 (defvar math-comp-level
)
1346 (defvar math-comp-margin
)
1347 (defvar math-comp-buf
)
1348 ;; The variable math-comp-pos is local to math-comp-to-string-flat, but
1349 ;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
1350 ;; which are called by math-comp-to-string-flat.
1351 (defvar math-comp-pos
)
1353 (defun math-comp-to-string-flat (c math-comp-full-width
)
1354 (if math-comp-sel-hpos
1355 (let ((math-comp-pos 0))
1356 (math-comp-sel-flat-term c
))
1357 (let ((math-comp-buf "")
1360 (math-comp-margin 0)
1361 (math-comp-highlight (and math-comp-selected calc-show-selections
))
1362 (math-comp-level -
1))
1363 (math-comp-to-string-flat-term '(set -
1 0))
1364 (math-comp-to-string-flat-term c
)
1365 (math-comp-to-string-flat-term '(break -
1))
1366 (let ((str (aref math-comp-buf-string
0))
1368 (and (> (length str
) 0) (= (aref str
0) ?
)
1369 (> (length math-comp-buf
) 0)
1370 (let ((k (length math-comp-buf
)))
1371 (while (not (= (aref math-comp-buf
(setq k
(1- k
))) ?
\n)))
1372 (aset math-comp-buf k ?
)
1373 (if (and (< (1+ k
) (length math-comp-buf
))
1374 (= (aref math-comp-buf
(1+ k
)) ?
))
1376 (aset math-comp-buf
(1+ k
) ?
\n)
1378 (setq prefix
"\n"))))
1379 (concat math-comp-buf prefix str
)))))
1381 (defun math-comp-to-string-flat-term (c)
1382 (cond ((not (consp c
))
1383 (if math-comp-highlight
1384 (setq c
(math-comp-highlight-string c
)))
1385 (setq math-comp-word
(if (= (length math-comp-word
) 0) c
1386 (concat math-comp-word c
))
1387 math-comp-pos
(+ math-comp-pos
(length c
))))
1389 ((eq (car c
) 'horiz
)
1390 (while (setq c
(cdr c
))
1391 (math-comp-to-string-flat-term (car c
))))
1396 (setq math-comp-level
(1+ math-comp-level
))
1397 (if (>= math-comp-level
(length math-comp-buf-string
))
1398 (setq math-comp-buf-string
(vconcat math-comp-buf-string
1399 math-comp-buf-string
)
1400 math-comp-buf-margin
(vconcat math-comp-buf-margin
1401 math-comp-buf-margin
)
1402 math-comp-buf-level
(vconcat math-comp-buf-level
1403 math-comp-buf-level
)))
1404 (aset math-comp-buf-string math-comp-level
"")
1405 (aset math-comp-buf-margin math-comp-level
(+ math-comp-pos
1407 (aset math-comp-buf-level math-comp-level
(nth 1 c
)))))
1409 ((eq (car c
) 'break
)
1410 (if (not calc-line-breaking
)
1411 (setq math-comp-buf
(concat math-comp-buf math-comp-word
)
1414 (if (and (> math-comp-pos math-comp-full-width
)
1417 (setq str
(aref math-comp-buf-string i
))
1418 (and (= (length str
) 0) (< i math-comp-level
)))
1420 (or (> (length str
) 0) (> (length math-comp-buf
) 0))))
1421 (let ((prefix "") mrg wid
)
1422 (setq mrg
(aref math-comp-buf-margin i
))
1423 (if (> mrg
12) ; indenting too far, go back to far left
1424 (let ((j i
) (new (if calc-line-numbering
5 1)))
1425 '(while (<= j math-comp-level
)
1426 (aset math-comp-buf-margin j
1427 (+ (aref math-comp-buf-margin j
) (- new mrg
)))
1430 (setq wid
(+ (length str
) math-comp-margin
))
1431 (and (> (length str
) 0) (= (aref str
0) ?
)
1432 (> (length math-comp-buf
) 0)
1433 (let ((k (length math-comp-buf
)))
1434 (while (not (= (aref math-comp-buf
(setq k
(1- k
))) ?
\n)))
1435 (aset math-comp-buf k ?
)
1436 (if (and (< (1+ k
) (length math-comp-buf
))
1437 (= (aref math-comp-buf
(1+ k
)) ?
))
1439 (aset math-comp-buf
(1+ k
) ?
\n)
1441 (setq prefix
"\n"))))
1442 (setq math-comp-buf
(concat math-comp-buf prefix str
"\n"
1443 (make-string mrg ?
))
1444 math-comp-pos
(+ math-comp-pos
(- mrg wid
))
1445 math-comp-margin mrg
)
1446 (aset math-comp-buf-string i
"")
1447 (while (<= (setq i
(1+ i
)) math-comp-level
)
1448 (if (> (aref math-comp-buf-margin i
) wid
)
1449 (aset math-comp-buf-margin i
1450 (+ (aref math-comp-buf-margin i
)
1452 (if (and (= (nth 1 c
) (aref math-comp-buf-level math-comp-level
))
1453 (< math-comp-pos
(+ (aref math-comp-buf-margin math-comp-level
) 2)))
1454 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
1455 (let ((str (aref math-comp-buf-string math-comp-level
)))
1456 (setq str
(if (= (length str
) 0)
1458 (concat str math-comp-word
))
1460 (while (< (nth 1 c
) (aref math-comp-buf-level math-comp-level
))
1461 (setq math-comp-level
(1- math-comp-level
))
1462 (or (= (length (aref math-comp-buf-string math-comp-level
)) 0)
1463 (setq str
(concat (aref math-comp-buf-string math-comp-level
)
1465 (aset math-comp-buf-string math-comp-level str
)))))
1468 (cond ((eq (nth 1 c
) math-comp-selected
)
1469 (let ((math-comp-highlight (not calc-show-selections
)))
1470 (math-comp-to-string-flat-term (nth 2 c
))))
1472 (let ((math-comp-highlight nil
))
1473 (math-comp-to-string-flat-term (nth 2 c
))))
1474 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1476 (t (math-comp-to-string-flat-term (nth 2 c
)))))
1478 (defun math-comp-highlight-string (s)
1479 (setq s
(copy-sequence s
))
1480 (let ((i (length s
)))
1481 (while (>= (setq i
(1- i
)) 0)
1482 (or (memq (aref s i
) '(32 ?
\n))
1483 (aset s i
(if calc-show-selections ?\. ?\
#)))))
1487 ;; The variable math-comp-sel-tag is local to calc-find-selected-part
1488 ;; in calc-sel.el, but is used by math-comp-sel-flat-term and
1489 ;; math-comp-add-string-sel, which are called (indirectly) by
1490 ;; calc-find-selected-part.
1491 (defvar math-comp-sel-tag
)
1493 (defun math-comp-sel-flat-term (c)
1494 (cond ((not (consp c
))
1495 (setq math-comp-pos
(+ math-comp-pos
(length c
))))
1496 ((memq (car c
) '(set break
)))
1497 ((eq (car c
) 'horiz
)
1498 (while (and (setq c
(cdr c
)) (< math-comp-sel-cpos
1000000))
1499 (math-comp-sel-flat-term (car c
))))
1501 (if (<= math-comp-pos math-comp-sel-cpos
)
1503 (math-comp-sel-flat-term (nth 2 c
))
1504 (if (> math-comp-pos math-comp-sel-cpos
)
1505 (setq math-comp-sel-tag c
1506 math-comp-sel-cpos
1000000)))
1507 (math-comp-sel-flat-term (nth 2 c
))))
1508 (t (math-comp-sel-flat-term (nth 2 c
)))))
1511 ;;; Simplify a composition to a canonical form consisting of
1512 ;;; (vleft n "string" "string" "string" ...)
1513 ;;; where 0 <= n < number-of-strings.
1515 ;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
1516 ;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
1517 ;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
1518 ;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
1519 ;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
1520 ;; math-comp-simplify.
1521 (defvar math-comp-base
)
1522 (defvar math-comp-hgt
)
1523 (defvar math-comp-tag
)
1524 (defvar math-comp-hpos
)
1525 (defvar math-comp-vpos
)
1527 (defun math-comp-simplify (c full-width
)
1528 (let ((math-comp-buf (list ""))
1533 (math-comp-highlight (and math-comp-selected calc-show-selections
))
1534 (math-comp-tag nil
))
1535 (math-comp-simplify-term c
)
1536 (cons 'vleft
(cons math-comp-base math-comp-buf
))))
1538 (defun math-comp-add-string (s h v
)
1539 (and (> (length s
) 0)
1540 (let ((vv (+ v math-comp-base
)))
1541 (if math-comp-sel-hpos
1542 (math-comp-add-string-sel h vv
(length s
) 1)
1544 (setq math-comp-buf
(nconc (make-list (- vv
) "") math-comp-buf
)
1545 math-comp-base
(- v
)
1546 math-comp-hgt
(- math-comp-hgt vv
)
1548 (if (>= vv math-comp-hgt
)
1549 (setq math-comp-buf
(nconc math-comp-buf
1550 (make-list (1+ (- vv math-comp-hgt
)) ""))
1551 math-comp-hgt
(1+ vv
))))
1552 (let ((str (nthcdr vv math-comp-buf
)))
1553 (setcar str
(concat (car str
)
1554 (make-string (- h
(length (car str
))) 32)
1555 (if math-comp-highlight
1556 (math-comp-highlight-string s
)
1559 (defun math-comp-add-string-sel (x y w h
)
1560 (if (and (<= y math-comp-sel-vpos
)
1561 (> (+ y h
) math-comp-sel-vpos
)
1562 (<= x math-comp-sel-hpos
)
1563 (> (+ x w
) math-comp-sel-hpos
))
1564 (setq math-comp-sel-tag math-comp-tag
1565 math-comp-sel-vpos
10000)))
1567 (defun math-comp-simplify-term (c)
1569 (math-comp-add-string c math-comp-hpos math-comp-vpos
)
1570 (setq math-comp-hpos
(+ math-comp-hpos
(length c
))))
1571 ((memq (car c
) '(set break
))
1573 ((eq (car c
) 'horiz
)
1574 (while (setq c
(cdr c
))
1575 (math-comp-simplify-term (car c
))))
1576 ((memq (car c
) '(vleft vcent vright
))
1577 (let* ((math-comp-vpos (+ (- math-comp-vpos
(nth 1 c
))
1578 (1- (math-comp-ascent (nth 2 c
)))))
1579 (widths (mapcar 'math-comp-width
(cdr (cdr c
))))
1580 (maxwid (apply 'max widths
))
1581 (bias (cond ((eq (car c
) 'vleft
) 0)
1582 ((eq (car c
) 'vcent
) 1)
1585 (while (setq c
(cdr c
))
1586 (if (eq (car-safe (car c
)) 'rule
)
1587 (math-comp-add-string (make-string maxwid
(nth 1 (car c
)))
1588 math-comp-hpos math-comp-vpos
)
1589 (let ((math-comp-hpos (+ math-comp-hpos
(/ (* bias
(- maxwid
1592 (math-comp-simplify-term (car c
))))
1594 (setq math-comp-vpos
(+ math-comp-vpos
1595 (+ (math-comp-descent (car c
))
1596 (math-comp-ascent (nth 1 c
))))
1597 widths
(cdr widths
))))
1598 (setq math-comp-hpos
(+ math-comp-hpos maxwid
))))
1599 ((eq (car c
) 'supscr
)
1600 (let* ((asc (or 1 (math-comp-ascent (nth 1 c
))))
1601 (desc (math-comp-descent (nth 2 c
)))
1604 (math-comp-simplify-term (nth 1 c
))))
1605 (math-comp-vpos (- math-comp-vpos
(+ asc desc
))))
1606 (math-comp-simplify-term (nth 2 c
))
1607 (if math-comp-sel-hpos
1608 (math-comp-add-string-sel oldh
1611 (math-comp-ascent (nth 2 c
)))
1612 (- math-comp-hpos oldh
)
1613 (math-comp-height c
)))))
1614 ((eq (car c
) 'subscr
)
1615 (let* ((asc (math-comp-ascent (nth 2 c
)))
1616 (desc (math-comp-descent (nth 1 c
)))
1617 (oldv math-comp-vpos
)
1620 (math-comp-simplify-term (nth 1 c
))))
1621 (math-comp-vpos (+ math-comp-vpos
(+ asc desc
))))
1622 (math-comp-simplify-term (nth 2 c
))
1623 (if math-comp-sel-hpos
1624 (math-comp-add-string-sel oldh oldv
1625 (- math-comp-hpos oldh
)
1626 (math-comp-height c
)))))
1628 (cond ((eq (nth 1 c
) math-comp-selected
)
1629 (let ((math-comp-highlight (not calc-show-selections
)))
1630 (math-comp-simplify-term (nth 2 c
))))
1632 (let ((math-comp-highlight nil
))
1633 (math-comp-simplify-term (nth 2 c
))))
1634 (t (let ((math-comp-tag c
))
1635 (math-comp-simplify-term (nth 2 c
))))))))
1638 ;;; Measuring a composition.
1640 (defun math-comp-first-char (c)
1642 (and (> (length c
) 0)
1644 ((memq (car c
) '(horiz subscr supscr
))
1645 (while (and (setq c
(cdr c
))
1646 (math-comp-is-null (car c
))))
1647 (and c
(math-comp-first-char (car c
))))
1649 (math-comp-first-char (nth 2 c
)))))
1651 (defun math-comp-first-string (c)
1653 (and (> (length c
) 0)
1655 ((eq (car c
) 'horiz
)
1656 (while (and (setq c
(cdr c
))
1657 (math-comp-is-null (car c
))))
1658 (and c
(math-comp-first-string (car c
))))
1660 (math-comp-first-string (nth 2 c
)))))
1662 (defun math-comp-last-char (c)
1664 (and (> (length c
) 0)
1665 (elt c
(1- (length c
)))))
1666 ((eq (car c
) 'horiz
)
1667 (let ((c (reverse (cdr c
))))
1668 (while (and c
(math-comp-is-null (car c
)))
1670 (and c
(math-comp-last-char (car c
)))))
1672 (math-comp-last-char (nth 2 c
)))))
1674 (defun math-comp-is-null (c)
1675 (cond ((stringp c
) (= (length c
) 0))
1676 ((memq (car c
) '(horiz subscr supscr
))
1677 (while (and (setq c
(cdr c
))
1678 (math-comp-is-null (car c
))))
1681 (math-comp-is-null (nth 2 c
)))
1682 ((memq (car c
) '(set break
)) t
)))
1684 (defun math-comp-width (c)
1685 (cond ((not (consp c
)) (length c
))
1686 ((memq (car c
) '(horiz subscr supscr
))
1688 (while (setq c
(cdr c
))
1689 (setq accum
(+ accum
(math-comp-width (car c
)))))
1691 ((memq (car c
) '(vcent vleft vright
))
1694 (while (setq c
(cdr c
))
1695 (setq accum
(max accum
(math-comp-width (car c
)))))
1698 (math-comp-width (nth 2 c
)))
1701 (defun math-comp-height (c)
1704 (+ (math-comp-ascent c
) (math-comp-descent c
))))
1706 (defun math-comp-ascent (c)
1707 (cond ((not (consp c
)) 1)
1708 ((eq (car c
) 'horiz
)
1710 (while (setq c
(cdr c
))
1711 (setq accum
(max accum
(math-comp-ascent (car c
)))))
1713 ((memq (car c
) '(vcent vleft vright
))
1714 (if (> (nth 1 c
) 0) (1+ (nth 1 c
)) 1))
1715 ((eq (car c
) 'supscr
)
1716 (max (math-comp-ascent (nth 1 c
)) (1+ (math-comp-height (nth 2 c
)))))
1717 ((eq (car c
) 'subscr
)
1718 (math-comp-ascent (nth 1 c
)))
1720 (math-comp-ascent (nth 2 c
)))
1723 (defun math-comp-descent (c)
1724 (cond ((not (consp c
)) 0)
1725 ((eq (car c
) 'horiz
)
1727 (while (setq c
(cdr c
))
1728 (setq accum
(max accum
(math-comp-descent (car c
)))))
1730 ((memq (car c
) '(vcent vleft vright
))
1731 (let ((accum (- (nth 1 c
))))
1733 (while (setq c
(cdr c
))
1734 (setq accum
(+ accum
(math-comp-height (car c
)))))
1735 (max (1- accum
) 0)))
1736 ((eq (car c
) 'supscr
)
1737 (math-comp-descent (nth 1 c
)))
1738 ((eq (car c
) 'subscr
)
1739 (+ (math-comp-descent (nth 1 c
)) (math-comp-height (nth 2 c
))))
1741 (math-comp-descent (nth 2 c
)))
1744 (defun calcFunc-cwidth (a &optional prec
)
1745 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1746 (math-comp-width (math-compose-expr a
(or prec
0))))
1748 (defun calcFunc-cheight (a &optional prec
)
1749 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1750 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1751 (memq (length a
) '(2 3))
1754 (math-comp-height (math-compose-expr a
(or prec
0)))))
1756 (defun calcFunc-cascent (a &optional prec
)
1757 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1758 (if (and (memq (car a
) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace
))
1759 (memq (length a
) '(2 3))
1762 (math-comp-ascent (math-compose-expr a
(or prec
0)))))
1764 (defun calcFunc-cdescent (a &optional prec
)
1765 (if (and prec
(not (integerp prec
))) (math-reject-arg prec
'fixnump
))
1766 (math-comp-descent (math-compose-expr a
(or prec
0))))
1769 ;;; Convert a simplified composition into string form.
1771 (defun math-vert-comp-to-string (c)
1774 (math-vert-comp-to-string-step (cdr (cdr c
)))))
1776 (defun math-vert-comp-to-string-step (c)
1778 (concat (car c
) "\n" (math-vert-comp-to-string-step (cdr c
)))
1782 ;;; Convert a composition to a string in "raw" form (for debugging).
1784 (defun math-comp-to-string-raw (c indent
)
1785 (cond ((or (not (consp c
)) (eq (car c
) 'set
))
1786 (prin1-to-string c
))
1788 (concat "(" (symbol-name (car c
)) ")"))
1790 (let ((next-indent (+ indent
2 (length (symbol-name (car c
))))))
1792 (symbol-name (car c
))
1794 (math-comp-to-string-raw (nth 1 c
) next-indent
)
1795 (math-comp-to-string-raw-step (cdr (cdr c
))
1799 (defun math-comp-to-string-raw-step (cl indent
)
1802 (make-string indent
32)
1803 (math-comp-to-string-raw (car cl
) indent
)
1804 (math-comp-to-string-raw-step (cdr cl
) indent
))
1809 ;;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
1810 ;;; calccomp.el ends here