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

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