cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-comp.el

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