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