emacs/lisp/calc/calccomp.el

;;; calccomp.el --- composition functions for Calc

;; Copyright (C) 1990-1993, 2001-2015 Free Software Foundation, Inc.

;; Author: David Gillespie <daveg@synaptics.com>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.

(require 'calc-ext)
(require 'calc-macs)

;;; 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

;; math-comp-just and math-comp-comma-spc are local to
;; math-compose-expr, but are used by math-compose-matrix, which is
;; called by math-compose-expr
(defvar math-comp-just)
(defvar math-comp-comma-spc)

;; math-comp-vector-prec is local to math-compose-expr, but is used by
;; math-compose-matrix and math-compose-rows, which are called by
;; math-compose-expr.
(defvar math-comp-vector-prec)

;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
;; local to math-compose-expr, but are used by math-compose-rows, which is
;; called by math-compose-expr.
(defvar math-comp-left-bracket)
(defvar math-comp-right-bracket)
(defvar math-comp-comma)

(defun math-compose-var (a)
  (let (v sn)
    (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))
      (setq sn (symbol-name (nth 1 a)))
      (if (memq calc-language calc-lang-allow-percentsigns)
          (setq sn (math-to-percentsigns sn)))
      (if (memq calc-language calc-lang-allow-underscores)
          (setq sn (math-to-underscores sn)))
      sn)))

;;; Give multiplication precedence when composing to avoid
;;; writing a*(b c) instead of a b c
(defun math-compose-expr (a prec &optional div)
  (let ((calc-multiplication-has-precedence t)
        (math-compose-level (1+ math-compose-level))
        (math-expr-opers (math-expr-ops))
        spfn)
    (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)))
     ((setq spfn (assq (car-safe a)
                       (get calc-language 'math-special-function-table)))
      (setq spfn (cdr spfn))
      (if (consp spfn)
          (funcall (car spfn) a spfn)
        (funcall spfn a)))
     ((math-scalarp a)
      (if (or (eq (car-safe a) 'frac)
	      (and (nth 1 calc-frac-format) (Math-integerp a)))
	  (if (and
               calc-language
               (not (memq calc-language
                          '(flat big unform))))
	      (let ((aa (math-adjust-fraction a))
		    (calc-frac-format nil))
		(math-compose-expr (list '/
					 (if (memq calc-language
                                                   calc-lang-slash-idiv)
					     (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* ((math-comp-left-bracket (if calc-vector-brackets
			       (substring calc-vector-brackets 0 1) ""))
	     (math-comp-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))
	     (math-comp-comma-spc (or calc-vector-commas " "))
	     (math-comp-comma (or calc-vector-commas ""))
	     (math-comp-vector-prec (if (or (and calc-vector-commas
				       (math-vector-no-parens a))
				  (memq 'P calc-matrix-brackets)) 0 1000))
	     (math-comp-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 math-comp-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 math-comp-left-bracket math-comp-left-bracket " ")
		      (math-compose-vector (cdr (nth 1 a)) (concat math-comp-comma " ")
					   math-comp-vector-prec)
		      (concat " " math-comp-right-bracket math-comp-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 math-comp-left-bracket
								 " "))
						    (and inner-brackets
							 (concat math-comp-left-bracket
								 " "))))
				      (make-list (1- rows)
						 (concat (and outer-brackets
							      "  ")
							 (and inner-brackets
							      (concat
							       math-comp-left-bracket
							       " "))))))
			(math-compose-matrix (cdr a) 1 cols base)
			(list (append '(vleft)
				      (list base)
				      (make-list (1- rows)
						 (if inner-brackets
						     (concat " "
							     math-comp-right-bracket
							     (and row-commas
								  math-comp-comma))
						   (if (and outer-brackets
							    row-commas)
						       ";" "")))
				      (list (concat
					     (and inner-brackets
						  (concat " "
							  math-comp-right-bracket))
					     (and outer-brackets
						  (concat
						   " "
						   math-comp-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))
		       (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
                       (setq spfn (get calc-language 'math-matrix-formatter))
                       (math-matrixp a))
                      (funcall spfn a)
                    (list 'horiz
                          math-comp-left-bracket
                          (math-compose-vector (cdr a)
                                               (concat math-comp-comma " ")
                                               math-comp-vector-prec)
                          math-comp-right-bracket))
		(list 'horiz
		      math-comp-left-bracket
		      (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
					   (concat math-comp-comma " ")
                                           math-comp-vector-prec)
		      math-comp-comma
                      (if (setq spfn (get calc-language 'math-dots))
                          (concat " " spfn)
                        " ...")
		      math-comp-comma " "
		      (list 'break math-compose-level)
		      (math-compose-expr (nth (1- (length a)) a)
					 (if (equal math-comp-comma "") 1000 0))
		      math-comp-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 (setq spfn (get calc-language 'math-var-formatter))
              (funcall spfn a prec)
            (math-compose-var a)))))
     ((eq (car a) 'intv)
      (list 'horiz
            (if (memq (nth 1 a) '(0 1)) "(" "[")
	    (math-compose-expr (nth 2 a) 0)
            " .. "
	    (math-compose-expr (nth 3 a) 0)
            (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)
           (setq spfn (get calc-language 'math-compose-subscr)))
      (funcall spfn a))
     ((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) '^)
	   (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)
                  (calc-twos-complement-mode nil))
	      (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 (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 (setq spfn (get calc-language 'math-big-parens))
                (list 'horiz (car spfn) c (cdr spfn))
              (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)
	   (setq spfn (get calc-language 'math-evalto))
	   (= math-compose-level (if math-comp-tagged 2 1))
	   (= (length a) 3))
      (list 'horiz
            (car spfn)
	    (math-compose-expr (nth 1 a) 0)
	    (cdr spfn)
	    (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
		((or
                  (> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
                  (and div (eq (car a) '*)))
		 (if (and (memq calc-language '(tex latex))
			  (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 (memq calc-language '(tex latex))
		      (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) (eq (nth 1 op) '/))))
		   (and (equal (car op) "^")
			(eq (math-comp-first-char lhs) ?-)
			(setq lhs (list 'horiz "(" lhs ")")))
		   (and (memq calc-language '(tex latex))
			(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 ?α) (<= nextc ?ω))
				       (and (>= nextc ?Α) (<= nextc ?Ω))
				       (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 (memq calc-language '(tex latex))
			  (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 (memq calc-language '(tex latex))
				(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 (memq calc-language '(tex latex))
			  (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 )
				      ( latex . math-compose-latex )
				      ( eqn . math-compose-eqn )
                                      ( yacas . math-compose-yacas )
                                      ( maxima . math-compose-maxima )
                                      ( giac . math-compose-giac )
				      ( 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-Zα-ωΑ-Ω0-9']+\\)\\'"
				  (symbol-name func))
				 (math-match-substring (symbol-name func) 1)
			       (symbol-name func))))
		 (if (memq calc-language calc-lang-allow-percentsigns)
		     (setq func (math-to-percentsigns func)))
		 (if (memq calc-language calc-lang-allow-underscores)
		     (setq func (math-to-underscores func)))
                 (if (setq spfn (get calc-language 'math-func-formatter))
                     (funcall spfn func a)

                   (list 'horiz func calc-function-open
		       (math-compose-vector (cdr a) ", " 0)
		       calc-function-close))))))))))


(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 math-comp-just
			    (cons base
				  (mapcar (function
					   (lambda (r)
					     (list 'horiz
						   (math-compose-expr
						    (nth col r)
						    math-comp-vector-prec)
						   (if (= col cols)
						       ""
						     (concat
                                                      math-comp-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
                   (let ((mdots (get calc-language 'math-dots)))
                     (if mdots
                         (concat " " mdots)
                       "  ..."))
                   math-comp-comma)
		  (math-compose-rows (cdr a) -1 nil)))
	(cons (list 'horiz
		    (if first (concat math-comp-left-bracket " ") "  ")
		    (math-compose-expr (car a) math-comp-vector-prec)
		    math-comp-comma)
	      (math-compose-rows (cdr a) (1- count) nil)))
    (list (list 'horiz
		(if first (concat math-comp-left-bracket " ") "  ")
		(math-compose-expr (car a) math-comp-vector-prec)
		(concat " " math-comp-right-bracket)))))

(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))

(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
					 ( ?\\ . "\\\\" )
					 ( ?\a . "\\a" )
					 ( ?\b . "\\b" )
					 ( ?\e . "\\e" )
					 ( ?\f . "\\f" )
					 ( ?\n . "\\n" )
					 ( ?\r . "\\r" )
					 ( ?\t . "\\t" )
					 ( ?\^? . "\\^?" )))

(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))


(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-to-percentsigns (x)
  (if (string-match "\\`\\(.*\\)o'o\\(.*\\)\\'" 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)
  (when (= (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)
  (when (= (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)) ")" "")))))

;; The variables math-svo-c, math-svo-wid and math-svo-off are local
;; to math-stack-value-offset in calc.el, but are used by
;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
(defvar math-svo-c)
(defvar math-svo-wid)
(defvar math-svo-off)

(defun math-stack-value-offset-fancy ()
  (let ((cwid (+ (math-comp-width math-svo-c))))
    (cond ((eq calc-display-just 'right)
	   (if calc-display-origin
	       (setq math-svo-wid (max calc-display-origin 5))
	     (if (integerp calc-line-breaking)
		 (setq math-svo-wid calc-line-breaking)))
	   (setq math-svo-off (- math-svo-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 math-svo-off (- calc-display-origin (/ cwid 2)))
		 (if (integerp calc-line-breaking)
		     (setq math-svo-off (min math-svo-off (- calc-line-breaking cwid
					   (length calc-right-label)))))
		 (if (>= math-svo-off 0)
		     (setq math-svo-wid (max math-svo-wid (+ math-svo-off cwid)))))
	     (if (integerp calc-line-breaking)
		 (setq math-svo-wid calc-line-breaking))
	     (setq math-svo-off (/ (- math-svo-wid cwid) 2)))))
    (and (integerp calc-line-breaking)
	 (or (< math-svo-off 0)
	     (and calc-display-origin
		  (> calc-line-breaking calc-display-origin)))
	 (setq math-svo-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)))))

(defvar math-comp-buf-string (make-vector 10 ""))
(defvar math-comp-buf-margin (make-vector 10 0))
(defvar math-comp-buf-level (make-vector 10 0))
(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.

;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
;; math-comp-level, math-comp-margin and math-comp-buf are local to
;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
;; which is called by math-comp-to-string-flat.
;; math-comp-highlight and math-comp-buf are also local to
;; math-comp-simplify-term and math-comp-simplify respectively, but are used
;; by math-comp-add-string.
(defvar math-comp-full-width)
(defvar math-comp-highlight)
(defvar math-comp-word)
(defvar math-comp-level)
(defvar math-comp-margin)
(defvar math-comp-buf)
;; The variable math-comp-pos is local to math-comp-to-string-flat, but
;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
;; which are called by math-comp-to-string-flat.
(defvar math-comp-pos)

(defun math-comp-to-string-flat (c math-comp-full-width)
  (if math-comp-sel-hpos
      (let ((math-comp-pos 0))
	(math-comp-sel-flat-term c))
    (let ((math-comp-buf "")
	  (math-comp-word "")
	  (math-comp-pos 0)
	  (math-comp-margin 0)
	  (math-comp-highlight (and math-comp-selected calc-show-selections))
	  (math-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 math-comp-buf) 0)
	     (let ((k (length math-comp-buf)))
	       (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
	       (aset math-comp-buf k ? )
	       (if (and (< (1+ k) (length math-comp-buf))
			(= (aref math-comp-buf (1+ k)) ? ))
		   (progn
		     (aset math-comp-buf (1+ k) ?\n)
		     (setq prefix " "))
		 (setq prefix "\n"))))
	(concat math-comp-buf prefix str)))))

(defun math-comp-to-string-flat-term (c)
  (cond ((not (consp c))
	 (if math-comp-highlight
	     (setq c (math-comp-highlight-string c)))
	 (setq math-comp-word (if (= (length math-comp-word) 0) c
                                (concat math-comp-word c))
	       math-comp-pos (+ math-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 math-comp-level (1+ math-comp-level))
	       (if (>= math-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 math-comp-level "")
	       (aset math-comp-buf-margin math-comp-level (+ math-comp-pos
							(or (nth 2 c) 0)))
	       (aset math-comp-buf-level math-comp-level (nth 1 c)))))

	((eq (car c) 'break)
	 (if (not calc-line-breaking)
	     (setq math-comp-buf (concat math-comp-buf math-comp-word)
		   math-comp-word "")
	   (let ((i 0) str)
	     (if (and (> math-comp-pos math-comp-full-width)
		      (progn
			(while (progn
				 (setq str (aref math-comp-buf-string i))
				 (and (= (length str) 0) (< i math-comp-level)))
			  (setq i (1+ i)))
			(or (> (length str) 0) (> (length math-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
		       (setq mrg (if calc-line-numbering 5 1)))
		   (setq wid (+ (length str) math-comp-margin))
		   (and (> (length str) 0) (= (aref str 0) ? )
			(> (length math-comp-buf) 0)
			(let ((k (length math-comp-buf)))
			  (while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
			  (aset math-comp-buf k ? )
			  (if (and (< (1+ k) (length math-comp-buf))
				   (= (aref math-comp-buf (1+ k)) ? ))
			      (progn
				(aset math-comp-buf (1+ k) ?\n)
				(setq prefix " "))
			    (setq prefix "\n"))))
		   (setq math-comp-buf (concat math-comp-buf prefix str "\n"
					  (make-string mrg ? ))
			 math-comp-pos (+ math-comp-pos (- mrg wid))
			 math-comp-margin mrg)
		   (aset math-comp-buf-string i "")
		   (while (<= (setq i (1+ i)) math-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 math-comp-level))
		    (< math-comp-pos (+ (aref math-comp-buf-margin math-comp-level) 2)))
	       ()  ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
	     (let ((str (aref math-comp-buf-string math-comp-level)))
	       (setq str (if (= (length str) 0)
			     math-comp-word
			   (concat str math-comp-word))
		     math-comp-word "")
	       (while (< (nth 1 c) (aref math-comp-buf-level math-comp-level))
		 (setq math-comp-level (1- math-comp-level))
		 (or (= (length (aref math-comp-buf-string math-comp-level)) 0)
		     (setq str (concat (aref math-comp-buf-string math-comp-level)
				       str))))
	       (aset math-comp-buf-string math-comp-level str)))))

	((eq (car c) 'tag)
	 (cond ((eq (nth 1 c) math-comp-selected)
		(let ((math-comp-highlight (not calc-show-selections)))
		  (math-comp-to-string-flat-term (nth 2 c))))
	       ((eq (nth 1 c) t)
		(let ((math-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))
  (if calc-highlight-selections-with-faces
      (if (not calc-show-selections)
          (propertize s 'face 'calc-selected-face)
        (propertize s 'face 'calc-nonselected-face))
    (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))

;; The variable math-comp-sel-tag is local to calc-find-selected-part
;; in calc-sel.el, but is used by math-comp-sel-flat-term and
;; math-comp-add-string-sel, which are called (indirectly) by
;; calc-find-selected-part.
(defvar math-comp-sel-tag)

(defun math-comp-sel-flat-term (c)
  (cond ((not (consp c))
	 (setq math-comp-pos (+ math-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 (<= math-comp-pos math-comp-sel-cpos)
	     (progn
	       (math-comp-sel-flat-term (nth 2 c))
	       (if (> math-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.

;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
;; math-comp-simplify.
(defvar math-comp-base)
(defvar math-comp-hgt)
(defvar math-comp-tag)
(defvar math-comp-hpos)
(defvar math-comp-vpos)

(defun math-comp-simplify (c full-width)
  (let ((math-comp-buf (list ""))
	(math-comp-base 0)
	(math-comp-hgt 1)
	(math-comp-hpos 0)
	(math-comp-vpos 0)
	(math-comp-highlight (and math-comp-selected calc-show-selections))
	(math-comp-tag nil))
    (math-comp-simplify-term c)
    (cons 'vleft (cons math-comp-base math-comp-buf))))

(defun math-comp-add-string (s h v)
  (and (> (length s) 0)
       (let ((vv (+ v math-comp-base)))
	 (if math-comp-sel-hpos
	     (math-comp-add-string-sel h vv (length s) 1)
	   (if (< vv 0)
	       (setq math-comp-buf (nconc (make-list (- vv) "") math-comp-buf)
		     math-comp-base (- v)
		     math-comp-hgt (- math-comp-hgt vv)
		     vv 0)
	     (if (>= vv math-comp-hgt)
		 (setq math-comp-buf (nconc math-comp-buf
				       (make-list (1+ (- vv math-comp-hgt)) ""))
		       math-comp-hgt (1+ vv))))
	   (let ((str (nthcdr vv math-comp-buf)))
	     (setcar str (concat (car str)
				 (make-string (- h (length (car str))) 32)
				 (if math-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 math-comp-tag
	    math-comp-sel-vpos 10000)))

(defun math-comp-simplify-term (c)
  (cond ((stringp c)
	 (math-comp-add-string c math-comp-hpos math-comp-vpos)
	 (setq math-comp-hpos (+ math-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* ((math-comp-vpos (+ (- math-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)))
				       math-comp-hpos math-comp-vpos)
	       (let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid
							   (car widths)))
						2))))
		 (math-comp-simplify-term (car c))))
	     (and (cdr c)
		  (setq math-comp-vpos (+ math-comp-vpos
				     (+ (math-comp-descent (car c))
					(math-comp-ascent (nth 1 c))))
			widths (cdr widths))))
	   (setq math-comp-hpos (+ math-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
			  math-comp-hpos
			(math-comp-simplify-term (nth 1 c))))
		(math-comp-vpos (- math-comp-vpos (+ asc desc))))
	   (math-comp-simplify-term (nth 2 c))
	   (if math-comp-sel-hpos
	       (math-comp-add-string-sel oldh
					 (- math-comp-vpos
					    -1
					    (math-comp-ascent (nth 2 c)))
					 (- math-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 math-comp-vpos)
		(oldh (prog1
			  math-comp-hpos
			(math-comp-simplify-term (nth 1 c))))
		(math-comp-vpos (+ math-comp-vpos (+ asc desc))))
	   (math-comp-simplify-term (nth 2 c))
	   (if math-comp-sel-hpos
	       (math-comp-add-string-sel oldh oldv
					 (- math-comp-hpos oldh)
					 (math-comp-height c)))))
	((eq (car c) 'tag)
	 (cond ((eq (nth 1 c) math-comp-selected)
		(let ((math-comp-highlight (not calc-show-selections)))
		  (math-comp-simplify-term (nth 2 c))))
	       ((eq (nth 1 c) t)
		(let ((math-comp-highlight nil))
		  (math-comp-simplify-term (nth 2 c))))
	       (t (let ((math-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))
    ""))

(provide 'calccomp)

;;; calccomp.el ends here