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