40785
|
1 ;; Calculator for GNU Emacs, part II [calc-comp.el]
|
|
2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
|
|
3 ;; Written by Dave Gillespie, daveg@synaptics.com.
|
|
4
|
|
5 ;; This file is part of GNU Emacs.
|
|
6
|
|
7 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
8 ;; but WITHOUT ANY WARRANTY. No author or distributor
|
|
9 ;; accepts responsibility to anyone for the consequences of using it
|
|
10 ;; or for whether it serves any particular purpose or works at all,
|
|
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public
|
|
12 ;; License for full details.
|
|
13
|
|
14 ;; Everyone is granted permission to copy, modify and redistribute
|
|
15 ;; GNU Emacs, but only under the conditions described in the
|
|
16 ;; GNU Emacs General Public License. A copy of this license is
|
|
17 ;; supposed to have been given to you along with GNU Emacs so you
|
|
18 ;; can know your rights and responsibilities. It should be in a
|
|
19 ;; file named COPYING. Among other things, the copyright notice
|
|
20 ;; and this notice must be preserved on all copies.
|
|
21
|
|
22
|
|
23
|
|
24 ;; This file is autoloaded from calc-ext.el.
|
|
25 (require 'calc-ext)
|
|
26
|
|
27 (require 'calc-macs)
|
|
28
|
|
29 (defun calc-Need-calc-comp () nil)
|
|
30
|
|
31
|
|
32 ;;; A "composition" has one of the following forms:
|
|
33 ;;;
|
|
34 ;;; "string" A literal string
|
|
35 ;;;
|
|
36 ;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
|
|
37 ;;;
|
|
38 ;;; (set LEVEL OFF) Set left margin + offset for line-break level
|
|
39 ;;; (break LEVEL) A potential line-break point
|
|
40 ;;;
|
|
41 ;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
|
|
42 ;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
|
|
43 ;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
|
|
44 ;;; N specifies baseline of the stack, 0=top line.
|
|
45 ;;;
|
|
46 ;;; (supscr C1 C2) Composition C1 with superscript C2
|
|
47 ;;; (subscr C1 C2) Composition C1 with subscript C2
|
|
48 ;;; (rule X) Horizontal line of X, full width of enclosing comp
|
|
49 ;;;
|
|
50 ;;; (tag X C) Composition C corresponds to sub-expression X
|
|
51
|
|
52 (defun math-compose-expr (a prec)
|
|
53 (let ((math-compose-level (1+ math-compose-level)))
|
|
54 (cond
|
|
55 ((or (and (eq a math-comp-selected) a)
|
|
56 (and math-comp-tagged
|
|
57 (not (eq math-comp-tagged a))))
|
|
58 (let ((math-comp-selected nil))
|
|
59 (and math-comp-tagged (setq math-comp-tagged a))
|
|
60 (list 'tag a (math-compose-expr a prec))))
|
|
61 ((and (not (consp a)) (not (integerp a)))
|
|
62 (concat "'" (prin1-to-string a)))
|
|
63 ((math-scalarp a)
|
|
64 (if (or (eq (car-safe a) 'frac)
|
|
65 (and (nth 1 calc-frac-format) (Math-integerp a)))
|
|
66 (if (memq calc-language '(tex eqn math maple c fortran pascal))
|
|
67 (let ((aa (math-adjust-fraction a))
|
|
68 (calc-frac-format nil))
|
|
69 (math-compose-expr (list '/
|
|
70 (if (memq calc-language '(c fortran))
|
|
71 (math-float (nth 1 aa))
|
|
72 (nth 1 aa))
|
|
73 (nth 2 aa)) prec))
|
|
74 (if (and (eq calc-language 'big)
|
|
75 (= (length (car calc-frac-format)) 1))
|
|
76 (let* ((aa (math-adjust-fraction a))
|
|
77 (calc-frac-format nil)
|
|
78 (math-radix-explicit-format nil)
|
|
79 (c (list 'horiz
|
|
80 (if (math-negp (nth 1 aa))
|
|
81 "- " "")
|
|
82 (list 'vcent 1
|
|
83 (math-format-number
|
|
84 (math-abs (nth 1 aa)))
|
|
85 '(rule ?-)
|
|
86 (math-format-number (nth 2 aa))))))
|
|
87 (if (= calc-number-radix 10)
|
|
88 c
|
|
89 (list 'horiz "(" c
|
|
90 (list 'subscr ")"
|
|
91 (int-to-string calc-number-radix)))))
|
|
92 (math-format-number a)))
|
|
93 (if (not (eq calc-language 'big))
|
|
94 (math-format-number a prec)
|
|
95 (if (memq (car-safe a) '(cplx polar))
|
|
96 (if (math-zerop (nth 2 a))
|
|
97 (math-compose-expr (nth 1 a) prec)
|
|
98 (list 'horiz "("
|
|
99 (math-compose-expr (nth 1 a) 0)
|
|
100 (if (eq (car a) 'cplx) ", " "; ")
|
|
101 (math-compose-expr (nth 2 a) 0) ")"))
|
|
102 (if (or (= calc-number-radix 10)
|
|
103 (not (Math-realp a))
|
|
104 (and calc-group-digits
|
|
105 (not (assoc calc-group-char '((",") (" "))))))
|
|
106 (math-format-number a prec)
|
|
107 (let ((s (math-format-number a prec))
|
|
108 (c nil))
|
|
109 (while (string-match (if (> calc-number-radix 14)
|
|
110 "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
|
|
111 "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
|
|
112 s)
|
|
113 (setq c (nconc c (list (substring s 0 (match-beginning 0))
|
|
114 (list 'subscr
|
|
115 (math-match-substring s 2)
|
|
116 (math-match-substring s 1))))
|
|
117 s (substring s (match-end 0))))
|
|
118 (if (string-match
|
|
119 "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
|
|
120 (setq s (list 'horiz
|
|
121 (substring s 0 (match-beginning 0)) " "
|
|
122 (list 'supscr
|
|
123 (math-match-substring s 1)
|
|
124 (math-match-substring s 2))
|
|
125 (math-match-substring s 3))))
|
|
126 (if c (cons 'horiz (nconc c (list s))) s)))))))
|
|
127 ((and (get (car a) 'math-compose-forms)
|
|
128 (not (eq calc-language 'unform))
|
|
129 (let ((comps (get (car a) 'math-compose-forms))
|
|
130 temp temp2)
|
|
131 (or (and (setq temp (assq calc-language comps))
|
|
132 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
|
|
133 (setq temp (apply (cdr temp2) (cdr a)))
|
|
134 (math-compose-expr temp prec))
|
|
135 (and (setq temp2 (assq nil (cdr temp)))
|
|
136 (funcall (cdr temp2) a))))
|
|
137 (and (setq temp (assq nil comps))
|
|
138 (or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
|
|
139 (setq temp (apply (cdr temp2) (cdr a)))
|
|
140 (math-compose-expr temp prec))
|
|
141 (and (setq temp2 (assq nil (cdr temp)))
|
|
142 (funcall (cdr temp2) a))))))))
|
|
143 ((eq (car a) 'vec)
|
|
144 (let* ((left-bracket (if calc-vector-brackets
|
|
145 (substring calc-vector-brackets 0 1) ""))
|
|
146 (right-bracket (if calc-vector-brackets
|
|
147 (substring calc-vector-brackets 1 2) ""))
|
|
148 (inner-brackets (memq 'R calc-matrix-brackets))
|
|
149 (outer-brackets (memq 'O calc-matrix-brackets))
|
|
150 (row-commas (memq 'C calc-matrix-brackets))
|
|
151 (comma-spc (or calc-vector-commas " "))
|
|
152 (comma (or calc-vector-commas ""))
|
|
153 (vector-prec (if (or (and calc-vector-commas
|
|
154 (math-vector-no-parens a))
|
|
155 (memq 'P calc-matrix-brackets)) 0 1000))
|
|
156 (just (cond ((eq calc-matrix-just 'right) 'vright)
|
|
157 ((eq calc-matrix-just 'center) 'vcent)
|
|
158 (t 'vleft)))
|
|
159 (break calc-break-vectors))
|
|
160 (if (and (memq calc-language '(nil big))
|
|
161 (not calc-break-vectors)
|
|
162 (math-matrixp a) (not (math-matrixp (nth 1 a)))
|
|
163 (or calc-full-vectors
|
|
164 (and (< (length a) 7) (< (length (nth 1 a)) 7))
|
|
165 (progn (setq break t) nil)))
|
|
166 (if (progn
|
|
167 (setq vector-prec (if (or (and calc-vector-commas
|
|
168 (math-vector-no-parens
|
|
169 (nth 1 a)))
|
|
170 (memq 'P calc-matrix-brackets))
|
|
171 0 1000))
|
|
172 (= (length a) 2))
|
|
173 (list 'horiz
|
|
174 (concat left-bracket left-bracket " ")
|
|
175 (math-compose-vector (cdr (nth 1 a)) (concat comma " ")
|
|
176 vector-prec)
|
|
177 (concat " " right-bracket right-bracket))
|
|
178 (let* ((rows (1- (length a)))
|
|
179 (cols (1- (length (nth 1 a))))
|
|
180 (base (/ (1- rows) 2))
|
|
181 (calc-language 'flat))
|
|
182 (append '(horiz)
|
|
183 (list (append '(vleft)
|
|
184 (list base)
|
|
185 (list (concat (and outer-brackets
|
|
186 (concat left-bracket
|
|
187 " "))
|
|
188 (and inner-brackets
|
|
189 (concat left-bracket
|
|
190 " "))))
|
|
191 (make-list (1- rows)
|
|
192 (concat (and outer-brackets
|
|
193 " ")
|
|
194 (and inner-brackets
|
|
195 (concat
|
|
196 left-bracket
|
|
197 " "))))))
|
|
198 (math-compose-matrix (cdr a) 1 cols base)
|
|
199 (list (append '(vleft)
|
|
200 (list base)
|
|
201 (make-list (1- rows)
|
|
202 (if inner-brackets
|
|
203 (concat " "
|
|
204 right-bracket
|
|
205 (and row-commas
|
|
206 comma))
|
|
207 (if (and outer-brackets
|
|
208 row-commas)
|
|
209 ";" "")))
|
|
210 (list (concat
|
|
211 (and inner-brackets
|
|
212 (concat " "
|
|
213 right-bracket))
|
|
214 (and outer-brackets
|
|
215 (concat
|
|
216 " "
|
|
217 right-bracket)))))))))
|
|
218 (if (and calc-display-strings
|
|
219 (cdr a)
|
|
220 (math-vector-is-string a))
|
|
221 (math-vector-to-string a t)
|
|
222 (if (and break (cdr a)
|
|
223 (not (eq calc-language 'flat)))
|
|
224 (let* ((full (or calc-full-vectors (< (length a) 7)))
|
|
225 (rows (if full (1- (length a)) 5))
|
|
226 (base (/ (1- rows) 2))
|
|
227 (just 'vleft)
|
|
228 (calc-break-vectors nil))
|
|
229 (list 'horiz
|
|
230 (cons 'vleft (cons base
|
|
231 (math-compose-rows
|
|
232 (cdr a)
|
|
233 (if full rows 3) t)))))
|
|
234 (if (or calc-full-vectors (< (length a) 7))
|
|
235 (if (and (eq calc-language 'tex)
|
|
236 (math-matrixp a))
|
|
237 (append '(horiz "\\matrix{ ")
|
|
238 (math-compose-tex-matrix (cdr a))
|
|
239 '(" }"))
|
|
240 (if (and (eq calc-language 'eqn)
|
|
241 (math-matrixp a))
|
|
242 (append '(horiz "matrix { ")
|
|
243 (math-compose-eqn-matrix
|
|
244 (cdr (math-transpose a)))
|
|
245 '("}"))
|
|
246 (if (and (eq calc-language 'maple)
|
|
247 (math-matrixp a))
|
|
248 (list 'horiz
|
|
249 "matrix("
|
|
250 left-bracket
|
|
251 (math-compose-vector (cdr a) (concat comma " ")
|
|
252 vector-prec)
|
|
253 right-bracket
|
|
254 ")")
|
|
255 (list 'horiz
|
|
256 left-bracket
|
|
257 (math-compose-vector (cdr a) (concat comma " ")
|
|
258 vector-prec)
|
|
259 right-bracket))))
|
|
260 (list 'horiz
|
|
261 left-bracket
|
|
262 (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
|
|
263 (concat comma " ") vector-prec)
|
|
264 comma (if (eq calc-language 'tex) " \\ldots" " ...")
|
|
265 comma " "
|
|
266 (list 'break math-compose-level)
|
|
267 (math-compose-expr (nth (1- (length a)) a)
|
|
268 (if (equal comma "") 1000 0))
|
|
269 right-bracket)))))))
|
|
270 ((eq (car a) 'incomplete)
|
|
271 (if (cdr (cdr a))
|
|
272 (cond ((eq (nth 1 a) 'vec)
|
|
273 (list 'horiz "["
|
|
274 (math-compose-vector (cdr (cdr a)) ", " 0)
|
|
275 " ..."))
|
|
276 ((eq (nth 1 a) 'cplx)
|
|
277 (list 'horiz "("
|
|
278 (math-compose-vector (cdr (cdr a)) ", " 0)
|
|
279 ", ..."))
|
|
280 ((eq (nth 1 a) 'polar)
|
|
281 (list 'horiz "("
|
|
282 (math-compose-vector (cdr (cdr a)) "; " 0)
|
|
283 "; ..."))
|
|
284 ((eq (nth 1 a) 'intv)
|
|
285 (list 'horiz
|
|
286 (if (memq (nth 2 a) '(0 1)) "(" "[")
|
|
287 (math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
|
|
288 " .. ..."))
|
|
289 (t (format "%s" a)))
|
|
290 (cond ((eq (nth 1 a) 'vec) "[ ...")
|
|
291 ((eq (nth 1 a) 'intv)
|
|
292 (if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
|
|
293 (t "( ..."))))
|
|
294 ((eq (car a) 'var)
|
|
295 (let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
|
|
296 (if v
|
|
297 (symbol-name (car v))
|
|
298 (if (and (eq calc-language 'tex)
|
|
299 calc-language-option
|
|
300 (not (= calc-language-option 0))
|
|
301 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
|
|
302 (symbol-name (nth 1 a))))
|
|
303 (format "\\hbox{%s}" (symbol-name (nth 1 a)))
|
|
304 (if (and math-compose-hash-args
|
|
305 (let ((p calc-arg-values))
|
|
306 (setq v 1)
|
|
307 (while (and p (not (equal (car p) a)))
|
|
308 (setq p (and (eq math-compose-hash-args t) (cdr p))
|
|
309 v (1+ v)))
|
|
310 p))
|
|
311 (if (eq math-compose-hash-args 1)
|
|
312 "#"
|
|
313 (format "#%d" v))
|
|
314 (if (memq calc-language '(c fortran pascal maple))
|
|
315 (math-to-underscores (symbol-name (nth 1 a)))
|
|
316 (if (and (eq calc-language 'eqn)
|
|
317 (string-match ".'\\'" (symbol-name (nth 2 a))))
|
|
318 (math-compose-expr
|
|
319 (list 'calcFunc-Prime
|
|
320 (list
|
|
321 'var
|
|
322 (intern (substring (symbol-name (nth 1 a)) 0 -1))
|
|
323 (intern (substring (symbol-name (nth 2 a)) 0 -1))))
|
|
324 prec)
|
|
325 (symbol-name (nth 1 a)))))))))
|
|
326 ((eq (car a) 'intv)
|
|
327 (list 'horiz
|
|
328 (if (eq calc-language 'maple) ""
|
|
329 (if (memq (nth 1 a) '(0 1)) "(" "["))
|
|
330 (math-compose-expr (nth 2 a) 0)
|
|
331 (if (eq calc-language 'tex) " \\ldots "
|
|
332 (if (eq calc-language 'eqn) " ... " " .. "))
|
|
333 (math-compose-expr (nth 3 a) 0)
|
|
334 (if (eq calc-language 'maple) ""
|
|
335 (if (memq (nth 1 a) '(0 2)) ")" "]"))))
|
|
336 ((eq (car a) 'date)
|
|
337 (if (eq (car calc-date-format) 'X)
|
|
338 (math-format-date a)
|
|
339 (concat "<" (math-format-date a) ">")))
|
|
340 ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a))
|
|
341 (memq calc-language '(c pascal fortran maple)))
|
|
342 (let ((args (cdr (cdr a))))
|
|
343 (while (and (memq calc-language '(pascal fortran))
|
|
344 (eq (car-safe (nth 1 a)) 'calcFunc-subscr))
|
|
345 (setq args (append (cdr (cdr (nth 1 a))) args)
|
|
346 a (nth 1 a)))
|
|
347 (list 'horiz
|
|
348 (math-compose-expr (nth 1 a) 1000)
|
|
349 (if (eq calc-language 'fortran) "(" "[")
|
|
350 (math-compose-vector args ", " 0)
|
|
351 (if (eq calc-language 'fortran) ")" "]"))))
|
|
352 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
|
|
353 (eq calc-language 'big))
|
|
354 (let* ((a1 (math-compose-expr (nth 1 a) 1000))
|
|
355 (calc-language 'flat)
|
|
356 (a2 (math-compose-expr (nth 2 a) 0)))
|
|
357 (if (or (eq (car-safe a1) 'subscr)
|
|
358 (and (eq (car-safe a1) 'tag)
|
|
359 (eq (car-safe (nth 2 a1)) 'subscr)
|
|
360 (setq a1 (nth 2 a1))))
|
|
361 (list 'subscr
|
|
362 (nth 1 a1)
|
|
363 (list 'horiz
|
|
364 (nth 2 a1)
|
|
365 ", "
|
|
366 a2))
|
|
367 (list 'subscr a1 a2))))
|
|
368 ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
|
|
369 (eq calc-language 'math))
|
|
370 (list 'horiz
|
|
371 (math-compose-expr (nth 1 a) 1000)
|
|
372 "[["
|
|
373 (math-compose-expr (nth 2 a) 0)
|
|
374 "]]"))
|
|
375 ((and (eq (car a) 'calcFunc-sqrt)
|
|
376 (eq calc-language 'tex))
|
|
377 (list 'horiz
|
|
378 "\\sqrt{"
|
|
379 (math-compose-expr (nth 1 a) 0)
|
|
380 "}"))
|
|
381 ((and nil (eq (car a) 'calcFunc-sqrt)
|
|
382 (eq calc-language 'eqn))
|
|
383 (list 'horiz
|
|
384 "sqrt {"
|
|
385 (math-compose-expr (nth 1 a) -1)
|
|
386 "}"))
|
|
387 ((and (eq (car a) '^)
|
|
388 (eq calc-language 'big))
|
|
389 (list 'supscr
|
|
390 (if (or (math-looks-negp (nth 1 a))
|
|
391 (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
|
|
392 (and (eq (car-safe (nth 1 a)) 'cplx)
|
|
393 (math-negp (nth 1 (nth 1 a)))
|
|
394 (eq (nth 2 (nth 1 a)) 0)))
|
|
395 (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
|
|
396 (math-compose-expr (nth 1 a) 201))
|
|
397 (let ((calc-language 'flat)
|
|
398 (calc-number-radix 10))
|
|
399 (math-compose-expr (nth 2 a) 0))))
|
|
400 ((and (eq (car a) '/)
|
|
401 (eq calc-language 'big))
|
|
402 (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
|
|
403 'flat 'big)))
|
|
404 (math-compose-expr (nth 1 a) 0)))
|
|
405 (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
|
|
406 'flat 'big)))
|
|
407 (math-compose-expr (nth 2 a) 0))))
|
|
408 (list 'vcent
|
|
409 (math-comp-height a1)
|
|
410 a1 '(rule ?-) a2)))
|
|
411 ((and (memq (car a) '(calcFunc-sum calcFunc-prod))
|
|
412 (eq calc-language 'tex)
|
|
413 (= (length a) 5))
|
|
414 (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod")
|
|
415 "_{" (math-compose-expr (nth 2 a) 0)
|
|
416 "=" (math-compose-expr (nth 3 a) 0)
|
|
417 "}^{" (math-compose-expr (nth 4 a) 0)
|
|
418 "}{" (math-compose-expr (nth 1 a) 0) "}"))
|
|
419 ((and (eq (car a) 'calcFunc-lambda)
|
|
420 (> (length a) 2)
|
|
421 (memq calc-language '(nil flat big)))
|
|
422 (let ((p (cdr a))
|
|
423 (ap calc-arg-values)
|
|
424 (math-compose-hash-args (if (= (length a) 3) 1 t)))
|
|
425 (while (and (cdr p) (equal (car p) (car ap)))
|
|
426 (setq p (cdr p) ap (cdr ap)))
|
|
427 (append '(horiz "<")
|
|
428 (if (cdr p)
|
|
429 (list (math-compose-vector
|
|
430 (nreverse (cdr (reverse (cdr a)))) ", " 0)
|
|
431 " : ")
|
|
432 nil)
|
|
433 (list (math-compose-expr (nth (1- (length a)) a) 0)
|
|
434 ">"))))
|
|
435 ((and (eq (car a) 'calcFunc-string)
|
|
436 (= (length a) 2)
|
|
437 (math-vectorp (nth 1 a))
|
|
438 (math-vector-is-string (nth 1 a)))
|
|
439 (if (eq calc-language 'unform)
|
|
440 (concat "string(" (math-vector-to-string (nth 1 a) t) ")")
|
|
441 (math-vector-to-string (nth 1 a) nil)))
|
|
442 ((and (eq (car a) 'calcFunc-bstring)
|
|
443 (= (length a) 2)
|
|
444 (math-vectorp (nth 1 a))
|
|
445 (math-vector-is-string (nth 1 a)))
|
|
446 (if (eq calc-language 'unform)
|
|
447 (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
|
|
448 (let ((c nil)
|
|
449 (s (math-vector-to-string (nth 1 a) nil))
|
|
450 p)
|
|
451 (while (string-match "[^ ] +[^ ]" s)
|
|
452 (setq p (1- (match-end 0))
|
|
453 c (cons (list 'break math-compose-level)
|
|
454 (cons (substring s 0 p)
|
|
455 c))
|
|
456 s (substring s p)))
|
|
457 (setq c (nreverse (cons s c)))
|
|
458 (or (= prec -123)
|
|
459 (setq c (cons (list 'set math-compose-level 2) c)))
|
|
460 (cons 'horiz c))))
|
|
461 ((and (eq (car a) 'calcFunc-cprec)
|
|
462 (not (eq calc-language 'unform))
|
|
463 (= (length a) 3)
|
|
464 (integerp (nth 2 a)))
|
|
465 (let ((c (math-compose-expr (nth 1 a) -1)))
|
|
466 (if (> prec (nth 2 a))
|
|
467 (if (eq calc-language 'tex)
|
|
468 (list 'horiz "\\left( " c " \\right)")
|
|
469 (if (eq calc-language 'eqn)
|
|
470 (list 'horiz "{left ( " c " right )}")
|
|
471 (list 'horiz "(" c ")")))
|
|
472 c)))
|
|
473 ((and (eq (car a) 'calcFunc-choriz)
|
|
474 (not (eq calc-language 'unform))
|
|
475 (memq (length a) '(2 3 4))
|
|
476 (math-vectorp (nth 1 a))
|
|
477 (if (integerp (nth 2 a))
|
|
478 (or (null (nth 3 a))
|
|
479 (and (math-vectorp (nth 3 a))
|
|
480 (math-vector-is-string (nth 3 a))))
|
|
481 (or (null (nth 2 a))
|
|
482 (and (math-vectorp (nth 2 a))
|
|
483 (math-vector-is-string (nth 2 a))))))
|
|
484 (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
|
|
485 (sep (nth (if cprec 3 2) a))
|
|
486 (bprec nil))
|
|
487 (if sep
|
|
488 (math-compose-vector (cdr (nth 1 a))
|
|
489 (math-vector-to-string sep nil)
|
|
490 (or cprec prec))
|
|
491 (cons 'horiz (mapcar (function
|
|
492 (lambda (x)
|
|
493 (if (eq (car-safe x) 'calcFunc-bstring)
|
|
494 (prog1
|
|
495 (math-compose-expr
|
|
496 x (or bprec cprec prec))
|
|
497 (setq bprec -123))
|
|
498 (math-compose-expr x (or cprec prec)))))
|
|
499 (cdr (nth 1 a)))))))
|
|
500 ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
|
|
501 (not (eq calc-language 'unform))
|
|
502 (memq (length a) '(2 3))
|
|
503 (math-vectorp (nth 1 a))
|
|
504 (or (null (nth 2 a))
|
|
505 (integerp (nth 2 a))))
|
|
506 (let* ((base 0)
|
|
507 (v 0)
|
|
508 (prec (or (nth 2 a) prec))
|
|
509 (c (mapcar (function
|
|
510 (lambda (x)
|
|
511 (let ((b nil) (cc nil) a d)
|
|
512 (if (and (memq (car-safe x) '(calcFunc-cbase
|
|
513 calcFunc-ctbase
|
|
514 calcFunc-cbbase))
|
|
515 (memq (length x) '(1 2)))
|
|
516 (setq b (car x)
|
|
517 x (nth 1 x)))
|
|
518 (if (and (eq (car-safe x) 'calcFunc-crule)
|
|
519 (memq (length x) '(1 2))
|
|
520 (or (null (nth 1 x))
|
|
521 (and (math-vectorp (nth 1 x))
|
|
522 (= (length (nth 1 x)) 2)
|
|
523 (math-vector-is-string
|
|
524 (nth 1 x)))
|
|
525 (and (natnump (nth 1 x))
|
|
526 (<= (nth 1 x) 255))))
|
|
527 (setq cc (list
|
|
528 'rule
|
|
529 (if (math-vectorp (nth 1 x))
|
|
530 (aref (math-vector-to-string
|
|
531 (nth 1 x) nil) 0)
|
|
532 (or (nth 1 x) ?-))))
|
|
533 (or (and (memq (car-safe x) '(calcFunc-cvspace
|
|
534 calcFunc-ctspace
|
|
535 calcFunc-cbspace))
|
|
536 (memq (length x) '(2 3))
|
|
537 (eq (nth 1 x) 0))
|
|
538 (null x)
|
|
539 (setq cc (math-compose-expr x prec))))
|
|
540 (setq a (if cc (math-comp-ascent cc) 0)
|
|
541 d (if cc (math-comp-descent cc) 0))
|
|
542 (if (eq b 'calcFunc-cbase)
|
|
543 (setq base (+ v a -1))
|
|
544 (if (eq b 'calcFunc-ctbase)
|
|
545 (setq base v)
|
|
546 (if (eq b 'calcFunc-cbbase)
|
|
547 (setq base (+ v a d -1)))))
|
|
548 (setq v (+ v a d))
|
|
549 cc)))
|
|
550 (cdr (nth 1 a)))))
|
|
551 (setq c (delq nil c))
|
|
552 (if c
|
|
553 (cons (if (eq (car a) 'calcFunc-cvert) 'vcent
|
|
554 (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
|
|
555 (cons base c))
|
|
556 " ")))
|
|
557 ((and (memq (car a) '(calcFunc-csup calcFunc-csub))
|
|
558 (not (eq calc-language 'unform))
|
|
559 (memq (length a) '(3 4))
|
|
560 (or (null (nth 3 a))
|
|
561 (integerp (nth 3 a))))
|
|
562 (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
|
|
563 (math-compose-expr (nth 1 a) (or (nth 3 a) 0))
|
|
564 (math-compose-expr (nth 2 a) 0)))
|
|
565 ((and (eq (car a) 'calcFunc-cflat)
|
|
566 (not (eq calc-language 'unform))
|
|
567 (memq (length a) '(2 3))
|
|
568 (or (null (nth 2 a))
|
|
569 (integerp (nth 2 a))))
|
|
570 (let ((calc-language (if (memq calc-language '(nil big))
|
|
571 'flat calc-language)))
|
|
572 (math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
|
|
573 ((and (eq (car a) 'calcFunc-cspace)
|
|
574 (memq (length a) '(2 3))
|
|
575 (natnump (nth 1 a)))
|
|
576 (if (nth 2 a)
|
|
577 (cons 'horiz (make-list (nth 1 a)
|
|
578 (if (and (math-vectorp (nth 2 a))
|
|
579 (math-vector-is-string (nth 2 a)))
|
|
580 (math-vector-to-string (nth 2 a) nil)
|
|
581 (math-compose-expr (nth 2 a) 0))))
|
|
582 (make-string (nth 1 a) ?\ )))
|
|
583 ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
|
|
584 (memq (length a) '(2 3))
|
|
585 (natnump (nth 1 a)))
|
|
586 (if (= (nth 1 a) 0)
|
|
587 ""
|
|
588 (let* ((c (if (nth 2 a)
|
|
589 (if (and (math-vectorp (nth 2 a))
|
|
590 (math-vector-is-string (nth 2 a)))
|
|
591 (math-vector-to-string (nth 2 a) nil)
|
|
592 (math-compose-expr (nth 2 a) 0))
|
|
593 " "))
|
|
594 (ca (math-comp-ascent c))
|
|
595 (cd (math-comp-descent c)))
|
|
596 (cons 'vleft
|
|
597 (cons (if (eq (car a) 'calcFunc-ctspace)
|
|
598 (1- ca)
|
|
599 (if (eq (car a) 'calcFunc-cbspace)
|
|
600 (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
|
|
601 (/ (1- (* (nth 1 a) (+ ca cd))) 2)))
|
|
602 (make-list (nth 1 a) c))))))
|
|
603 ((and (eq (car a) 'calcFunc-evalto)
|
|
604 (setq calc-any-evaltos t)
|
|
605 (memq calc-language '(tex eqn))
|
|
606 (= math-compose-level (if math-comp-tagged 2 1))
|
|
607 (= (length a) 3))
|
|
608 (list 'horiz
|
|
609 (if (eq calc-language 'tex) "\\evalto " "evalto ")
|
|
610 (math-compose-expr (nth 1 a) 0)
|
|
611 (if (eq calc-language 'tex) " \\to " " -> ")
|
|
612 (math-compose-expr (nth 2 a) 0)))
|
|
613 (t
|
|
614 (let ((op (and (not (eq calc-language 'unform))
|
|
615 (if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
|
|
616 (assoc "?" math-expr-opers)
|
|
617 (math-assq2 (car a) math-expr-opers)))))
|
|
618 (cond ((and op
|
|
619 (or (= (length a) 3) (eq (car a) 'calcFunc-if))
|
|
620 (/= (nth 3 op) -1))
|
|
621 (cond
|
|
622 ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
|
|
623 (if (and (eq calc-language 'tex)
|
|
624 (not (math-tex-expr-is-flat a)))
|
|
625 (if (eq (car-safe a) '/)
|
|
626 (list 'horiz "{" (math-compose-expr a -1) "}")
|
|
627 (list 'horiz "\\left( "
|
|
628 (math-compose-expr a -1)
|
|
629 " \\right)"))
|
|
630 (if (eq calc-language 'eqn)
|
|
631 (if (or (eq (car-safe a) '/)
|
|
632 (= (/ prec 100) 9))
|
|
633 (list 'horiz "{" (math-compose-expr a -1) "}")
|
|
634 (if (math-tex-expr-is-flat a)
|
|
635 (list 'horiz "( " (math-compose-expr a -1) " )")
|
|
636 (list 'horiz "{left ( "
|
|
637 (math-compose-expr a -1)
|
|
638 " right )}")))
|
|
639 (list 'horiz "(" (math-compose-expr a 0) ")"))))
|
|
640 ((and (eq calc-language 'tex)
|
|
641 (memq (car a) '(/ calcFunc-choose calcFunc-evalto))
|
|
642 (>= prec 0))
|
|
643 (list 'horiz "{" (math-compose-expr a -1) "}"))
|
|
644 ((eq (car a) 'calcFunc-if)
|
|
645 (list 'horiz
|
|
646 (math-compose-expr (nth 1 a) (nth 2 op))
|
|
647 " ? "
|
|
648 (math-compose-expr (nth 2 a) 0)
|
|
649 " : "
|
|
650 (math-compose-expr (nth 3 a) (nth 3 op))))
|
|
651 (t
|
|
652 (let* ((math-comp-tagged (and math-comp-tagged
|
|
653 (not (math-primp a))
|
|
654 math-comp-tagged))
|
|
655 (setlev (if (= prec (min (nth 2 op) (nth 3 op)))
|
|
656 (progn
|
|
657 (setq math-compose-level
|
|
658 (1- math-compose-level))
|
|
659 nil)
|
|
660 math-compose-level))
|
|
661 (lhs (math-compose-expr (nth 1 a) (nth 2 op)))
|
|
662 (rhs (math-compose-expr (nth 2 a) (nth 3 op))))
|
|
663 (and (equal (car op) "^")
|
|
664 (eq (math-comp-first-char lhs) ?-)
|
|
665 (setq lhs (list 'horiz "(" lhs ")")))
|
|
666 (and (eq calc-language 'tex)
|
|
667 (or (equal (car op) "^") (equal (car op) "_"))
|
|
668 (not (and (stringp rhs) (= (length rhs) 1)))
|
|
669 (setq rhs (list 'horiz "{" rhs "}")))
|
|
670 (or (and (eq (car a) '*)
|
|
671 (or (null calc-language)
|
|
672 (assoc "2x" math-expr-opers))
|
|
673 (let* ((prevt (math-prod-last-term (nth 1 a)))
|
|
674 (nextt (math-prod-first-term (nth 2 a)))
|
|
675 (prevc (or (math-comp-last-char lhs)
|
|
676 (and (memq (car-safe prevt)
|
|
677 '(^ calcFunc-subscr
|
|
678 calcFunc-sqrt
|
|
679 frac))
|
|
680 (eq calc-language 'big)
|
|
681 ?0)))
|
|
682 (nextc (or (math-comp-first-char rhs)
|
|
683 (and (memq (car-safe nextt)
|
|
684 '(calcFunc-sqrt
|
|
685 calcFunc-sum
|
|
686 calcFunc-prod
|
|
687 calcFunc-integ))
|
|
688 (eq calc-language 'big)
|
|
689 ?0))))
|
|
690 (and prevc nextc
|
|
691 (or (and (>= nextc ?a) (<= nextc ?z))
|
|
692 (and (>= nextc ?A) (<= nextc ?Z))
|
|
693 (and (>= nextc ?0) (<= nextc ?9))
|
|
694 (memq nextc '(?. ?_ ?#
|
|
695 ?\( ?\[ ?\{))
|
|
696 (and (eq nextc ?\\)
|
|
697 (not (string-match
|
|
698 "\\`\\\\left("
|
|
699 (math-comp-first-string
|
|
700 rhs)))))
|
|
701 (not (and (eq (car-safe prevt) 'var)
|
|
702 (eq nextc ?\()))
|
|
703 (list 'horiz
|
|
704 (list 'set setlev 1)
|
|
705 lhs
|
|
706 (list 'break math-compose-level)
|
|
707 " "
|
|
708 rhs))))
|
|
709 (list 'horiz
|
|
710 (list 'set setlev 1)
|
|
711 lhs
|
|
712 (list 'break math-compose-level)
|
|
713 (if (or (equal (car op) "^")
|
|
714 (equal (car op) "_")
|
|
715 (equal (car op) "**")
|
|
716 (and (equal (car op) "*")
|
|
717 (math-comp-last-char lhs)
|
|
718 (math-comp-first-char rhs))
|
|
719 (and (equal (car op) "/")
|
|
720 (math-num-integerp (nth 1 a))
|
|
721 (math-integerp (nth 2 a))))
|
|
722 (car op)
|
|
723 (if (and (eq calc-language 'big)
|
|
724 (equal (car op) "=>"))
|
|
725 " => "
|
|
726 (concat " " (car op) " ")))
|
|
727 rhs))))))
|
|
728 ((and op (= (length a) 2) (= (nth 3 op) -1))
|
|
729 (cond
|
|
730 ((or (> prec (or (nth 4 op) (nth 2 op)))
|
|
731 (and (not (eq (assoc (car op) math-expr-opers) op))
|
|
732 (> prec 0))) ; don't write x% + y
|
|
733 (if (and (eq calc-language 'tex)
|
|
734 (not (math-tex-expr-is-flat a)))
|
|
735 (list 'horiz "\\left( "
|
|
736 (math-compose-expr a -1)
|
|
737 " \\right)")
|
|
738 (if (eq calc-language 'eqn)
|
|
739 (if (= (/ prec 100) 9)
|
|
740 (list 'horiz "{" (math-compose-expr a -1) "}")
|
|
741 (if (math-tex-expr-is-flat a)
|
|
742 (list 'horiz "{( " (math-compose-expr a -1) " )}")
|
|
743 (list 'horiz "{left ( "
|
|
744 (math-compose-expr a -1)
|
|
745 " right )}")))
|
|
746 (list 'horiz "(" (math-compose-expr a 0) ")"))))
|
|
747 (t
|
|
748 (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
|
|
749 (list 'horiz
|
|
750 lhs
|
|
751 (if (or (> (length (car op)) 1)
|
|
752 (not (math-comp-is-flat lhs)))
|
|
753 (concat " " (car op))
|
|
754 (car op)))))))
|
|
755 ((and op (= (length a) 2) (= (nth 2 op) -1))
|
|
756 (cond
|
|
757 ((eq (nth 3 op) 0)
|
|
758 (let ((lr (and (eq calc-language 'tex)
|
|
759 (not (math-tex-expr-is-flat (nth 1 a))))))
|
|
760 (list 'horiz
|
|
761 (if lr "\\left" "")
|
|
762 (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
|
|
763 (substring (car op) 1)
|
|
764 (car op))
|
|
765 (if (or lr (> (length (car op)) 2)) " " "")
|
|
766 (math-compose-expr (nth 1 a) -1)
|
|
767 (if (or lr (> (length (car op)) 2)) " " "")
|
|
768 (if lr "\\right" "")
|
|
769 (car (nth 1 (memq op math-expr-opers))))))
|
|
770 ((> prec (or (nth 4 op) (nth 3 op)))
|
|
771 (if (and (eq calc-language 'tex)
|
|
772 (not (math-tex-expr-is-flat a)))
|
|
773 (list 'horiz "\\left( "
|
|
774 (math-compose-expr a -1)
|
|
775 " \\right)")
|
|
776 (if (eq calc-language 'eqn)
|
|
777 (if (= (/ prec 100) 9)
|
|
778 (list 'horiz "{" (math-compose-expr a -1) "}")
|
|
779 (if (math-tex-expr-is-flat a)
|
|
780 (list 'horiz "{( " (math-compose-expr a -1) " )}")
|
|
781 (list 'horiz "{left ( "
|
|
782 (math-compose-expr a -1)
|
|
783 " right )}")))
|
|
784 (list 'horiz "(" (math-compose-expr a 0) ")"))))
|
|
785 (t
|
|
786 (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
|
|
787 (list 'horiz
|
|
788 (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
|
|
789 (car op))
|
|
790 (substring (car op) 1)
|
|
791 (car op))))
|
|
792 (if (or (> (length ops) 1)
|
|
793 (not (math-comp-is-flat rhs)))
|
|
794 (concat ops " ")
|
|
795 ops))
|
|
796 rhs)))))
|
|
797 ((and (eq calc-language 'big)
|
|
798 (setq op (get (car a) 'math-compose-big))
|
|
799 (funcall op a prec)))
|
|
800 ((and (setq op (assq calc-language
|
|
801 '( ( nil . math-compose-normal )
|
|
802 ( flat . math-compose-normal )
|
|
803 ( big . math-compose-normal )
|
|
804 ( c . math-compose-c )
|
|
805 ( pascal . math-compose-pascal )
|
|
806 ( fortran . math-compose-fortran )
|
|
807 ( tex . math-compose-tex )
|
|
808 ( eqn . math-compose-eqn )
|
|
809 ( math . math-compose-math )
|
|
810 ( maple . math-compose-maple ))))
|
|
811 (setq op (get (car a) (cdr op)))
|
|
812 (funcall op a prec)))
|
|
813 (t
|
|
814 (let* ((func (car a))
|
|
815 (func2 (assq func '(( mod . calcFunc-makemod )
|
|
816 ( sdev . calcFunc-sdev )
|
|
817 ( + . calcFunc-add )
|
|
818 ( - . calcFunc-sub )
|
|
819 ( * . calcFunc-mul )
|
|
820 ( / . calcFunc-div )
|
|
821 ( % . calcFunc-mod )
|
|
822 ( ^ . calcFunc-pow )
|
|
823 ( neg . calcFunc-neg )
|
|
824 ( | . calcFunc-vconcat ))))
|
|
825 left right args)
|
|
826 (if func2
|
|
827 (setq func (cdr func2)))
|
|
828 (if (setq func2 (rassq func math-expr-function-mapping))
|
|
829 (setq func (car func2)))
|
|
830 (setq func (math-remove-dashes
|
|
831 (if (string-match
|
|
832 "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
|
|
833 (symbol-name func))
|
|
834 (math-match-substring (symbol-name func) 1)
|
|
835 (symbol-name func))))
|
|
836 (if (memq calc-language '(c fortran pascal maple))
|
|
837 (setq func (math-to-underscores func)))
|
|
838 (if (and (eq calc-language 'tex)
|
|
839 calc-language-option
|
|
840 (not (= calc-language-option 0))
|
|
841 (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func))
|
|
842 (if (< (prefix-numeric-value calc-language-option) 0)
|
|
843 (setq func (format "\\%s" func))
|
|
844 (setq func (format "\\hbox{%s}" func))))
|
|
845 (if (and (eq calc-language 'eqn)
|
|
846 (string-match "[^']'+\\'" func))
|
|
847 (let ((n (- (length func) (match-beginning 0) 1)))
|
|
848 (setq func (substring func 0 (- n)))
|
|
849 (while (>= (setq n (1- n)) 0)
|
|
850 (setq func (concat func " prime")))))
|
|
851 (cond ((and (eq calc-language 'tex)
|
|
852 (or (> (length a) 2)
|
|
853 (not (math-tex-expr-is-flat (nth 1 a)))))
|
|
854 (setq left "\\left( "
|
|
855 right " \\right)"))
|
|
856 ((and (eq calc-language 'eqn)
|
|
857 (or (> (length a) 2)
|
|
858 (not (math-tex-expr-is-flat (nth 1 a)))))
|
|
859 (setq left "{left ( "
|
|
860 right " right )}"))
|
|
861 ((and (or (and (eq calc-language 'tex)
|
|
862 (eq (aref func 0) ?\\))
|
|
863 (and (eq calc-language 'eqn)
|
|
864 (memq (car a) math-eqn-special-funcs)))
|
|
865 (not (string-match "\\hbox{" func))
|
|
866 (= (length a) 2)
|
|
867 (or (Math-realp (nth 1 a))
|
|
868 (memq (car (nth 1 a)) '(var *))))
|
|
869 (setq left (if (eq calc-language 'eqn) "~{" "{")
|
|
870 right "}"))
|
|
871 ((eq calc-language 'eqn)
|
|
872 (setq left " ( "
|
|
873 right " )"))
|
|
874 (t (setq left calc-function-open
|
|
875 right calc-function-close)))
|
|
876 (list 'horiz func left
|
|
877 (math-compose-vector (cdr a)
|
|
878 (if (eq calc-language 'eqn)
|
|
879 " , " ", ")
|
|
880 0)
|
|
881 right))))))))
|
|
882 )
|
|
883
|
|
884 (defconst math-eqn-special-funcs
|
|
885 '( calcFunc-log
|
|
886 calcFunc-ln calcFunc-exp
|
|
887 calcFunc-sin calcFunc-cos calcFunc-tan
|
|
888 calcFunc-sinh calcFunc-cosh calcFunc-tanh
|
|
889 calcFunc-arcsin calcFunc-arccos calcFunc-arctan
|
|
890 calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh
|
|
891 ))
|
|
892
|
|
893
|
|
894 (defun math-prod-first-term (x)
|
|
895 (while (eq (car-safe x) '*)
|
|
896 (setq x (nth 1 x)))
|
|
897 x
|
|
898 )
|
|
899
|
|
900 (defun math-prod-last-term (x)
|
|
901 (while (eq (car-safe x) '*)
|
|
902 (setq x (nth 2 x)))
|
|
903 x
|
|
904 )
|
|
905
|
|
906 (defun math-compose-vector (a sep prec)
|
|
907 (if a
|
|
908 (cons 'horiz
|
|
909 (cons (list 'set math-compose-level)
|
|
910 (let ((c (list (math-compose-expr (car a) prec))))
|
|
911 (while (setq a (cdr a))
|
|
912 (setq c (cons (if (eq (car-safe (car a))
|
|
913 'calcFunc-bstring)
|
|
914 (let ((math-compose-level
|
|
915 (1- math-compose-level)))
|
|
916 (math-compose-expr (car a) -123))
|
|
917 (math-compose-expr (car a) prec))
|
|
918 (cons (list 'break math-compose-level)
|
|
919 (cons sep c)))))
|
|
920 (nreverse c))))
|
|
921 "")
|
|
922 )
|
|
923
|
|
924 (defun math-vector-no-parens (a)
|
|
925 (or (cdr (cdr a))
|
|
926 (not (eq (car-safe (nth 1 a)) '*)))
|
|
927 )
|
|
928
|
|
929 (defun math-compose-matrix (a col cols base)
|
|
930 (let ((col 0)
|
|
931 (res nil))
|
|
932 (while (<= (setq col (1+ col)) cols)
|
|
933 (setq res (cons (cons just
|
|
934 (cons base
|
|
935 (mapcar (function
|
|
936 (lambda (r)
|
|
937 (list 'horiz
|
|
938 (math-compose-expr
|
|
939 (nth col r)
|
|
940 vector-prec)
|
|
941 (if (= col cols)
|
|
942 ""
|
|
943 (concat comma-spc " ")))))
|
|
944 a)))
|
|
945 res)))
|
|
946 (nreverse res))
|
|
947 )
|
|
948
|
|
949 (defun math-compose-rows (a count first)
|
|
950 (if (cdr a)
|
|
951 (if (<= count 0)
|
|
952 (if (< count 0)
|
|
953 (math-compose-rows (cdr a) -1 nil)
|
|
954 (cons (concat (if (eq calc-language 'tex) " \\ldots" " ...")
|
|
955 comma)
|
|
956 (math-compose-rows (cdr a) -1 nil)))
|
|
957 (cons (list 'horiz
|
|
958 (if first (concat left-bracket " ") " ")
|
|
959 (math-compose-expr (car a) vector-prec)
|
|
960 comma)
|
|
961 (math-compose-rows (cdr a) (1- count) nil)))
|
|
962 (list (list 'horiz
|
|
963 (if first (concat left-bracket " ") " ")
|
|
964 (math-compose-expr (car a) vector-prec)
|
|
965 (concat " " right-bracket))))
|
|
966 )
|
|
967
|
|
968 (defun math-compose-tex-matrix (a)
|
|
969 (if (cdr a)
|
|
970 (cons (math-compose-vector (cdr (car a)) " & " 0)
|
|
971 (cons " \\\\ "
|
|
972 (math-compose-tex-matrix (cdr a))))
|
|
973 (list (math-compose-vector (cdr (car a)) " & " 0)))
|
|
974 )
|
|
975
|
|
976 (defun math-compose-eqn-matrix (a)
|
|
977 (if a
|
|
978 (cons
|
|
979 (cond ((eq calc-matrix-just 'right) "rcol ")
|
|
980 ((eq calc-matrix-just 'center) "ccol ")
|
|
981 (t "lcol "))
|
|
982 (cons
|
|
983 (list 'break math-compose-level)
|
|
984 (cons
|
|
985 "{ "
|
|
986 (cons
|
|
987 (let ((math-compose-level (1+ math-compose-level)))
|
|
988 (math-compose-vector (cdr (car a)) " above " 1000))
|
|
989 (cons
|
|
990 " } "
|
|
991 (math-compose-eqn-matrix (cdr a)))))))
|
|
992 nil)
|
|
993 )
|
|
994
|
|
995 (defun math-vector-is-string (a)
|
|
996 (while (and (setq a (cdr a))
|
|
997 (or (and (natnump (car a))
|
|
998 (<= (car a) 255))
|
|
999 (and (eq (car-safe (car a)) 'cplx)
|
|
1000 (natnump (nth 1 (car a)))
|
|
1001 (eq (nth 2 (car a)) 0)
|
|
1002 (<= (nth 1 (car a)) 255)))))
|
|
1003 (null a)
|
|
1004 )
|
|
1005
|
|
1006 (defun math-vector-to-string (a &optional quoted)
|
|
1007 (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
|
|
1008 (cdr a))))
|
|
1009 (if (string-match "[\000-\037\177\\\"]" a)
|
|
1010 (let ((p 0)
|
|
1011 (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
|
|
1012 (codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
|
|
1013 (fmt (if quoted "\\^%c" "^%c"))
|
|
1014 new)
|
|
1015 (while (setq p (string-match pat a p))
|
|
1016 (if (setq new (assq (aref a p) codes))
|
|
1017 (setq a (concat (substring a 0 p)
|
|
1018 (cdr new)
|
|
1019 (substring a (1+ p)))
|
|
1020 p (+ p (length (cdr new))))
|
|
1021 (setq a (concat (substring a 0 p)
|
|
1022 (format fmt (+ (aref a p) 64))
|
|
1023 (substring a (1+ p)))
|
|
1024 p (+ p 2))))))
|
|
1025 (if quoted
|
|
1026 (concat "\"" a "\"")
|
|
1027 a)
|
|
1028 )
|
|
1029 (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
|
|
1030 ( ?\\ . "\\\\" )
|
|
1031 ( ?\a . "\\a" )
|
|
1032 ( ?\b . "\\b" )
|
|
1033 ( ?\e . "\\e" )
|
|
1034 ( ?\f . "\\f" )
|
|
1035 ( ?\n . "\\n" )
|
|
1036 ( ?\r . "\\r" )
|
|
1037 ( ?\t . "\\t" )
|
|
1038 ( ?\^? . "\\^?" )
|
|
1039 ))
|
|
1040
|
|
1041 (defun math-to-underscores (x)
|
|
1042 (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
|
|
1043 (math-to-underscores
|
|
1044 (concat (math-match-substring x 1) "_" (math-match-substring x 2)))
|
|
1045 x)
|
|
1046 )
|
|
1047
|
|
1048 (defun math-tex-expr-is-flat (a)
|
|
1049 (or (Math-integerp a)
|
|
1050 (memq (car a) '(float var))
|
|
1051 (and (memq (car a) '(+ - * neg))
|
|
1052 (progn
|
|
1053 (while (and (setq a (cdr a))
|
|
1054 (math-tex-expr-is-flat (car a))))
|
|
1055 (null a)))
|
|
1056 (and (memq (car a) '(^ calcFunc-subscr))
|
|
1057 (math-tex-expr-is-flat (nth 1 a))))
|
|
1058 )
|
|
1059
|
|
1060 (put 'calcFunc-log 'math-compose-big 'math-compose-log)
|
|
1061 (defun math-compose-log (a prec)
|
|
1062 (and (= (length a) 3)
|
|
1063 (list 'horiz
|
|
1064 (list 'subscr "log"
|
|
1065 (let ((calc-language 'flat))
|
|
1066 (math-compose-expr (nth 2 a) 1000)))
|
|
1067 "("
|
|
1068 (math-compose-expr (nth 1 a) 1000)
|
|
1069 ")"))
|
|
1070 )
|
|
1071
|
|
1072 (put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
|
|
1073 (defun math-compose-log10 (a prec)
|
|
1074 (and (= (length a) 2)
|
|
1075 (list 'horiz
|
|
1076 (list 'subscr "log" "10")
|
|
1077 "("
|
|
1078 (math-compose-expr (nth 1 a) 1000)
|
|
1079 ")"))
|
|
1080 )
|
|
1081
|
|
1082 (put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
|
|
1083 (put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
|
|
1084 (defun math-compose-deriv (a prec)
|
|
1085 (and (= (length a) 3)
|
|
1086 (math-compose-expr (list '/
|
|
1087 (list 'calcFunc-choriz
|
|
1088 (list 'vec
|
|
1089 '(calcFunc-string (vec ?d))
|
|
1090 (nth 1 a)))
|
|
1091 (list 'calcFunc-choriz
|
|
1092 (list 'vec
|
|
1093 '(calcFunc-string (vec ?d))
|
|
1094 (nth 2 a))))
|
|
1095 prec))
|
|
1096 )
|
|
1097
|
|
1098 (put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
|
|
1099 (defun math-compose-sqrt (a prec)
|
|
1100 (and (= (length a) 2)
|
|
1101 (let* ((c (math-compose-expr (nth 1 a) 0))
|
|
1102 (a (math-comp-ascent c))
|
|
1103 (d (math-comp-descent c))
|
|
1104 (h (+ a d))
|
|
1105 (w (math-comp-width c)))
|
|
1106 (list 'vleft
|
|
1107 a
|
|
1108 (concat (if (= h 1) " " " ")
|
|
1109 (make-string (+ w 2) ?\_))
|
|
1110 (list 'horiz
|
|
1111 (if (= h 1)
|
|
1112 "V"
|
|
1113 (append (list 'vleft (1- a))
|
|
1114 (make-list (1- h) " |")
|
|
1115 '("\\|")))
|
|
1116 " "
|
|
1117 c))))
|
|
1118 )
|
|
1119
|
|
1120 (put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
|
|
1121 (defun math-compose-choose (a prec)
|
|
1122 (let ((a1 (math-compose-expr (nth 1 a) 0))
|
|
1123 (a2 (math-compose-expr (nth 2 a) 0)))
|
|
1124 (list 'horiz
|
|
1125 "("
|
|
1126 (list 'vcent
|
|
1127 (math-comp-height a1)
|
|
1128 a1 " " a2)
|
|
1129 ")"))
|
|
1130 )
|
|
1131
|
|
1132 (put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
|
|
1133 (defun math-compose-integ (a prec)
|
|
1134 (and (memq (length a) '(3 5))
|
|
1135 (eq (car-safe (nth 2 a)) 'var)
|
|
1136 (let* ((parens (and (>= prec 196) (/= prec 1000)))
|
|
1137 (var (math-compose-expr (nth 2 a) 0))
|
|
1138 (over (and (eq (car-safe (nth 2 a)) 'var)
|
|
1139 (or (and (eq (car-safe (nth 1 a)) '/)
|
|
1140 (math-numberp (nth 1 (nth 1 a))))
|
|
1141 (and (eq (car-safe (nth 1 a)) '^)
|
|
1142 (math-looks-negp (nth 2 (nth 1 a)))))))
|
|
1143 (expr (math-compose-expr (if over
|
|
1144 (math-mul (nth 1 a)
|
|
1145 (math-build-var-name
|
|
1146 (format
|
|
1147 "d%s"
|
|
1148 (nth 1 (nth 2 a)))))
|
|
1149 (nth 1 a)) 185))
|
|
1150 (calc-language 'flat)
|
|
1151 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
|
|
1152 (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
|
|
1153 (list 'horiz
|
|
1154 (if parens "(" "")
|
|
1155 (append (list 'vcent (if high 3 2))
|
|
1156 (and high (list (list 'horiz " " high)))
|
|
1157 '(" /"
|
|
1158 " | "
|
|
1159 " | "
|
|
1160 " | "
|
|
1161 "/ ")
|
|
1162 (and low (list (list 'horiz low " "))))
|
|
1163 expr
|
|
1164 (if over
|
|
1165 ""
|
|
1166 (list 'horiz " d" var))
|
|
1167 (if parens ")" ""))))
|
|
1168 )
|
|
1169
|
|
1170 (put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
|
|
1171 (defun math-compose-sum (a prec)
|
|
1172 (and (memq (length a) '(3 5 6))
|
|
1173 (let* ((expr (math-compose-expr (nth 1 a) 185))
|
|
1174 (calc-language 'flat)
|
|
1175 (var (math-compose-expr (nth 2 a) 0))
|
|
1176 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
|
|
1177 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
|
|
1178 (list 'horiz
|
|
1179 (if (memq prec '(180 201)) "(" "")
|
|
1180 (append (list 'vcent (if high 3 2))
|
|
1181 (and high (list high))
|
|
1182 '("---- "
|
|
1183 "\\ "
|
|
1184 " > "
|
|
1185 "/ "
|
|
1186 "---- ")
|
|
1187 (if low
|
|
1188 (list (list 'horiz var " = " low))
|
|
1189 (list var)))
|
|
1190 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
|
|
1191 " " "")
|
|
1192 expr
|
|
1193 (if (memq prec '(180 201)) ")" ""))))
|
|
1194 )
|
|
1195
|
|
1196 (put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
|
|
1197 (defun math-compose-prod (a prec)
|
|
1198 (and (memq (length a) '(3 5 6))
|
|
1199 (let* ((expr (math-compose-expr (nth 1 a) 198))
|
|
1200 (calc-language 'flat)
|
|
1201 (var (math-compose-expr (nth 2 a) 0))
|
|
1202 (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
|
|
1203 (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
|
|
1204 (list 'horiz
|
|
1205 (if (memq prec '(196 201)) "(" "")
|
|
1206 (append (list 'vcent (if high 3 2))
|
|
1207 (and high (list high))
|
|
1208 '("----- "
|
|
1209 " | | "
|
|
1210 " | | "
|
|
1211 " | | ")
|
|
1212 (if low
|
|
1213 (list (list 'horiz var " = " low))
|
|
1214 (list var)))
|
|
1215 (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
|
|
1216 " " "")
|
|
1217 expr
|
|
1218 (if (memq prec '(196 201)) ")" ""))))
|
|
1219 )
|
|
1220
|
|
1221
|
|
1222 (defun math-stack-value-offset-fancy ()
|
|
1223 (let ((cwid (+ (math-comp-width c))))
|
|
1224 (cond ((eq calc-display-just 'right)
|
|
1225 (if calc-display-origin
|
|
1226 (setq wid (max calc-display-origin 5))
|
|
1227 (if (integerp calc-line-breaking)
|
|
1228 (setq wid calc-line-breaking)))
|
|
1229 (setq off (- wid cwid
|
|
1230 (max (- (length calc-right-label)
|
|
1231 (if (and (integerp calc-line-breaking)
|
|
1232 calc-display-origin)
|
|
1233 (max (- calc-line-breaking
|
|
1234 calc-display-origin)
|
|
1235 0)
|
|
1236 0))
|
|
1237 0))))
|
|
1238 (t
|
|
1239 (if calc-display-origin
|
|
1240 (progn
|
|
1241 (setq off (- calc-display-origin (/ cwid 2)))
|
|
1242 (if (integerp calc-line-breaking)
|
|
1243 (setq off (min off (- calc-line-breaking cwid
|
|
1244 (length calc-right-label)))))
|
|
1245 (if (>= off 0)
|
|
1246 (setq wid (max wid (+ off cwid)))))
|
|
1247 (if (integerp calc-line-breaking)
|
|
1248 (setq wid calc-line-breaking))
|
|
1249 (setq off (/ (- wid cwid) 2)))))
|
|
1250 (and (integerp calc-line-breaking)
|
|
1251 (or (< off 0)
|
|
1252 (and calc-display-origin
|
|
1253 (> calc-line-breaking calc-display-origin)))
|
|
1254 (setq wid calc-line-breaking)))
|
|
1255 )
|
|
1256
|
|
1257
|
|
1258
|
|
1259 ;;; Convert a composition to string form, with embedded \n's if necessary.
|
|
1260
|
|
1261 (defun math-composition-to-string (c &optional width)
|
|
1262 (or width (setq width (calc-window-width)))
|
|
1263 (if calc-display-raw
|
|
1264 (math-comp-to-string-raw c 0)
|
|
1265 (if (math-comp-is-flat c)
|
|
1266 (math-comp-to-string-flat c width)
|
|
1267 (math-vert-comp-to-string
|
|
1268 (math-comp-simplify c width))))
|
|
1269 )
|
|
1270
|
|
1271 (defun math-comp-is-flat (c) ; check if c's height is 1.
|
|
1272 (cond ((not (consp c)) t)
|
|
1273 ((memq (car c) '(set break)) t)
|
|
1274 ((eq (car c) 'horiz)
|
|
1275 (while (and (setq c (cdr c))
|
|
1276 (math-comp-is-flat (car c))))
|
|
1277 (null c))
|
|
1278 ((memq (car c) '(vleft vcent vright))
|
|
1279 (and (= (length c) 3)
|
|
1280 (= (nth 1 c) 0)
|
|
1281 (math-comp-is-flat (nth 2 c))))
|
|
1282 ((eq (car c) 'tag)
|
|
1283 (math-comp-is-flat (nth 2 c)))
|
|
1284 (t nil))
|
|
1285 )
|
|
1286
|
|
1287
|
|
1288 ;;; Convert a one-line composition to a string. Break into multiple
|
|
1289 ;;; lines if necessary, choosing break points according to the structure
|
|
1290 ;;; of the formula.
|
|
1291
|
|
1292 (defun math-comp-to-string-flat (c full-width)
|
|
1293 (if math-comp-sel-hpos
|
|
1294 (let ((comp-pos 0))
|
|
1295 (math-comp-sel-flat-term c))
|
|
1296 (let ((comp-buf "")
|
|
1297 (comp-word "")
|
|
1298 (comp-pos 0)
|
|
1299 (comp-margin 0)
|
|
1300 (comp-highlight (and math-comp-selected calc-show-selections))
|
|
1301 (comp-level -1))
|
|
1302 (math-comp-to-string-flat-term '(set -1 0))
|
|
1303 (math-comp-to-string-flat-term c)
|
|
1304 (math-comp-to-string-flat-term '(break -1))
|
|
1305 (let ((str (aref math-comp-buf-string 0))
|
|
1306 (prefix ""))
|
|
1307 (and (> (length str) 0) (= (aref str 0) ? )
|
|
1308 (> (length comp-buf) 0)
|
|
1309 (let ((k (length comp-buf)))
|
|
1310 (while (not (= (aref comp-buf (setq k (1- k))) ?\n)))
|
|
1311 (aset comp-buf k ? )
|
|
1312 (if (and (< (1+ k) (length comp-buf))
|
|
1313 (= (aref comp-buf (1+ k)) ? ))
|
|
1314 (progn
|
|
1315 (aset comp-buf (1+ k) ?\n)
|
|
1316 (setq prefix " "))
|
|
1317 (setq prefix "\n"))))
|
|
1318 (concat comp-buf prefix str))))
|
|
1319 )
|
|
1320 (setq math-comp-buf-string (make-vector 10 ""))
|
|
1321 (setq math-comp-buf-margin (make-vector 10 0))
|
|
1322 (setq math-comp-buf-level (make-vector 10 0))
|
|
1323
|
|
1324 (defun math-comp-to-string-flat-term (c)
|
|
1325 (cond ((not (consp c))
|
|
1326 (if comp-highlight
|
|
1327 (setq c (math-comp-highlight-string c)))
|
|
1328 (setq comp-word (if (= (length comp-word) 0) c (concat comp-word c))
|
|
1329 comp-pos (+ comp-pos (length c))))
|
|
1330
|
|
1331 ((eq (car c) 'horiz)
|
|
1332 (while (setq c (cdr c))
|
|
1333 (math-comp-to-string-flat-term (car c))))
|
|
1334
|
|
1335 ((eq (car c) 'set)
|
|
1336 (if (nth 1 c)
|
|
1337 (progn
|
|
1338 (setq comp-level (1+ comp-level))
|
|
1339 (if (>= comp-level (length math-comp-buf-string))
|
|
1340 (setq math-comp-buf-string (vconcat math-comp-buf-string
|
|
1341 math-comp-buf-string)
|
|
1342 math-comp-buf-margin (vconcat math-comp-buf-margin
|
|
1343 math-comp-buf-margin)
|
|
1344 math-comp-buf-level (vconcat math-comp-buf-level
|
|
1345 math-comp-buf-level)))
|
|
1346 (aset math-comp-buf-string comp-level "")
|
|
1347 (aset math-comp-buf-margin comp-level (+ comp-pos
|
|
1348 (or (nth 2 c) 0)))
|
|
1349 (aset math-comp-buf-level comp-level (nth 1 c)))))
|
|
1350
|
|
1351 ((eq (car c) 'break)
|
|
1352 (if (not calc-line-breaking)
|
|
1353 (setq comp-buf (concat comp-buf comp-word)
|
|
1354 comp-word "")
|
|
1355 (let ((i 0) str)
|
|
1356 (if (and (> comp-pos full-width)
|
|
1357 (progn
|
|
1358 (while (progn
|
|
1359 (setq str (aref math-comp-buf-string i))
|
|
1360 (and (= (length str) 0) (< i comp-level)))
|
|
1361 (setq i (1+ i)))
|
|
1362 (or (> (length str) 0) (> (length comp-buf) 0))))
|
|
1363 (let ((prefix "") mrg wid)
|
|
1364 (setq mrg (aref math-comp-buf-margin i))
|
|
1365 (if (> mrg 12) ; indenting too far, go back to far left
|
|
1366 (let ((j i) (new (if calc-line-numbering 5 1)))
|
|
1367 '(while (<= j comp-level)
|
|
1368 (aset math-comp-buf-margin j
|
|
1369 (+ (aref math-comp-buf-margin j) (- new mrg)))
|
|
1370 (setq j (1+ j)))
|
|
1371 (setq mrg new)))
|
|
1372 (setq wid (+ (length str) comp-margin))
|
|
1373 (and (> (length str) 0) (= (aref str 0) ? )
|
|
1374 (> (length comp-buf) 0)
|
|
1375 (let ((k (length comp-buf)))
|
|
1376 (while (not (= (aref comp-buf (setq k (1- k))) ?\n)))
|
|
1377 (aset comp-buf k ? )
|
|
1378 (if (and (< (1+ k) (length comp-buf))
|
|
1379 (= (aref comp-buf (1+ k)) ? ))
|
|
1380 (progn
|
|
1381 (aset comp-buf (1+ k) ?\n)
|
|
1382 (setq prefix " "))
|
|
1383 (setq prefix "\n"))))
|
|
1384 (setq comp-buf (concat comp-buf prefix str "\n"
|
|
1385 (make-string mrg ? ))
|
|
1386 comp-pos (+ comp-pos (- mrg wid))
|
|
1387 comp-margin mrg)
|
|
1388 (aset math-comp-buf-string i "")
|
|
1389 (while (<= (setq i (1+ i)) comp-level)
|
|
1390 (if (> (aref math-comp-buf-margin i) wid)
|
|
1391 (aset math-comp-buf-margin i
|
|
1392 (+ (aref math-comp-buf-margin i)
|
|
1393 (- mrg wid))))))))
|
|
1394 (if (and (= (nth 1 c) (aref math-comp-buf-level comp-level))
|
|
1395 (< comp-pos (+ (aref math-comp-buf-margin comp-level) 2)))
|
|
1396 () ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
|
|
1397 (let ((str (aref math-comp-buf-string comp-level)))
|
|
1398 (setq str (if (= (length str) 0)
|
|
1399 comp-word
|
|
1400 (concat str comp-word))
|
|
1401 comp-word "")
|
|
1402 (while (< (nth 1 c) (aref math-comp-buf-level comp-level))
|
|
1403 (setq comp-level (1- comp-level))
|
|
1404 (or (= (length (aref math-comp-buf-string comp-level)) 0)
|
|
1405 (setq str (concat (aref math-comp-buf-string comp-level)
|
|
1406 str))))
|
|
1407 (aset math-comp-buf-string comp-level str)))))
|
|
1408
|
|
1409 ((eq (car c) 'tag)
|
|
1410 (cond ((eq (nth 1 c) math-comp-selected)
|
|
1411 (let ((comp-highlight (not calc-show-selections)))
|
|
1412 (math-comp-to-string-flat-term (nth 2 c))))
|
|
1413 ((eq (nth 1 c) t)
|
|
1414 (let ((comp-highlight nil))
|
|
1415 (math-comp-to-string-flat-term (nth 2 c))))
|
|
1416 (t (math-comp-to-string-flat-term (nth 2 c)))))
|
|
1417
|
|
1418 (t (math-comp-to-string-flat-term (nth 2 c))))
|
|
1419 )
|
|
1420
|
|
1421 (defun math-comp-highlight-string (s)
|
|
1422 (setq s (copy-sequence s))
|
|
1423 (let ((i (length s)))
|
|
1424 (while (>= (setq i (1- i)) 0)
|
|
1425 (or (memq (aref s i) '(32 ?\n))
|
|
1426 (aset s i (if calc-show-selections ?\. ?\#)))))
|
|
1427 s
|
|
1428 )
|
|
1429
|
|
1430 (defun math-comp-sel-flat-term (c)
|
|
1431 (cond ((not (consp c))
|
|
1432 (setq comp-pos (+ comp-pos (length c))))
|
|
1433 ((memq (car c) '(set break)))
|
|
1434 ((eq (car c) 'horiz)
|
|
1435 (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
|
|
1436 (math-comp-sel-flat-term (car c))))
|
|
1437 ((eq (car c) 'tag)
|
|
1438 (if (<= comp-pos math-comp-sel-cpos)
|
|
1439 (progn
|
|
1440 (math-comp-sel-flat-term (nth 2 c))
|
|
1441 (if (> comp-pos math-comp-sel-cpos)
|
|
1442 (setq math-comp-sel-tag c
|
|
1443 math-comp-sel-cpos 1000000)))
|
|
1444 (math-comp-sel-flat-term (nth 2 c))))
|
|
1445 (t (math-comp-sel-flat-term (nth 2 c))))
|
|
1446 )
|
|
1447
|
|
1448
|
|
1449 ;;; Simplify a composition to a canonical form consisting of
|
|
1450 ;;; (vleft n "string" "string" "string" ...)
|
|
1451 ;;; where 0 <= n < number-of-strings.
|
|
1452
|
|
1453 (defun math-comp-simplify (c full-width)
|
|
1454 (let ((comp-buf (list ""))
|
|
1455 (comp-base 0)
|
|
1456 (comp-height 1)
|
|
1457 (comp-hpos 0)
|
|
1458 (comp-vpos 0)
|
|
1459 (comp-highlight (and math-comp-selected calc-show-selections))
|
|
1460 (comp-tag nil))
|
|
1461 (math-comp-simplify-term c)
|
|
1462 (cons 'vleft (cons comp-base comp-buf)))
|
|
1463 )
|
|
1464
|
|
1465 (defun math-comp-add-string (s h v)
|
|
1466 (and (> (length s) 0)
|
|
1467 (let ((vv (+ v comp-base)))
|
|
1468 (if math-comp-sel-hpos
|
|
1469 (math-comp-add-string-sel h vv (length s) 1)
|
|
1470 (if (< vv 0)
|
|
1471 (setq comp-buf (nconc (make-list (- vv) "") comp-buf)
|
|
1472 comp-base (- v)
|
|
1473 comp-height (- comp-height vv)
|
|
1474 vv 0)
|
|
1475 (if (>= vv comp-height)
|
|
1476 (setq comp-buf (nconc comp-buf
|
|
1477 (make-list (1+ (- vv comp-height)) ""))
|
|
1478 comp-height (1+ vv))))
|
|
1479 (let ((str (nthcdr vv comp-buf)))
|
|
1480 (setcar str (concat (car str)
|
|
1481 (make-string (- h (length (car str))) 32)
|
|
1482 (if comp-highlight
|
|
1483 (math-comp-highlight-string s)
|
|
1484 s)))))))
|
|
1485 )
|
|
1486
|
|
1487 (defun math-comp-add-string-sel (x y w h)
|
|
1488 (if (and (<= y math-comp-sel-vpos)
|
|
1489 (> (+ y h) math-comp-sel-vpos)
|
|
1490 (<= x math-comp-sel-hpos)
|
|
1491 (> (+ x w) math-comp-sel-hpos))
|
|
1492 (setq math-comp-sel-tag comp-tag
|
|
1493 math-comp-sel-vpos 10000))
|
|
1494 )
|
|
1495
|
|
1496 (defun math-comp-simplify-term (c)
|
|
1497 (cond ((stringp c)
|
|
1498 (math-comp-add-string c comp-hpos comp-vpos)
|
|
1499 (setq comp-hpos (+ comp-hpos (length c))))
|
|
1500 ((memq (car c) '(set break))
|
|
1501 nil)
|
|
1502 ((eq (car c) 'horiz)
|
|
1503 (while (setq c (cdr c))
|
|
1504 (math-comp-simplify-term (car c))))
|
|
1505 ((memq (car c) '(vleft vcent vright))
|
|
1506 (let* ((comp-vpos (+ (- comp-vpos (nth 1 c))
|
|
1507 (1- (math-comp-ascent (nth 2 c)))))
|
|
1508 (widths (mapcar 'math-comp-width (cdr (cdr c))))
|
|
1509 (maxwid (apply 'max widths))
|
|
1510 (bias (cond ((eq (car c) 'vleft) 0)
|
|
1511 ((eq (car c) 'vcent) 1)
|
|
1512 (t 2))))
|
|
1513 (setq c (cdr c))
|
|
1514 (while (setq c (cdr c))
|
|
1515 (if (eq (car-safe (car c)) 'rule)
|
|
1516 (math-comp-add-string (make-string maxwid (nth 1 (car c)))
|
|
1517 comp-hpos comp-vpos)
|
|
1518 (let ((comp-hpos (+ comp-hpos (/ (* bias (- maxwid
|
|
1519 (car widths)))
|
|
1520 2))))
|
|
1521 (math-comp-simplify-term (car c))))
|
|
1522 (and (cdr c)
|
|
1523 (setq comp-vpos (+ comp-vpos
|
|
1524 (+ (math-comp-descent (car c))
|
|
1525 (math-comp-ascent (nth 1 c))))
|
|
1526 widths (cdr widths))))
|
|
1527 (setq comp-hpos (+ comp-hpos maxwid))))
|
|
1528 ((eq (car c) 'supscr)
|
|
1529 (let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
|
|
1530 (desc (math-comp-descent (nth 2 c)))
|
|
1531 (oldh (prog1
|
|
1532 comp-hpos
|
|
1533 (math-comp-simplify-term (nth 1 c))))
|
|
1534 (comp-vpos (- comp-vpos (+ asc desc))))
|
|
1535 (math-comp-simplify-term (nth 2 c))
|
|
1536 (if math-comp-sel-hpos
|
|
1537 (math-comp-add-string-sel oldh
|
|
1538 (- comp-vpos
|
|
1539 -1
|
|
1540 (math-comp-ascent (nth 2 c)))
|
|
1541 (- comp-hpos oldh)
|
|
1542 (math-comp-height c)))))
|
|
1543 ((eq (car c) 'subscr)
|
|
1544 (let* ((asc (math-comp-ascent (nth 2 c)))
|
|
1545 (desc (math-comp-descent (nth 1 c)))
|
|
1546 (oldv comp-vpos)
|
|
1547 (oldh (prog1
|
|
1548 comp-hpos
|
|
1549 (math-comp-simplify-term (nth 1 c))))
|
|
1550 (comp-vpos (+ comp-vpos (+ asc desc))))
|
|
1551 (math-comp-simplify-term (nth 2 c))
|
|
1552 (if math-comp-sel-hpos
|
|
1553 (math-comp-add-string-sel oldh oldv
|
|
1554 (- comp-hpos oldh)
|
|
1555 (math-comp-height c)))))
|
|
1556 ((eq (car c) 'tag)
|
|
1557 (cond ((eq (nth 1 c) math-comp-selected)
|
|
1558 (let ((comp-highlight (not calc-show-selections)))
|
|
1559 (math-comp-simplify-term (nth 2 c))))
|
|
1560 ((eq (nth 1 c) t)
|
|
1561 (let ((comp-highlight nil))
|
|
1562 (math-comp-simplify-term (nth 2 c))))
|
|
1563 (t (let ((comp-tag c))
|
|
1564 (math-comp-simplify-term (nth 2 c)))))))
|
|
1565 )
|
|
1566
|
|
1567
|
|
1568 ;;; Measuring a composition.
|
|
1569
|
|
1570 (defun math-comp-first-char (c)
|
|
1571 (cond ((stringp c)
|
|
1572 (and (> (length c) 0)
|
|
1573 (elt c 0)))
|
|
1574 ((memq (car c) '(horiz subscr supscr))
|
|
1575 (while (and (setq c (cdr c))
|
|
1576 (math-comp-is-null (car c))))
|
|
1577 (and c (math-comp-first-char (car c))))
|
|
1578 ((eq (car c) 'tag)
|
|
1579 (math-comp-first-char (nth 2 c))))
|
|
1580 )
|
|
1581
|
|
1582 (defun math-comp-first-string (c)
|
|
1583 (cond ((stringp c)
|
|
1584 (and (> (length c) 0)
|
|
1585 c))
|
|
1586 ((eq (car c) 'horiz)
|
|
1587 (while (and (setq c (cdr c))
|
|
1588 (math-comp-is-null (car c))))
|
|
1589 (and c (math-comp-first-string (car c))))
|
|
1590 ((eq (car c) 'tag)
|
|
1591 (math-comp-first-string (nth 2 c))))
|
|
1592 )
|
|
1593
|
|
1594 (defun math-comp-last-char (c)
|
|
1595 (cond ((stringp c)
|
|
1596 (and (> (length c) 0)
|
|
1597 (elt c (1- (length c)))))
|
|
1598 ((eq (car c) 'horiz)
|
|
1599 (let ((c (reverse (cdr c))))
|
|
1600 (while (and c (math-comp-is-null (car c)))
|
|
1601 (setq c (cdr c)))
|
|
1602 (and c (math-comp-last-char (car c)))))
|
|
1603 ((eq (car c) 'tag)
|
|
1604 (math-comp-last-char (nth 2 c))))
|
|
1605 )
|
|
1606
|
|
1607 (defun math-comp-is-null (c)
|
|
1608 (cond ((stringp c) (= (length c) 0))
|
|
1609 ((memq (car c) '(horiz subscr supscr))
|
|
1610 (while (and (setq c (cdr c))
|
|
1611 (math-comp-is-null (car c))))
|
|
1612 (null c))
|
|
1613 ((eq (car c) 'tag)
|
|
1614 (math-comp-is-null (nth 2 c)))
|
|
1615 ((memq (car c) '(set break)) t))
|
|
1616 )
|
|
1617
|
|
1618 (defun math-comp-width (c)
|
|
1619 (cond ((not (consp c)) (length c))
|
|
1620 ((memq (car c) '(horiz subscr supscr))
|
|
1621 (let ((accum 0))
|
|
1622 (while (setq c (cdr c))
|
|
1623 (setq accum (+ accum (math-comp-width (car c)))))
|
|
1624 accum))
|
|
1625 ((memq (car c) '(vcent vleft vright))
|
|
1626 (setq c (cdr c))
|
|
1627 (let ((accum 0))
|
|
1628 (while (setq c (cdr c))
|
|
1629 (setq accum (max accum (math-comp-width (car c)))))
|
|
1630 accum))
|
|
1631 ((eq (car c) 'tag)
|
|
1632 (math-comp-width (nth 2 c)))
|
|
1633 (t 0))
|
|
1634 )
|
|
1635
|
|
1636 (defun math-comp-height (c)
|
|
1637 (if (stringp c)
|
|
1638 1
|
|
1639 (+ (math-comp-ascent c) (math-comp-descent c)))
|
|
1640 )
|
|
1641
|
|
1642 (defun math-comp-ascent (c)
|
|
1643 (cond ((not (consp c)) 1)
|
|
1644 ((eq (car c) 'horiz)
|
|
1645 (let ((accum 0))
|
|
1646 (while (setq c (cdr c))
|
|
1647 (setq accum (max accum (math-comp-ascent (car c)))))
|
|
1648 accum))
|
|
1649 ((memq (car c) '(vcent vleft vright))
|
|
1650 (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
|
|
1651 ((eq (car c) 'supscr)
|
|
1652 (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
|
|
1653 ((eq (car c) 'subscr)
|
|
1654 (math-comp-ascent (nth 1 c)))
|
|
1655 ((eq (car c) 'tag)
|
|
1656 (math-comp-ascent (nth 2 c)))
|
|
1657 (t 1))
|
|
1658 )
|
|
1659
|
|
1660 (defun math-comp-descent (c)
|
|
1661 (cond ((not (consp c)) 0)
|
|
1662 ((eq (car c) 'horiz)
|
|
1663 (let ((accum 0))
|
|
1664 (while (setq c (cdr c))
|
|
1665 (setq accum (max accum (math-comp-descent (car c)))))
|
|
1666 accum))
|
|
1667 ((memq (car c) '(vcent vleft vright))
|
|
1668 (let ((accum (- (nth 1 c))))
|
|
1669 (setq c (cdr c))
|
|
1670 (while (setq c (cdr c))
|
|
1671 (setq accum (+ accum (math-comp-height (car c)))))
|
|
1672 (max (1- accum) 0)))
|
|
1673 ((eq (car c) 'supscr)
|
|
1674 (math-comp-descent (nth 1 c)))
|
|
1675 ((eq (car c) 'subscr)
|
|
1676 (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
|
|
1677 ((eq (car c) 'tag)
|
|
1678 (math-comp-descent (nth 2 c)))
|
|
1679 (t 0))
|
|
1680 )
|
|
1681
|
|
1682 (defun calcFunc-cwidth (a &optional prec)
|
|
1683 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
1684 (math-comp-width (math-compose-expr a (or prec 0)))
|
|
1685 )
|
|
1686
|
|
1687 (defun calcFunc-cheight (a &optional prec)
|
|
1688 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
1689 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
|
|
1690 (memq (length a) '(2 3))
|
|
1691 (eq (nth 1 a) 0))
|
|
1692 0
|
|
1693 (math-comp-height (math-compose-expr a (or prec 0))))
|
|
1694 )
|
|
1695
|
|
1696 (defun calcFunc-cascent (a &optional prec)
|
|
1697 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
1698 (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
|
|
1699 (memq (length a) '(2 3))
|
|
1700 (eq (nth 1 a) 0))
|
|
1701 0
|
|
1702 (math-comp-ascent (math-compose-expr a (or prec 0))))
|
|
1703 )
|
|
1704
|
|
1705 (defun calcFunc-cdescent (a &optional prec)
|
|
1706 (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
1707 (math-comp-descent (math-compose-expr a (or prec 0)))
|
|
1708 )
|
|
1709
|
|
1710
|
|
1711 ;;; Convert a simplified composition into string form.
|
|
1712
|
|
1713 (defun math-vert-comp-to-string (c)
|
|
1714 (if (stringp c)
|
|
1715 c
|
|
1716 (math-vert-comp-to-string-step (cdr (cdr c))))
|
|
1717 )
|
|
1718
|
|
1719 (defun math-vert-comp-to-string-step (c)
|
|
1720 (if (cdr c)
|
|
1721 (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
|
|
1722 (car c))
|
|
1723 )
|
|
1724
|
|
1725
|
|
1726 ;;; Convert a composition to a string in "raw" form (for debugging).
|
|
1727
|
|
1728 (defun math-comp-to-string-raw (c indent)
|
|
1729 (cond ((or (not (consp c)) (eq (car c) 'set))
|
|
1730 (prin1-to-string c))
|
|
1731 ((null (cdr c))
|
|
1732 (concat "(" (symbol-name (car c)) ")"))
|
|
1733 (t
|
|
1734 (let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
|
|
1735 (concat "("
|
|
1736 (symbol-name (car c))
|
|
1737 " "
|
|
1738 (math-comp-to-string-raw (nth 1 c) next-indent)
|
|
1739 (math-comp-to-string-raw-step (cdr (cdr c))
|
|
1740 next-indent)
|
|
1741 ")"))))
|
|
1742 )
|
|
1743
|
|
1744 (defun math-comp-to-string-raw-step (cl indent)
|
|
1745 (if cl
|
|
1746 (concat "\n"
|
|
1747 (make-string indent 32)
|
|
1748 (math-comp-to-string-raw (car cl) indent)
|
|
1749 (math-comp-to-string-raw-step (cdr cl) indent))
|
|
1750 "")
|
|
1751 )
|
|
1752
|
|
1753
|
|
1754
|
|
1755
|