Mercurial > emacs
diff lisp/calc/calccomp.el @ 40785:2fb9d407ae73
Initial import of Calc 2.02f.
| author | Eli Zaretskii <eliz@gnu.org> |
|---|---|
| date | Tue, 06 Nov 2001 18:59:06 +0000 |
| parents | |
| children | 73f364fd8aaa |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/calc/calccomp.el Tue Nov 06 18:59:06 2001 +0000 @@ -0,0 +1,1755 @@ +;; Calculator for GNU Emacs, part II [calc-comp.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, daveg@synaptics.com. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-comp () nil) + + +;;; A "composition" has one of the following forms: +;;; +;;; "string" A literal string +;;; +;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions +;;; +;;; (set LEVEL OFF) Set left margin + offset for line-break level +;;; (break LEVEL) A potential line-break point +;;; +;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps +;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps +;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps +;;; N specifies baseline of the stack, 0=top line. +;;; +;;; (supscr C1 C2) Composition C1 with superscript C2 +;;; (subscr C1 C2) Composition C1 with subscript C2 +;;; (rule X) Horizontal line of X, full width of enclosing comp +;;; +;;; (tag X C) Composition C corresponds to sub-expression X + +(defun math-compose-expr (a prec) + (let ((math-compose-level (1+ math-compose-level))) + (cond + ((or (and (eq a math-comp-selected) a) + (and math-comp-tagged + (not (eq math-comp-tagged a)))) + (let ((math-comp-selected nil)) + (and math-comp-tagged (setq math-comp-tagged a)) + (list 'tag a (math-compose-expr a prec)))) + ((and (not (consp a)) (not (integerp a))) + (concat "'" (prin1-to-string a))) + ((math-scalarp a) + (if (or (eq (car-safe a) 'frac) + (and (nth 1 calc-frac-format) (Math-integerp a))) + (if (memq calc-language '(tex eqn math maple c fortran pascal)) + (let ((aa (math-adjust-fraction a)) + (calc-frac-format nil)) + (math-compose-expr (list '/ + (if (memq calc-language '(c fortran)) + (math-float (nth 1 aa)) + (nth 1 aa)) + (nth 2 aa)) prec)) + (if (and (eq calc-language 'big) + (= (length (car calc-frac-format)) 1)) + (let* ((aa (math-adjust-fraction a)) + (calc-frac-format nil) + (math-radix-explicit-format nil) + (c (list 'horiz + (if (math-negp (nth 1 aa)) + "- " "") + (list 'vcent 1 + (math-format-number + (math-abs (nth 1 aa))) + '(rule ?-) + (math-format-number (nth 2 aa)))))) + (if (= calc-number-radix 10) + c + (list 'horiz "(" c + (list 'subscr ")" + (int-to-string calc-number-radix))))) + (math-format-number a))) + (if (not (eq calc-language 'big)) + (math-format-number a prec) + (if (memq (car-safe a) '(cplx polar)) + (if (math-zerop (nth 2 a)) + (math-compose-expr (nth 1 a) prec) + (list 'horiz "(" + (math-compose-expr (nth 1 a) 0) + (if (eq (car a) 'cplx) ", " "; ") + (math-compose-expr (nth 2 a) 0) ")")) + (if (or (= calc-number-radix 10) + (not (Math-realp a)) + (and calc-group-digits + (not (assoc calc-group-char '((",") (" ")))))) + (math-format-number a prec) + (let ((s (math-format-number a prec)) + (c nil)) + (while (string-match (if (> calc-number-radix 14) + "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)" + "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)") + s) + (setq c (nconc c (list (substring s 0 (match-beginning 0)) + (list 'subscr + (math-match-substring s 2) + (math-match-substring s 1)))) + s (substring s (match-end 0)))) + (if (string-match + "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s) + (setq s (list 'horiz + (substring s 0 (match-beginning 0)) " " + (list 'supscr + (math-match-substring s 1) + (math-match-substring s 2)) + (math-match-substring s 3)))) + (if c (cons 'horiz (nconc c (list s))) s))))))) + ((and (get (car a) 'math-compose-forms) + (not (eq calc-language 'unform)) + (let ((comps (get (car a) 'math-compose-forms)) + temp temp2) + (or (and (setq temp (assq calc-language comps)) + (or (and (setq temp2 (assq (1- (length a)) (cdr temp))) + (setq temp (apply (cdr temp2) (cdr a))) + (math-compose-expr temp prec)) + (and (setq temp2 (assq nil (cdr temp))) + (funcall (cdr temp2) a)))) + (and (setq temp (assq nil comps)) + (or (and (setq temp2 (assq (1- (length a)) (cdr temp))) + (setq temp (apply (cdr temp2) (cdr a))) + (math-compose-expr temp prec)) + (and (setq temp2 (assq nil (cdr temp))) + (funcall (cdr temp2) a)))))))) + ((eq (car a) 'vec) + (let* ((left-bracket (if calc-vector-brackets + (substring calc-vector-brackets 0 1) "")) + (right-bracket (if calc-vector-brackets + (substring calc-vector-brackets 1 2) "")) + (inner-brackets (memq 'R calc-matrix-brackets)) + (outer-brackets (memq 'O calc-matrix-brackets)) + (row-commas (memq 'C calc-matrix-brackets)) + (comma-spc (or calc-vector-commas " ")) + (comma (or calc-vector-commas "")) + (vector-prec (if (or (and calc-vector-commas + (math-vector-no-parens a)) + (memq 'P calc-matrix-brackets)) 0 1000)) + (just (cond ((eq calc-matrix-just 'right) 'vright) + ((eq calc-matrix-just 'center) 'vcent) + (t 'vleft))) + (break calc-break-vectors)) + (if (and (memq calc-language '(nil big)) + (not calc-break-vectors) + (math-matrixp a) (not (math-matrixp (nth 1 a))) + (or calc-full-vectors + (and (< (length a) 7) (< (length (nth 1 a)) 7)) + (progn (setq break t) nil))) + (if (progn + (setq vector-prec (if (or (and calc-vector-commas + (math-vector-no-parens + (nth 1 a))) + (memq 'P calc-matrix-brackets)) + 0 1000)) + (= (length a) 2)) + (list 'horiz + (concat left-bracket left-bracket " ") + (math-compose-vector (cdr (nth 1 a)) (concat comma " ") + vector-prec) + (concat " " right-bracket right-bracket)) + (let* ((rows (1- (length a))) + (cols (1- (length (nth 1 a)))) + (base (/ (1- rows) 2)) + (calc-language 'flat)) + (append '(horiz) + (list (append '(vleft) + (list base) + (list (concat (and outer-brackets + (concat left-bracket + " ")) + (and inner-brackets + (concat left-bracket + " ")))) + (make-list (1- rows) + (concat (and outer-brackets + " ") + (and inner-brackets + (concat + left-bracket + " ")))))) + (math-compose-matrix (cdr a) 1 cols base) + (list (append '(vleft) + (list base) + (make-list (1- rows) + (if inner-brackets + (concat " " + right-bracket + (and row-commas + comma)) + (if (and outer-brackets + row-commas) + ";" ""))) + (list (concat + (and inner-brackets + (concat " " + right-bracket)) + (and outer-brackets + (concat + " " + right-bracket))))))))) + (if (and calc-display-strings + (cdr a) + (math-vector-is-string a)) + (math-vector-to-string a t) + (if (and break (cdr a) + (not (eq calc-language 'flat))) + (let* ((full (or calc-full-vectors (< (length a) 7))) + (rows (if full (1- (length a)) 5)) + (base (/ (1- rows) 2)) + (just 'vleft) + (calc-break-vectors nil)) + (list 'horiz + (cons 'vleft (cons base + (math-compose-rows + (cdr a) + (if full rows 3) t))))) + (if (or calc-full-vectors (< (length a) 7)) + (if (and (eq calc-language 'tex) + (math-matrixp a)) + (append '(horiz "\\matrix{ ") + (math-compose-tex-matrix (cdr a)) + '(" }")) + (if (and (eq calc-language 'eqn) + (math-matrixp a)) + (append '(horiz "matrix { ") + (math-compose-eqn-matrix + (cdr (math-transpose a))) + '("}")) + (if (and (eq calc-language 'maple) + (math-matrixp a)) + (list 'horiz + "matrix(" + left-bracket + (math-compose-vector (cdr a) (concat comma " ") + vector-prec) + right-bracket + ")") + (list 'horiz + left-bracket + (math-compose-vector (cdr a) (concat comma " ") + vector-prec) + right-bracket)))) + (list 'horiz + left-bracket + (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a)) + (concat comma " ") vector-prec) + comma (if (eq calc-language 'tex) " \\ldots" " ...") + comma " " + (list 'break math-compose-level) + (math-compose-expr (nth (1- (length a)) a) + (if (equal comma "") 1000 0)) + right-bracket))))))) + ((eq (car a) 'incomplete) + (if (cdr (cdr a)) + (cond ((eq (nth 1 a) 'vec) + (list 'horiz "[" + (math-compose-vector (cdr (cdr a)) ", " 0) + " ...")) + ((eq (nth 1 a) 'cplx) + (list 'horiz "(" + (math-compose-vector (cdr (cdr a)) ", " 0) + ", ...")) + ((eq (nth 1 a) 'polar) + (list 'horiz "(" + (math-compose-vector (cdr (cdr a)) "; " 0) + "; ...")) + ((eq (nth 1 a) 'intv) + (list 'horiz + (if (memq (nth 2 a) '(0 1)) "(" "[") + (math-compose-vector (cdr (cdr (cdr a))) " .. " 0) + " .. ...")) + (t (format "%s" a))) + (cond ((eq (nth 1 a) 'vec) "[ ...") + ((eq (nth 1 a) 'intv) + (if (memq (nth 2 a) '(0 1)) "( ..." "[ ...")) + (t "( ...")))) + ((eq (car a) 'var) + (let ((v (rassq (nth 2 a) math-expr-variable-mapping))) + (if v + (symbol-name (car v)) + (if (and (eq calc-language 'tex) + calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" + (symbol-name (nth 1 a)))) + (format "\\hbox{%s}" (symbol-name (nth 1 a))) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (if (memq calc-language '(c fortran pascal maple)) + (math-to-underscores (symbol-name (nth 1 a))) + (if (and (eq calc-language 'eqn) + (string-match ".'\\'" (symbol-name (nth 2 a)))) + (math-compose-expr + (list 'calcFunc-Prime + (list + 'var + (intern (substring (symbol-name (nth 1 a)) 0 -1)) + (intern (substring (symbol-name (nth 2 a)) 0 -1)))) + prec) + (symbol-name (nth 1 a))))))))) + ((eq (car a) 'intv) + (list 'horiz + (if (eq calc-language 'maple) "" + (if (memq (nth 1 a) '(0 1)) "(" "[")) + (math-compose-expr (nth 2 a) 0) + (if (eq calc-language 'tex) " \\ldots " + (if (eq calc-language 'eqn) " ... " " .. ")) + (math-compose-expr (nth 3 a) 0) + (if (eq calc-language 'maple) "" + (if (memq (nth 1 a) '(0 2)) ")" "]")))) + ((eq (car a) 'date) + (if (eq (car calc-date-format) 'X) + (math-format-date a) + (concat "<" (math-format-date a) ">"))) + ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a)) + (memq calc-language '(c pascal fortran maple))) + (let ((args (cdr (cdr a)))) + (while (and (memq calc-language '(pascal fortran)) + (eq (car-safe (nth 1 a)) 'calcFunc-subscr)) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + (if (eq calc-language 'fortran) "(" "[") + (math-compose-vector args ", " 0) + (if (eq calc-language 'fortran) ")" "]")))) + ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) + (eq calc-language 'big)) + (let* ((a1 (math-compose-expr (nth 1 a) 1000)) + (calc-language 'flat) + (a2 (math-compose-expr (nth 2 a) 0))) + (if (or (eq (car-safe a1) 'subscr) + (and (eq (car-safe a1) 'tag) + (eq (car-safe (nth 2 a1)) 'subscr) + (setq a1 (nth 2 a1)))) + (list 'subscr + (nth 1 a1) + (list 'horiz + (nth 2 a1) + ", " + a2)) + (list 'subscr a1 a2)))) + ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) + (eq calc-language 'math)) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[[" + (math-compose-expr (nth 2 a) 0) + "]]")) + ((and (eq (car a) 'calcFunc-sqrt) + (eq calc-language 'tex)) + (list 'horiz + "\\sqrt{" + (math-compose-expr (nth 1 a) 0) + "}")) + ((and nil (eq (car a) 'calcFunc-sqrt) + (eq calc-language 'eqn)) + (list 'horiz + "sqrt {" + (math-compose-expr (nth 1 a) -1) + "}")) + ((and (eq (car a) '^) + (eq calc-language 'big)) + (list 'supscr + (if (or (math-looks-negp (nth 1 a)) + (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt)) + (and (eq (car-safe (nth 1 a)) 'cplx) + (math-negp (nth 1 (nth 1 a))) + (eq (nth 2 (nth 1 a)) 0))) + (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")") + (math-compose-expr (nth 1 a) 201)) + (let ((calc-language 'flat) + (calc-number-radix 10)) + (math-compose-expr (nth 2 a) 0)))) + ((and (eq (car a) '/) + (eq calc-language 'big)) + (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac)) + 'flat 'big))) + (math-compose-expr (nth 1 a) 0))) + (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac)) + 'flat 'big))) + (math-compose-expr (nth 2 a) 0)))) + (list 'vcent + (math-comp-height a1) + a1 '(rule ?-) a2))) + ((and (memq (car a) '(calcFunc-sum calcFunc-prod)) + (eq calc-language 'tex) + (= (length a) 5)) + (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod") + "_{" (math-compose-expr (nth 2 a) 0) + "=" (math-compose-expr (nth 3 a) 0) + "}^{" (math-compose-expr (nth 4 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")) + ((and (eq (car a) 'calcFunc-lambda) + (> (length a) 2) + (memq calc-language '(nil flat big))) + (let ((p (cdr a)) + (ap calc-arg-values) + (math-compose-hash-args (if (= (length a) 3) 1 t))) + (while (and (cdr p) (equal (car p) (car ap))) + (setq p (cdr p) ap (cdr ap))) + (append '(horiz "<") + (if (cdr p) + (list (math-compose-vector + (nreverse (cdr (reverse (cdr a)))) ", " 0) + " : ") + nil) + (list (math-compose-expr (nth (1- (length a)) a) 0) + ">")))) + ((and (eq (car a) 'calcFunc-string) + (= (length a) 2) + (math-vectorp (nth 1 a)) + (math-vector-is-string (nth 1 a))) + (if (eq calc-language 'unform) + (concat "string(" (math-vector-to-string (nth 1 a) t) ")") + (math-vector-to-string (nth 1 a) nil))) + ((and (eq (car a) 'calcFunc-bstring) + (= (length a) 2) + (math-vectorp (nth 1 a)) + (math-vector-is-string (nth 1 a))) + (if (eq calc-language 'unform) + (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")") + (let ((c nil) + (s (math-vector-to-string (nth 1 a) nil)) + p) + (while (string-match "[^ ] +[^ ]" s) + (setq p (1- (match-end 0)) + c (cons (list 'break math-compose-level) + (cons (substring s 0 p) + c)) + s (substring s p))) + (setq c (nreverse (cons s c))) + (or (= prec -123) + (setq c (cons (list 'set math-compose-level 2) c))) + (cons 'horiz c)))) + ((and (eq (car a) 'calcFunc-cprec) + (not (eq calc-language 'unform)) + (= (length a) 3) + (integerp (nth 2 a))) + (let ((c (math-compose-expr (nth 1 a) -1))) + (if (> prec (nth 2 a)) + (if (eq calc-language 'tex) + (list 'horiz "\\left( " c " \\right)") + (if (eq calc-language 'eqn) + (list 'horiz "{left ( " c " right )}") + (list 'horiz "(" c ")"))) + c))) + ((and (eq (car a) 'calcFunc-choriz) + (not (eq calc-language 'unform)) + (memq (length a) '(2 3 4)) + (math-vectorp (nth 1 a)) + (if (integerp (nth 2 a)) + (or (null (nth 3 a)) + (and (math-vectorp (nth 3 a)) + (math-vector-is-string (nth 3 a)))) + (or (null (nth 2 a)) + (and (math-vectorp (nth 2 a)) + (math-vector-is-string (nth 2 a)))))) + (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a))) + (sep (nth (if cprec 3 2) a)) + (bprec nil)) + (if sep + (math-compose-vector (cdr (nth 1 a)) + (math-vector-to-string sep nil) + (or cprec prec)) + (cons 'horiz (mapcar (function + (lambda (x) + (if (eq (car-safe x) 'calcFunc-bstring) + (prog1 + (math-compose-expr + x (or bprec cprec prec)) + (setq bprec -123)) + (math-compose-expr x (or cprec prec))))) + (cdr (nth 1 a))))))) + ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert)) + (not (eq calc-language 'unform)) + (memq (length a) '(2 3)) + (math-vectorp (nth 1 a)) + (or (null (nth 2 a)) + (integerp (nth 2 a)))) + (let* ((base 0) + (v 0) + (prec (or (nth 2 a) prec)) + (c (mapcar (function + (lambda (x) + (let ((b nil) (cc nil) a d) + (if (and (memq (car-safe x) '(calcFunc-cbase + calcFunc-ctbase + calcFunc-cbbase)) + (memq (length x) '(1 2))) + (setq b (car x) + x (nth 1 x))) + (if (and (eq (car-safe x) 'calcFunc-crule) + (memq (length x) '(1 2)) + (or (null (nth 1 x)) + (and (math-vectorp (nth 1 x)) + (= (length (nth 1 x)) 2) + (math-vector-is-string + (nth 1 x))) + (and (natnump (nth 1 x)) + (<= (nth 1 x) 255)))) + (setq cc (list + 'rule + (if (math-vectorp (nth 1 x)) + (aref (math-vector-to-string + (nth 1 x) nil) 0) + (or (nth 1 x) ?-)))) + (or (and (memq (car-safe x) '(calcFunc-cvspace + calcFunc-ctspace + calcFunc-cbspace)) + (memq (length x) '(2 3)) + (eq (nth 1 x) 0)) + (null x) + (setq cc (math-compose-expr x prec)))) + (setq a (if cc (math-comp-ascent cc) 0) + d (if cc (math-comp-descent cc) 0)) + (if (eq b 'calcFunc-cbase) + (setq base (+ v a -1)) + (if (eq b 'calcFunc-ctbase) + (setq base v) + (if (eq b 'calcFunc-cbbase) + (setq base (+ v a d -1))))) + (setq v (+ v a d)) + cc))) + (cdr (nth 1 a))))) + (setq c (delq nil c)) + (if c + (cons (if (eq (car a) 'calcFunc-cvert) 'vcent + (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright)) + (cons base c)) + " "))) + ((and (memq (car a) '(calcFunc-csup calcFunc-csub)) + (not (eq calc-language 'unform)) + (memq (length a) '(3 4)) + (or (null (nth 3 a)) + (integerp (nth 3 a)))) + (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr) + (math-compose-expr (nth 1 a) (or (nth 3 a) 0)) + (math-compose-expr (nth 2 a) 0))) + ((and (eq (car a) 'calcFunc-cflat) + (not (eq calc-language 'unform)) + (memq (length a) '(2 3)) + (or (null (nth 2 a)) + (integerp (nth 2 a)))) + (let ((calc-language (if (memq calc-language '(nil big)) + 'flat calc-language))) + (math-compose-expr (nth 1 a) (or (nth 2 a) 0)))) + ((and (eq (car a) 'calcFunc-cspace) + (memq (length a) '(2 3)) + (natnump (nth 1 a))) + (if (nth 2 a) + (cons 'horiz (make-list (nth 1 a) + (if (and (math-vectorp (nth 2 a)) + (math-vector-is-string (nth 2 a))) + (math-vector-to-string (nth 2 a) nil) + (math-compose-expr (nth 2 a) 0)))) + (make-string (nth 1 a) ?\ ))) + ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace)) + (memq (length a) '(2 3)) + (natnump (nth 1 a))) + (if (= (nth 1 a) 0) + "" + (let* ((c (if (nth 2 a) + (if (and (math-vectorp (nth 2 a)) + (math-vector-is-string (nth 2 a))) + (math-vector-to-string (nth 2 a) nil) + (math-compose-expr (nth 2 a) 0)) + " ")) + (ca (math-comp-ascent c)) + (cd (math-comp-descent c))) + (cons 'vleft + (cons (if (eq (car a) 'calcFunc-ctspace) + (1- ca) + (if (eq (car a) 'calcFunc-cbspace) + (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca)) + (/ (1- (* (nth 1 a) (+ ca cd))) 2))) + (make-list (nth 1 a) c)))))) + ((and (eq (car a) 'calcFunc-evalto) + (setq calc-any-evaltos t) + (memq calc-language '(tex eqn)) + (= math-compose-level (if math-comp-tagged 2 1)) + (= (length a) 3)) + (list 'horiz + (if (eq calc-language 'tex) "\\evalto " "evalto ") + (math-compose-expr (nth 1 a) 0) + (if (eq calc-language 'tex) " \\to " " -> ") + (math-compose-expr (nth 2 a) 0))) + (t + (let ((op (and (not (eq calc-language 'unform)) + (if (and (eq (car a) 'calcFunc-if) (= (length a) 4)) + (assoc "?" math-expr-opers) + (math-assq2 (car a) math-expr-opers))))) + (cond ((and op + (or (= (length a) 3) (eq (car a) 'calcFunc-if)) + (/= (nth 3 op) -1)) + (cond + ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op)))) + (if (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat a))) + (if (eq (car-safe a) '/) + (list 'horiz "{" (math-compose-expr a -1) "}") + (list 'horiz "\\left( " + (math-compose-expr a -1) + " \\right)")) + (if (eq calc-language 'eqn) + (if (or (eq (car-safe a) '/) + (= (/ prec 100) 9)) + (list 'horiz "{" (math-compose-expr a -1) "}") + (if (math-tex-expr-is-flat a) + (list 'horiz "( " (math-compose-expr a -1) " )") + (list 'horiz "{left ( " + (math-compose-expr a -1) + " right )}"))) + (list 'horiz "(" (math-compose-expr a 0) ")")))) + ((and (eq calc-language 'tex) + (memq (car a) '(/ calcFunc-choose calcFunc-evalto)) + (>= prec 0)) + (list 'horiz "{" (math-compose-expr a -1) "}")) + ((eq (car a) 'calcFunc-if) + (list 'horiz + (math-compose-expr (nth 1 a) (nth 2 op)) + " ? " + (math-compose-expr (nth 2 a) 0) + " : " + (math-compose-expr (nth 3 a) (nth 3 op)))) + (t + (let* ((math-comp-tagged (and math-comp-tagged + (not (math-primp a)) + math-comp-tagged)) + (setlev (if (= prec (min (nth 2 op) (nth 3 op))) + (progn + (setq math-compose-level + (1- math-compose-level)) + nil) + math-compose-level)) + (lhs (math-compose-expr (nth 1 a) (nth 2 op))) + (rhs (math-compose-expr (nth 2 a) (nth 3 op)))) + (and (equal (car op) "^") + (eq (math-comp-first-char lhs) ?-) + (setq lhs (list 'horiz "(" lhs ")"))) + (and (eq calc-language 'tex) + (or (equal (car op) "^") (equal (car op) "_")) + (not (and (stringp rhs) (= (length rhs) 1))) + (setq rhs (list 'horiz "{" rhs "}"))) + (or (and (eq (car a) '*) + (or (null calc-language) + (assoc "2x" math-expr-opers)) + (let* ((prevt (math-prod-last-term (nth 1 a))) + (nextt (math-prod-first-term (nth 2 a))) + (prevc (or (math-comp-last-char lhs) + (and (memq (car-safe prevt) + '(^ calcFunc-subscr + calcFunc-sqrt + frac)) + (eq calc-language 'big) + ?0))) + (nextc (or (math-comp-first-char rhs) + (and (memq (car-safe nextt) + '(calcFunc-sqrt + calcFunc-sum + calcFunc-prod + calcFunc-integ)) + (eq calc-language 'big) + ?0)))) + (and prevc nextc + (or (and (>= nextc ?a) (<= nextc ?z)) + (and (>= nextc ?A) (<= nextc ?Z)) + (and (>= nextc ?0) (<= nextc ?9)) + (memq nextc '(?. ?_ ?# + ?\( ?\[ ?\{)) + (and (eq nextc ?\\) + (not (string-match + "\\`\\\\left(" + (math-comp-first-string + rhs))))) + (not (and (eq (car-safe prevt) 'var) + (eq nextc ?\())) + (list 'horiz + (list 'set setlev 1) + lhs + (list 'break math-compose-level) + " " + rhs)))) + (list 'horiz + (list 'set setlev 1) + lhs + (list 'break math-compose-level) + (if (or (equal (car op) "^") + (equal (car op) "_") + (equal (car op) "**") + (and (equal (car op) "*") + (math-comp-last-char lhs) + (math-comp-first-char rhs)) + (and (equal (car op) "/") + (math-num-integerp (nth 1 a)) + (math-integerp (nth 2 a)))) + (car op) + (if (and (eq calc-language 'big) + (equal (car op) "=>")) + " => " + (concat " " (car op) " "))) + rhs)))))) + ((and op (= (length a) 2) (= (nth 3 op) -1)) + (cond + ((or (> prec (or (nth 4 op) (nth 2 op))) + (and (not (eq (assoc (car op) math-expr-opers) op)) + (> prec 0))) ; don't write x% + y + (if (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat a))) + (list 'horiz "\\left( " + (math-compose-expr a -1) + " \\right)") + (if (eq calc-language 'eqn) + (if (= (/ prec 100) 9) + (list 'horiz "{" (math-compose-expr a -1) "}") + (if (math-tex-expr-is-flat a) + (list 'horiz "{( " (math-compose-expr a -1) " )}") + (list 'horiz "{left ( " + (math-compose-expr a -1) + " right )}"))) + (list 'horiz "(" (math-compose-expr a 0) ")")))) + (t + (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))) + (list 'horiz + lhs + (if (or (> (length (car op)) 1) + (not (math-comp-is-flat lhs))) + (concat " " (car op)) + (car op))))))) + ((and op (= (length a) 2) (= (nth 2 op) -1)) + (cond + ((eq (nth 3 op) 0) + (let ((lr (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat (nth 1 a)))))) + (list 'horiz + (if lr "\\left" "") + (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op)) + (substring (car op) 1) + (car op)) + (if (or lr (> (length (car op)) 2)) " " "") + (math-compose-expr (nth 1 a) -1) + (if (or lr (> (length (car op)) 2)) " " "") + (if lr "\\right" "") + (car (nth 1 (memq op math-expr-opers)))))) + ((> prec (or (nth 4 op) (nth 3 op))) + (if (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat a))) + (list 'horiz "\\left( " + (math-compose-expr a -1) + " \\right)") + (if (eq calc-language 'eqn) + (if (= (/ prec 100) 9) + (list 'horiz "{" (math-compose-expr a -1) "}") + (if (math-tex-expr-is-flat a) + (list 'horiz "{( " (math-compose-expr a -1) " )}") + (list 'horiz "{left ( " + (math-compose-expr a -1) + " right )}"))) + (list 'horiz "(" (math-compose-expr a 0) ")")))) + (t + (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op)))) + (list 'horiz + (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" + (car op)) + (substring (car op) 1) + (car op)))) + (if (or (> (length ops) 1) + (not (math-comp-is-flat rhs))) + (concat ops " ") + ops)) + rhs))))) + ((and (eq calc-language 'big) + (setq op (get (car a) 'math-compose-big)) + (funcall op a prec))) + ((and (setq op (assq calc-language + '( ( nil . math-compose-normal ) + ( flat . math-compose-normal ) + ( big . math-compose-normal ) + ( c . math-compose-c ) + ( pascal . math-compose-pascal ) + ( fortran . math-compose-fortran ) + ( tex . math-compose-tex ) + ( eqn . math-compose-eqn ) + ( math . math-compose-math ) + ( maple . math-compose-maple )))) + (setq op (get (car a) (cdr op))) + (funcall op a prec))) + (t + (let* ((func (car a)) + (func2 (assq func '(( mod . calcFunc-makemod ) + ( sdev . calcFunc-sdev ) + ( + . calcFunc-add ) + ( - . calcFunc-sub ) + ( * . calcFunc-mul ) + ( / . calcFunc-div ) + ( % . calcFunc-mod ) + ( ^ . calcFunc-pow ) + ( neg . calcFunc-neg ) + ( | . calcFunc-vconcat )))) + left right args) + (if func2 + (setq func (cdr func2))) + (if (setq func2 (rassq func math-expr-function-mapping)) + (setq func (car func2))) + (setq func (math-remove-dashes + (if (string-match + "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'" + (symbol-name func)) + (math-match-substring (symbol-name func) 1) + (symbol-name func)))) + (if (memq calc-language '(c fortran pascal maple)) + (setq func (math-to-underscores func))) + (if (and (eq calc-language 'tex) + calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) + (if (< (prefix-numeric-value calc-language-option) 0) + (setq func (format "\\%s" func)) + (setq func (format "\\hbox{%s}" func)))) + (if (and (eq calc-language 'eqn) + (string-match "[^']'+\\'" func)) + (let ((n (- (length func) (match-beginning 0) 1))) + (setq func (substring func 0 (- n))) + (while (>= (setq n (1- n)) 0) + (setq func (concat func " prime"))))) + (cond ((and (eq calc-language 'tex) + (or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a))))) + (setq left "\\left( " + right " \\right)")) + ((and (eq calc-language 'eqn) + (or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a))))) + (setq left "{left ( " + right " right )}")) + ((and (or (and (eq calc-language 'tex) + (eq (aref func 0) ?\\)) + (and (eq calc-language 'eqn) + (memq (car a) math-eqn-special-funcs))) + (not (string-match "\\hbox{" func)) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left (if (eq calc-language 'eqn) "~{" "{") + right "}")) + ((eq calc-language 'eqn) + (setq left " ( " + right " )")) + (t (setq left calc-function-open + right calc-function-close))) + (list 'horiz func left + (math-compose-vector (cdr a) + (if (eq calc-language 'eqn) + " , " ", ") + 0) + right)))))))) +) + +(defconst math-eqn-special-funcs + '( calcFunc-log + calcFunc-ln calcFunc-exp + calcFunc-sin calcFunc-cos calcFunc-tan + calcFunc-sinh calcFunc-cosh calcFunc-tanh + calcFunc-arcsin calcFunc-arccos calcFunc-arctan + calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh +)) + + +(defun math-prod-first-term (x) + (while (eq (car-safe x) '*) + (setq x (nth 1 x))) + x +) + +(defun math-prod-last-term (x) + (while (eq (car-safe x) '*) + (setq x (nth 2 x))) + x +) + +(defun math-compose-vector (a sep prec) + (if a + (cons 'horiz + (cons (list 'set math-compose-level) + (let ((c (list (math-compose-expr (car a) prec)))) + (while (setq a (cdr a)) + (setq c (cons (if (eq (car-safe (car a)) + 'calcFunc-bstring) + (let ((math-compose-level + (1- math-compose-level))) + (math-compose-expr (car a) -123)) + (math-compose-expr (car a) prec)) + (cons (list 'break math-compose-level) + (cons sep c))))) + (nreverse c)))) + "") +) + +(defun math-vector-no-parens (a) + (or (cdr (cdr a)) + (not (eq (car-safe (nth 1 a)) '*))) +) + +(defun math-compose-matrix (a col cols base) + (let ((col 0) + (res nil)) + (while (<= (setq col (1+ col)) cols) + (setq res (cons (cons just + (cons base + (mapcar (function + (lambda (r) + (list 'horiz + (math-compose-expr + (nth col r) + vector-prec) + (if (= col cols) + "" + (concat comma-spc " "))))) + a))) + res))) + (nreverse res)) +) + +(defun math-compose-rows (a count first) + (if (cdr a) + (if (<= count 0) + (if (< count 0) + (math-compose-rows (cdr a) -1 nil) + (cons (concat (if (eq calc-language 'tex) " \\ldots" " ...") + comma) + (math-compose-rows (cdr a) -1 nil))) + (cons (list 'horiz + (if first (concat left-bracket " ") " ") + (math-compose-expr (car a) vector-prec) + comma) + (math-compose-rows (cdr a) (1- count) nil))) + (list (list 'horiz + (if first (concat left-bracket " ") " ") + (math-compose-expr (car a) vector-prec) + (concat " " right-bracket)))) +) + +(defun math-compose-tex-matrix (a) + (if (cdr a) + (cons (math-compose-vector (cdr (car a)) " & " 0) + (cons " \\\\ " + (math-compose-tex-matrix (cdr a)))) + (list (math-compose-vector (cdr (car a)) " & " 0))) +) + +(defun math-compose-eqn-matrix (a) + (if a + (cons + (cond ((eq calc-matrix-just 'right) "rcol ") + ((eq calc-matrix-just 'center) "ccol ") + (t "lcol ")) + (cons + (list 'break math-compose-level) + (cons + "{ " + (cons + (let ((math-compose-level (1+ math-compose-level))) + (math-compose-vector (cdr (car a)) " above " 1000)) + (cons + " } " + (math-compose-eqn-matrix (cdr a))))))) + nil) +) + +(defun math-vector-is-string (a) + (while (and (setq a (cdr a)) + (or (and (natnump (car a)) + (<= (car a) 255)) + (and (eq (car-safe (car a)) 'cplx) + (natnump (nth 1 (car a))) + (eq (nth 2 (car a)) 0) + (<= (nth 1 (car a)) 255))))) + (null a) +) + +(defun math-vector-to-string (a &optional quoted) + (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x))) + (cdr a)))) + (if (string-match "[\000-\037\177\\\"]" a) + (let ((p 0) + (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]")) + (codes (if quoted math-vector-to-string-chars '((?\^? . "^?")))) + (fmt (if quoted "\\^%c" "^%c")) + new) + (while (setq p (string-match pat a p)) + (if (setq new (assq (aref a p) codes)) + (setq a (concat (substring a 0 p) + (cdr new) + (substring a (1+ p))) + p (+ p (length (cdr new)))) + (setq a (concat (substring a 0 p) + (format fmt (+ (aref a p) 64)) + (substring a (1+ p))) + p (+ p 2)))))) + (if quoted + (concat "\"" a "\"") + a) +) +(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" ) + ( ?\\ . "\\\\" ) + ( ?\a . "\\a" ) + ( ?\b . "\\b" ) + ( ?\e . "\\e" ) + ( ?\f . "\\f" ) + ( ?\n . "\\n" ) + ( ?\r . "\\r" ) + ( ?\t . "\\t" ) + ( ?\^? . "\\^?" ) +)) + +(defun math-to-underscores (x) + (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x) + (math-to-underscores + (concat (math-match-substring x 1) "_" (math-match-substring x 2))) + x) +) + +(defun math-tex-expr-is-flat (a) + (or (Math-integerp a) + (memq (car a) '(float var)) + (and (memq (car a) '(+ - * neg)) + (progn + (while (and (setq a (cdr a)) + (math-tex-expr-is-flat (car a)))) + (null a))) + (and (memq (car a) '(^ calcFunc-subscr)) + (math-tex-expr-is-flat (nth 1 a)))) +) + +(put 'calcFunc-log 'math-compose-big 'math-compose-log) +(defun math-compose-log (a prec) + (and (= (length a) 3) + (list 'horiz + (list 'subscr "log" + (let ((calc-language 'flat)) + (math-compose-expr (nth 2 a) 1000))) + "(" + (math-compose-expr (nth 1 a) 1000) + ")")) +) + +(put 'calcFunc-log10 'math-compose-big 'math-compose-log10) +(defun math-compose-log10 (a prec) + (and (= (length a) 2) + (list 'horiz + (list 'subscr "log" "10") + "(" + (math-compose-expr (nth 1 a) 1000) + ")")) +) + +(put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv) +(put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv) +(defun math-compose-deriv (a prec) + (and (= (length a) 3) + (math-compose-expr (list '/ + (list 'calcFunc-choriz + (list 'vec + '(calcFunc-string (vec ?d)) + (nth 1 a))) + (list 'calcFunc-choriz + (list 'vec + '(calcFunc-string (vec ?d)) + (nth 2 a)))) + prec)) +) + +(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt) +(defun math-compose-sqrt (a prec) + (and (= (length a) 2) + (let* ((c (math-compose-expr (nth 1 a) 0)) + (a (math-comp-ascent c)) + (d (math-comp-descent c)) + (h (+ a d)) + (w (math-comp-width c))) + (list 'vleft + a + (concat (if (= h 1) " " " ") + (make-string (+ w 2) ?\_)) + (list 'horiz + (if (= h 1) + "V" + (append (list 'vleft (1- a)) + (make-list (1- h) " |") + '("\\|"))) + " " + c)))) +) + +(put 'calcFunc-choose 'math-compose-big 'math-compose-choose) +(defun math-compose-choose (a prec) + (let ((a1 (math-compose-expr (nth 1 a) 0)) + (a2 (math-compose-expr (nth 2 a) 0))) + (list 'horiz + "(" + (list 'vcent + (math-comp-height a1) + a1 " " a2) + ")")) +) + +(put 'calcFunc-integ 'math-compose-big 'math-compose-integ) +(defun math-compose-integ (a prec) + (and (memq (length a) '(3 5)) + (eq (car-safe (nth 2 a)) 'var) + (let* ((parens (and (>= prec 196) (/= prec 1000))) + (var (math-compose-expr (nth 2 a) 0)) + (over (and (eq (car-safe (nth 2 a)) 'var) + (or (and (eq (car-safe (nth 1 a)) '/) + (math-numberp (nth 1 (nth 1 a)))) + (and (eq (car-safe (nth 1 a)) '^) + (math-looks-negp (nth 2 (nth 1 a))))))) + (expr (math-compose-expr (if over + (math-mul (nth 1 a) + (math-build-var-name + (format + "d%s" + (nth 1 (nth 2 a))))) + (nth 1 a)) 185)) + (calc-language 'flat) + (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) + (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0)))) + (list 'horiz + (if parens "(" "") + (append (list 'vcent (if high 3 2)) + (and high (list (list 'horiz " " high))) + '(" /" + " | " + " | " + " | " + "/ ") + (and low (list (list 'horiz low " ")))) + expr + (if over + "" + (list 'horiz " d" var)) + (if parens ")" "")))) +) + +(put 'calcFunc-sum 'math-compose-big 'math-compose-sum) +(defun math-compose-sum (a prec) + (and (memq (length a) '(3 5 6)) + (let* ((expr (math-compose-expr (nth 1 a) 185)) + (calc-language 'flat) + (var (math-compose-expr (nth 2 a) 0)) + (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) + (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) + (list 'horiz + (if (memq prec '(180 201)) "(" "") + (append (list 'vcent (if high 3 2)) + (and high (list high)) + '("---- " + "\\ " + " > " + "/ " + "---- ") + (if low + (list (list 'horiz var " = " low)) + (list var))) + (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) + " " "") + expr + (if (memq prec '(180 201)) ")" "")))) +) + +(put 'calcFunc-prod 'math-compose-big 'math-compose-prod) +(defun math-compose-prod (a prec) + (and (memq (length a) '(3 5 6)) + (let* ((expr (math-compose-expr (nth 1 a) 198)) + (calc-language 'flat) + (var (math-compose-expr (nth 2 a) 0)) + (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) + (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) + (list 'horiz + (if (memq prec '(196 201)) "(" "") + (append (list 'vcent (if high 3 2)) + (and high (list high)) + '("----- " + " | | " + " | | " + " | | ") + (if low + (list (list 'horiz var " = " low)) + (list var))) + (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) + " " "") + expr + (if (memq prec '(196 201)) ")" "")))) +) + + +(defun math-stack-value-offset-fancy () + (let ((cwid (+ (math-comp-width c)))) + (cond ((eq calc-display-just 'right) + (if calc-display-origin + (setq wid (max calc-display-origin 5)) + (if (integerp calc-line-breaking) + (setq wid calc-line-breaking))) + (setq off (- wid cwid + (max (- (length calc-right-label) + (if (and (integerp calc-line-breaking) + calc-display-origin) + (max (- calc-line-breaking + calc-display-origin) + 0) + 0)) + 0)))) + (t + (if calc-display-origin + (progn + (setq off (- calc-display-origin (/ cwid 2))) + (if (integerp calc-line-breaking) + (setq off (min off (- calc-line-breaking cwid + (length calc-right-label))))) + (if (>= off 0) + (setq wid (max wid (+ off cwid))))) + (if (integerp calc-line-breaking) + (setq wid calc-line-breaking)) + (setq off (/ (- wid cwid) 2))))) + (and (integerp calc-line-breaking) + (or (< off 0) + (and calc-display-origin + (> calc-line-breaking calc-display-origin))) + (setq wid calc-line-breaking))) +) + + + +;;; Convert a composition to string form, with embedded \n's if necessary. + +(defun math-composition-to-string (c &optional width) + (or width (setq width (calc-window-width))) + (if calc-display-raw + (math-comp-to-string-raw c 0) + (if (math-comp-is-flat c) + (math-comp-to-string-flat c width) + (math-vert-comp-to-string + (math-comp-simplify c width)))) +) + +(defun math-comp-is-flat (c) ; check if c's height is 1. + (cond ((not (consp c)) t) + ((memq (car c) '(set break)) t) + ((eq (car c) 'horiz) + (while (and (setq c (cdr c)) + (math-comp-is-flat (car c)))) + (null c)) + ((memq (car c) '(vleft vcent vright)) + (and (= (length c) 3) + (= (nth 1 c) 0) + (math-comp-is-flat (nth 2 c)))) + ((eq (car c) 'tag) + (math-comp-is-flat (nth 2 c))) + (t nil)) +) + + +;;; Convert a one-line composition to a string. Break into multiple +;;; lines if necessary, choosing break points according to the structure +;;; of the formula. + +(defun math-comp-to-string-flat (c full-width) + (if math-comp-sel-hpos + (let ((comp-pos 0)) + (math-comp-sel-flat-term c)) + (let ((comp-buf "") + (comp-word "") + (comp-pos 0) + (comp-margin 0) + (comp-highlight (and math-comp-selected calc-show-selections)) + (comp-level -1)) + (math-comp-to-string-flat-term '(set -1 0)) + (math-comp-to-string-flat-term c) + (math-comp-to-string-flat-term '(break -1)) + (let ((str (aref math-comp-buf-string 0)) + (prefix "")) + (and (> (length str) 0) (= (aref str 0) ? ) + (> (length comp-buf) 0) + (let ((k (length comp-buf))) + (while (not (= (aref comp-buf (setq k (1- k))) ?\n))) + (aset comp-buf k ? ) + (if (and (< (1+ k) (length comp-buf)) + (= (aref comp-buf (1+ k)) ? )) + (progn + (aset comp-buf (1+ k) ?\n) + (setq prefix " ")) + (setq prefix "\n")))) + (concat comp-buf prefix str)))) +) +(setq math-comp-buf-string (make-vector 10 "")) +(setq math-comp-buf-margin (make-vector 10 0)) +(setq math-comp-buf-level (make-vector 10 0)) + +(defun math-comp-to-string-flat-term (c) + (cond ((not (consp c)) + (if comp-highlight + (setq c (math-comp-highlight-string c))) + (setq comp-word (if (= (length comp-word) 0) c (concat comp-word c)) + comp-pos (+ comp-pos (length c)))) + + ((eq (car c) 'horiz) + (while (setq c (cdr c)) + (math-comp-to-string-flat-term (car c)))) + + ((eq (car c) 'set) + (if (nth 1 c) + (progn + (setq comp-level (1+ comp-level)) + (if (>= comp-level (length math-comp-buf-string)) + (setq math-comp-buf-string (vconcat math-comp-buf-string + math-comp-buf-string) + math-comp-buf-margin (vconcat math-comp-buf-margin + math-comp-buf-margin) + math-comp-buf-level (vconcat math-comp-buf-level + math-comp-buf-level))) + (aset math-comp-buf-string comp-level "") + (aset math-comp-buf-margin comp-level (+ comp-pos + (or (nth 2 c) 0))) + (aset math-comp-buf-level comp-level (nth 1 c))))) + + ((eq (car c) 'break) + (if (not calc-line-breaking) + (setq comp-buf (concat comp-buf comp-word) + comp-word "") + (let ((i 0) str) + (if (and (> comp-pos full-width) + (progn + (while (progn + (setq str (aref math-comp-buf-string i)) + (and (= (length str) 0) (< i comp-level))) + (setq i (1+ i))) + (or (> (length str) 0) (> (length comp-buf) 0)))) + (let ((prefix "") mrg wid) + (setq mrg (aref math-comp-buf-margin i)) + (if (> mrg 12) ; indenting too far, go back to far left + (let ((j i) (new (if calc-line-numbering 5 1))) + '(while (<= j comp-level) + (aset math-comp-buf-margin j + (+ (aref math-comp-buf-margin j) (- new mrg))) + (setq j (1+ j))) + (setq mrg new))) + (setq wid (+ (length str) comp-margin)) + (and (> (length str) 0) (= (aref str 0) ? ) + (> (length comp-buf) 0) + (let ((k (length comp-buf))) + (while (not (= (aref comp-buf (setq k (1- k))) ?\n))) + (aset comp-buf k ? ) + (if (and (< (1+ k) (length comp-buf)) + (= (aref comp-buf (1+ k)) ? )) + (progn + (aset comp-buf (1+ k) ?\n) + (setq prefix " ")) + (setq prefix "\n")))) + (setq comp-buf (concat comp-buf prefix str "\n" + (make-string mrg ? )) + comp-pos (+ comp-pos (- mrg wid)) + comp-margin mrg) + (aset math-comp-buf-string i "") + (while (<= (setq i (1+ i)) comp-level) + (if (> (aref math-comp-buf-margin i) wid) + (aset math-comp-buf-margin i + (+ (aref math-comp-buf-margin i) + (- mrg wid)))))))) + (if (and (= (nth 1 c) (aref math-comp-buf-level comp-level)) + (< comp-pos (+ (aref math-comp-buf-margin comp-level) 2))) + () ; avoid stupid breaks, e.g., "1 +\n really_long_expr" + (let ((str (aref math-comp-buf-string comp-level))) + (setq str (if (= (length str) 0) + comp-word + (concat str comp-word)) + comp-word "") + (while (< (nth 1 c) (aref math-comp-buf-level comp-level)) + (setq comp-level (1- comp-level)) + (or (= (length (aref math-comp-buf-string comp-level)) 0) + (setq str (concat (aref math-comp-buf-string comp-level) + str)))) + (aset math-comp-buf-string comp-level str))))) + + ((eq (car c) 'tag) + (cond ((eq (nth 1 c) math-comp-selected) + (let ((comp-highlight (not calc-show-selections))) + (math-comp-to-string-flat-term (nth 2 c)))) + ((eq (nth 1 c) t) + (let ((comp-highlight nil)) + (math-comp-to-string-flat-term (nth 2 c)))) + (t (math-comp-to-string-flat-term (nth 2 c))))) + + (t (math-comp-to-string-flat-term (nth 2 c)))) +) + +(defun math-comp-highlight-string (s) + (setq s (copy-sequence s)) + (let ((i (length s))) + (while (>= (setq i (1- i)) 0) + (or (memq (aref s i) '(32 ?\n)) + (aset s i (if calc-show-selections ?\. ?\#))))) + s +) + +(defun math-comp-sel-flat-term (c) + (cond ((not (consp c)) + (setq comp-pos (+ comp-pos (length c)))) + ((memq (car c) '(set break))) + ((eq (car c) 'horiz) + (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000)) + (math-comp-sel-flat-term (car c)))) + ((eq (car c) 'tag) + (if (<= comp-pos math-comp-sel-cpos) + (progn + (math-comp-sel-flat-term (nth 2 c)) + (if (> comp-pos math-comp-sel-cpos) + (setq math-comp-sel-tag c + math-comp-sel-cpos 1000000))) + (math-comp-sel-flat-term (nth 2 c)))) + (t (math-comp-sel-flat-term (nth 2 c)))) +) + + +;;; Simplify a composition to a canonical form consisting of +;;; (vleft n "string" "string" "string" ...) +;;; where 0 <= n < number-of-strings. + +(defun math-comp-simplify (c full-width) + (let ((comp-buf (list "")) + (comp-base 0) + (comp-height 1) + (comp-hpos 0) + (comp-vpos 0) + (comp-highlight (and math-comp-selected calc-show-selections)) + (comp-tag nil)) + (math-comp-simplify-term c) + (cons 'vleft (cons comp-base comp-buf))) +) + +(defun math-comp-add-string (s h v) + (and (> (length s) 0) + (let ((vv (+ v comp-base))) + (if math-comp-sel-hpos + (math-comp-add-string-sel h vv (length s) 1) + (if (< vv 0) + (setq comp-buf (nconc (make-list (- vv) "") comp-buf) + comp-base (- v) + comp-height (- comp-height vv) + vv 0) + (if (>= vv comp-height) + (setq comp-buf (nconc comp-buf + (make-list (1+ (- vv comp-height)) "")) + comp-height (1+ vv)))) + (let ((str (nthcdr vv comp-buf))) + (setcar str (concat (car str) + (make-string (- h (length (car str))) 32) + (if comp-highlight + (math-comp-highlight-string s) + s))))))) +) + +(defun math-comp-add-string-sel (x y w h) + (if (and (<= y math-comp-sel-vpos) + (> (+ y h) math-comp-sel-vpos) + (<= x math-comp-sel-hpos) + (> (+ x w) math-comp-sel-hpos)) + (setq math-comp-sel-tag comp-tag + math-comp-sel-vpos 10000)) +) + +(defun math-comp-simplify-term (c) + (cond ((stringp c) + (math-comp-add-string c comp-hpos comp-vpos) + (setq comp-hpos (+ comp-hpos (length c)))) + ((memq (car c) '(set break)) + nil) + ((eq (car c) 'horiz) + (while (setq c (cdr c)) + (math-comp-simplify-term (car c)))) + ((memq (car c) '(vleft vcent vright)) + (let* ((comp-vpos (+ (- comp-vpos (nth 1 c)) + (1- (math-comp-ascent (nth 2 c))))) + (widths (mapcar 'math-comp-width (cdr (cdr c)))) + (maxwid (apply 'max widths)) + (bias (cond ((eq (car c) 'vleft) 0) + ((eq (car c) 'vcent) 1) + (t 2)))) + (setq c (cdr c)) + (while (setq c (cdr c)) + (if (eq (car-safe (car c)) 'rule) + (math-comp-add-string (make-string maxwid (nth 1 (car c))) + comp-hpos comp-vpos) + (let ((comp-hpos (+ comp-hpos (/ (* bias (- maxwid + (car widths))) + 2)))) + (math-comp-simplify-term (car c)))) + (and (cdr c) + (setq comp-vpos (+ comp-vpos + (+ (math-comp-descent (car c)) + (math-comp-ascent (nth 1 c)))) + widths (cdr widths)))) + (setq comp-hpos (+ comp-hpos maxwid)))) + ((eq (car c) 'supscr) + (let* ((asc (or 1 (math-comp-ascent (nth 1 c)))) + (desc (math-comp-descent (nth 2 c))) + (oldh (prog1 + comp-hpos + (math-comp-simplify-term (nth 1 c)))) + (comp-vpos (- comp-vpos (+ asc desc)))) + (math-comp-simplify-term (nth 2 c)) + (if math-comp-sel-hpos + (math-comp-add-string-sel oldh + (- comp-vpos + -1 + (math-comp-ascent (nth 2 c))) + (- comp-hpos oldh) + (math-comp-height c))))) + ((eq (car c) 'subscr) + (let* ((asc (math-comp-ascent (nth 2 c))) + (desc (math-comp-descent (nth 1 c))) + (oldv comp-vpos) + (oldh (prog1 + comp-hpos + (math-comp-simplify-term (nth 1 c)))) + (comp-vpos (+ comp-vpos (+ asc desc)))) + (math-comp-simplify-term (nth 2 c)) + (if math-comp-sel-hpos + (math-comp-add-string-sel oldh oldv + (- comp-hpos oldh) + (math-comp-height c))))) + ((eq (car c) 'tag) + (cond ((eq (nth 1 c) math-comp-selected) + (let ((comp-highlight (not calc-show-selections))) + (math-comp-simplify-term (nth 2 c)))) + ((eq (nth 1 c) t) + (let ((comp-highlight nil)) + (math-comp-simplify-term (nth 2 c)))) + (t (let ((comp-tag c)) + (math-comp-simplify-term (nth 2 c))))))) +) + + +;;; Measuring a composition. + +(defun math-comp-first-char (c) + (cond ((stringp c) + (and (> (length c) 0) + (elt c 0))) + ((memq (car c) '(horiz subscr supscr)) + (while (and (setq c (cdr c)) + (math-comp-is-null (car c)))) + (and c (math-comp-first-char (car c)))) + ((eq (car c) 'tag) + (math-comp-first-char (nth 2 c)))) +) + +(defun math-comp-first-string (c) + (cond ((stringp c) + (and (> (length c) 0) + c)) + ((eq (car c) 'horiz) + (while (and (setq c (cdr c)) + (math-comp-is-null (car c)))) + (and c (math-comp-first-string (car c)))) + ((eq (car c) 'tag) + (math-comp-first-string (nth 2 c)))) +) + +(defun math-comp-last-char (c) + (cond ((stringp c) + (and (> (length c) 0) + (elt c (1- (length c))))) + ((eq (car c) 'horiz) + (let ((c (reverse (cdr c)))) + (while (and c (math-comp-is-null (car c))) + (setq c (cdr c))) + (and c (math-comp-last-char (car c))))) + ((eq (car c) 'tag) + (math-comp-last-char (nth 2 c)))) +) + +(defun math-comp-is-null (c) + (cond ((stringp c) (= (length c) 0)) + ((memq (car c) '(horiz subscr supscr)) + (while (and (setq c (cdr c)) + (math-comp-is-null (car c)))) + (null c)) + ((eq (car c) 'tag) + (math-comp-is-null (nth 2 c))) + ((memq (car c) '(set break)) t)) +) + +(defun math-comp-width (c) + (cond ((not (consp c)) (length c)) + ((memq (car c) '(horiz subscr supscr)) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (+ accum (math-comp-width (car c))))) + accum)) + ((memq (car c) '(vcent vleft vright)) + (setq c (cdr c)) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (max accum (math-comp-width (car c))))) + accum)) + ((eq (car c) 'tag) + (math-comp-width (nth 2 c))) + (t 0)) +) + +(defun math-comp-height (c) + (if (stringp c) + 1 + (+ (math-comp-ascent c) (math-comp-descent c))) +) + +(defun math-comp-ascent (c) + (cond ((not (consp c)) 1) + ((eq (car c) 'horiz) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (max accum (math-comp-ascent (car c))))) + accum)) + ((memq (car c) '(vcent vleft vright)) + (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1)) + ((eq (car c) 'supscr) + (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c))))) + ((eq (car c) 'subscr) + (math-comp-ascent (nth 1 c))) + ((eq (car c) 'tag) + (math-comp-ascent (nth 2 c))) + (t 1)) +) + +(defun math-comp-descent (c) + (cond ((not (consp c)) 0) + ((eq (car c) 'horiz) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (max accum (math-comp-descent (car c))))) + accum)) + ((memq (car c) '(vcent vleft vright)) + (let ((accum (- (nth 1 c)))) + (setq c (cdr c)) + (while (setq c (cdr c)) + (setq accum (+ accum (math-comp-height (car c))))) + (max (1- accum) 0))) + ((eq (car c) 'supscr) + (math-comp-descent (nth 1 c))) + ((eq (car c) 'subscr) + (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c)))) + ((eq (car c) 'tag) + (math-comp-descent (nth 2 c))) + (t 0)) +) + +(defun calcFunc-cwidth (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (math-comp-width (math-compose-expr a (or prec 0))) +) + +(defun calcFunc-cheight (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace)) + (memq (length a) '(2 3)) + (eq (nth 1 a) 0)) + 0 + (math-comp-height (math-compose-expr a (or prec 0)))) +) + +(defun calcFunc-cascent (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace)) + (memq (length a) '(2 3)) + (eq (nth 1 a) 0)) + 0 + (math-comp-ascent (math-compose-expr a (or prec 0)))) +) + +(defun calcFunc-cdescent (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (math-comp-descent (math-compose-expr a (or prec 0))) +) + + +;;; Convert a simplified composition into string form. + +(defun math-vert-comp-to-string (c) + (if (stringp c) + c + (math-vert-comp-to-string-step (cdr (cdr c)))) +) + +(defun math-vert-comp-to-string-step (c) + (if (cdr c) + (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c))) + (car c)) +) + + +;;; Convert a composition to a string in "raw" form (for debugging). + +(defun math-comp-to-string-raw (c indent) + (cond ((or (not (consp c)) (eq (car c) 'set)) + (prin1-to-string c)) + ((null (cdr c)) + (concat "(" (symbol-name (car c)) ")")) + (t + (let ((next-indent (+ indent 2 (length (symbol-name (car c)))))) + (concat "(" + (symbol-name (car c)) + " " + (math-comp-to-string-raw (nth 1 c) next-indent) + (math-comp-to-string-raw-step (cdr (cdr c)) + next-indent) + ")")))) +) + +(defun math-comp-to-string-raw-step (cl indent) + (if cl + (concat "\n" + (make-string indent 32) + (math-comp-to-string-raw (car cl) indent) + (math-comp-to-string-raw-step (cdr cl) indent)) + "") +) + + + +