code.delx.au - gnu-emacs/blob - lisp/calc/calccomp.el

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