mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-25 10:47:00 +00:00
1670 lines
55 KiB
EmacsLisp
1670 lines
55 KiB
EmacsLisp
;;; calccomp.el --- composition functions for Calc
|
|
|
|
;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
|
|
;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
|
|
|
|
;; Author: David Gillespie <daveg@synaptics.com>
|
|
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
;; This file is autoloaded from calc-ext.el.
|
|
|
|
(require 'calc-ext)
|
|
(require 'calc-macs)
|
|
|
|
;;; A "composition" has one of the following forms:
|
|
;;;
|
|
;;; "string" A literal string
|
|
;;;
|
|
;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions
|
|
;;;
|
|
;;; (set LEVEL OFF) Set left margin + offset for line-break level
|
|
;;; (break LEVEL) A potential line-break point
|
|
;;;
|
|
;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps
|
|
;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps
|
|
;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps
|
|
;;; N specifies baseline of the stack, 0=top line.
|
|
;;;
|
|
;;; (supscr C1 C2) Composition C1 with superscript C2
|
|
;;; (subscr C1 C2) Composition C1 with subscript C2
|
|
;;; (rule X) Horizontal line of X, full width of enclosing comp
|
|
;;;
|
|
;;; (tag X C) Composition C corresponds to sub-expression X
|
|
|
|
;; math-comp-just and math-comp-comma-spc are local to
|
|
;; math-compose-expr, but are used by math-compose-matrix, which is
|
|
;; called by math-compose-expr
|
|
(defvar math-comp-just)
|
|
(defvar math-comp-comma-spc)
|
|
|
|
;; math-comp-vector-prec is local to math-compose-expr, but is used by
|
|
;; math-compose-matrix and math-compose-rows, which are called by
|
|
;; math-compose-expr.
|
|
(defvar math-comp-vector-prec)
|
|
|
|
;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
|
|
;; local to math-compose-expr, but are used by math-compose-rows, which is
|
|
;; called by math-compose-expr.
|
|
(defvar math-comp-left-bracket)
|
|
(defvar math-comp-right-bracket)
|
|
(defvar math-comp-comma)
|
|
|
|
(defun math-compose-var (a)
|
|
(let (v sn)
|
|
(if (and math-compose-hash-args
|
|
(let ((p calc-arg-values))
|
|
(setq v 1)
|
|
(while (and p (not (equal (car p) a)))
|
|
(setq p (and (eq math-compose-hash-args t) (cdr p))
|
|
v (1+ v)))
|
|
p))
|
|
(if (eq math-compose-hash-args 1)
|
|
"#"
|
|
(format "#%d" v))
|
|
(setq sn (symbol-name (nth 1 a)))
|
|
(if (memq calc-language calc-lang-allow-percentsigns)
|
|
(setq sn (math-to-percentsigns sn)))
|
|
(if (memq calc-language calc-lang-allow-underscores)
|
|
(setq sn (math-to-underscores sn)))
|
|
sn)))
|
|
|
|
(defun math-compose-expr (a prec)
|
|
(let ((math-compose-level (1+ math-compose-level))
|
|
(math-expr-opers (math-expr-ops))
|
|
spfn)
|
|
(cond
|
|
((or (and (eq a math-comp-selected) a)
|
|
(and math-comp-tagged
|
|
(not (eq math-comp-tagged a))))
|
|
(let ((math-comp-selected nil))
|
|
(and math-comp-tagged (setq math-comp-tagged a))
|
|
(list 'tag a (math-compose-expr a prec))))
|
|
((and (not (consp a)) (not (integerp a)))
|
|
(concat "'" (prin1-to-string a)))
|
|
((setq spfn (assq (car-safe a)
|
|
(get calc-language 'math-special-function-table)))
|
|
(setq spfn (cdr spfn))
|
|
(if (consp spfn)
|
|
(funcall (car spfn) a spfn)
|
|
(funcall spfn a)))
|
|
((math-scalarp a)
|
|
(if (or (eq (car-safe a) 'frac)
|
|
(and (nth 1 calc-frac-format) (Math-integerp a)))
|
|
(if (and
|
|
calc-language
|
|
(not (memq calc-language
|
|
'(flat big unform))))
|
|
(let ((aa (math-adjust-fraction a))
|
|
(calc-frac-format nil))
|
|
(math-compose-expr (list '/
|
|
(if (memq calc-language
|
|
calc-lang-slash-idiv)
|
|
(math-float (nth 1 aa))
|
|
(nth 1 aa))
|
|
(nth 2 aa)) prec))
|
|
(if (and (eq calc-language 'big)
|
|
(= (length (car calc-frac-format)) 1))
|
|
(let* ((aa (math-adjust-fraction a))
|
|
(calc-frac-format nil)
|
|
(math-radix-explicit-format nil)
|
|
(c (list 'horiz
|
|
(if (math-negp (nth 1 aa))
|
|
"- " "")
|
|
(list 'vcent 1
|
|
(math-format-number
|
|
(math-abs (nth 1 aa)))
|
|
'(rule ?-)
|
|
(math-format-number (nth 2 aa))))))
|
|
(if (= calc-number-radix 10)
|
|
c
|
|
(list 'horiz "(" c
|
|
(list 'subscr ")"
|
|
(int-to-string calc-number-radix)))))
|
|
(math-format-number a)))
|
|
(if (not (eq calc-language 'big))
|
|
(math-format-number a prec)
|
|
(if (memq (car-safe a) '(cplx polar))
|
|
(if (math-zerop (nth 2 a))
|
|
(math-compose-expr (nth 1 a) prec)
|
|
(list 'horiz "("
|
|
(math-compose-expr (nth 1 a) 0)
|
|
(if (eq (car a) 'cplx) ", " "; ")
|
|
(math-compose-expr (nth 2 a) 0) ")"))
|
|
(if (or (= calc-number-radix 10)
|
|
(not (Math-realp a))
|
|
(and calc-group-digits
|
|
(not (assoc calc-group-char '((",") (" "))))))
|
|
(math-format-number a prec)
|
|
(let ((s (math-format-number a prec))
|
|
(c nil))
|
|
(while (string-match (if (> calc-number-radix 14)
|
|
"\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)"
|
|
"\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)")
|
|
s)
|
|
(setq c (nconc c (list (substring s 0 (match-beginning 0))
|
|
(list 'subscr
|
|
(math-match-substring s 2)
|
|
(math-match-substring s 1))))
|
|
s (substring s (match-end 0))))
|
|
(if (string-match
|
|
"\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s)
|
|
(setq s (list 'horiz
|
|
(substring s 0 (match-beginning 0)) " "
|
|
(list 'supscr
|
|
(math-match-substring s 1)
|
|
(math-match-substring s 2))
|
|
(math-match-substring s 3))))
|
|
(if c (cons 'horiz (nconc c (list s))) s)))))))
|
|
((and (get (car a) 'math-compose-forms)
|
|
(not (eq calc-language 'unform))
|
|
(let ((comps (get (car a) 'math-compose-forms))
|
|
temp temp2)
|
|
(or (and (setq temp (assq calc-language comps))
|
|
(or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
|
|
(setq temp (apply (cdr temp2) (cdr a)))
|
|
(math-compose-expr temp prec))
|
|
(and (setq temp2 (assq nil (cdr temp)))
|
|
(funcall (cdr temp2) a))))
|
|
(and (setq temp (assq nil comps))
|
|
(or (and (setq temp2 (assq (1- (length a)) (cdr temp)))
|
|
(setq temp (apply (cdr temp2) (cdr a)))
|
|
(math-compose-expr temp prec))
|
|
(and (setq temp2 (assq nil (cdr temp)))
|
|
(funcall (cdr temp2) a))))))))
|
|
((eq (car a) 'vec)
|
|
(let* ((math-comp-left-bracket (if calc-vector-brackets
|
|
(substring calc-vector-brackets 0 1) ""))
|
|
(math-comp-right-bracket (if calc-vector-brackets
|
|
(substring calc-vector-brackets 1 2) ""))
|
|
(inner-brackets (memq 'R calc-matrix-brackets))
|
|
(outer-brackets (memq 'O calc-matrix-brackets))
|
|
(row-commas (memq 'C calc-matrix-brackets))
|
|
(math-comp-comma-spc (or calc-vector-commas " "))
|
|
(math-comp-comma (or calc-vector-commas ""))
|
|
(math-comp-vector-prec (if (or (and calc-vector-commas
|
|
(math-vector-no-parens a))
|
|
(memq 'P calc-matrix-brackets)) 0 1000))
|
|
(math-comp-just (cond ((eq calc-matrix-just 'right) 'vright)
|
|
((eq calc-matrix-just 'center) 'vcent)
|
|
(t 'vleft)))
|
|
(break calc-break-vectors))
|
|
(if (and (memq calc-language '(nil big))
|
|
(not calc-break-vectors)
|
|
(math-matrixp a) (not (math-matrixp (nth 1 a)))
|
|
(or calc-full-vectors
|
|
(and (< (length a) 7) (< (length (nth 1 a)) 7))
|
|
(progn (setq break t) nil)))
|
|
(if (progn
|
|
(setq math-comp-vector-prec (if (or (and calc-vector-commas
|
|
(math-vector-no-parens
|
|
(nth 1 a)))
|
|
(memq 'P calc-matrix-brackets))
|
|
0 1000))
|
|
(= (length a) 2))
|
|
(list 'horiz
|
|
(concat math-comp-left-bracket math-comp-left-bracket " ")
|
|
(math-compose-vector (cdr (nth 1 a)) (concat math-comp-comma " ")
|
|
math-comp-vector-prec)
|
|
(concat " " math-comp-right-bracket math-comp-right-bracket))
|
|
(let* ((rows (1- (length a)))
|
|
(cols (1- (length (nth 1 a))))
|
|
(base (/ (1- rows) 2))
|
|
(calc-language 'flat))
|
|
(append '(horiz)
|
|
(list (append '(vleft)
|
|
(list base)
|
|
(list (concat (and outer-brackets
|
|
(concat math-comp-left-bracket
|
|
" "))
|
|
(and inner-brackets
|
|
(concat math-comp-left-bracket
|
|
" "))))
|
|
(make-list (1- rows)
|
|
(concat (and outer-brackets
|
|
" ")
|
|
(and inner-brackets
|
|
(concat
|
|
math-comp-left-bracket
|
|
" "))))))
|
|
(math-compose-matrix (cdr a) 1 cols base)
|
|
(list (append '(vleft)
|
|
(list base)
|
|
(make-list (1- rows)
|
|
(if inner-brackets
|
|
(concat " "
|
|
math-comp-right-bracket
|
|
(and row-commas
|
|
math-comp-comma))
|
|
(if (and outer-brackets
|
|
row-commas)
|
|
";" "")))
|
|
(list (concat
|
|
(and inner-brackets
|
|
(concat " "
|
|
math-comp-right-bracket))
|
|
(and outer-brackets
|
|
(concat
|
|
" "
|
|
math-comp-right-bracket)))))))))
|
|
(if (and calc-display-strings
|
|
(cdr a)
|
|
(math-vector-is-string a))
|
|
(math-vector-to-string a t)
|
|
(if (and break (cdr a)
|
|
(not (eq calc-language 'flat)))
|
|
(let* ((full (or calc-full-vectors (< (length a) 7)))
|
|
(rows (if full (1- (length a)) 5))
|
|
(base (/ (1- rows) 2))
|
|
(calc-break-vectors nil))
|
|
(list 'horiz
|
|
(cons 'vleft (cons base
|
|
(math-compose-rows
|
|
(cdr a)
|
|
(if full rows 3) t)))))
|
|
(if (or calc-full-vectors (< (length a) 7))
|
|
(if (and
|
|
(setq spfn (get calc-language 'math-matrix-formatter))
|
|
(math-matrixp a))
|
|
(funcall spfn a)
|
|
(list 'horiz
|
|
math-comp-left-bracket
|
|
(math-compose-vector (cdr a)
|
|
(concat math-comp-comma " ")
|
|
math-comp-vector-prec)
|
|
math-comp-right-bracket))
|
|
(list 'horiz
|
|
math-comp-left-bracket
|
|
(math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
|
|
(concat math-comp-comma " ")
|
|
math-comp-vector-prec)
|
|
math-comp-comma
|
|
(if (setq spfn (get calc-language 'math-dots))
|
|
(concat " " spfn)
|
|
" ...")
|
|
math-comp-comma " "
|
|
(list 'break math-compose-level)
|
|
(math-compose-expr (nth (1- (length a)) a)
|
|
(if (equal math-comp-comma "") 1000 0))
|
|
math-comp-right-bracket)))))))
|
|
((eq (car a) 'incomplete)
|
|
(if (cdr (cdr a))
|
|
(cond ((eq (nth 1 a) 'vec)
|
|
(list 'horiz "["
|
|
(math-compose-vector (cdr (cdr a)) ", " 0)
|
|
" ..."))
|
|
((eq (nth 1 a) 'cplx)
|
|
(list 'horiz "("
|
|
(math-compose-vector (cdr (cdr a)) ", " 0)
|
|
", ..."))
|
|
((eq (nth 1 a) 'polar)
|
|
(list 'horiz "("
|
|
(math-compose-vector (cdr (cdr a)) "; " 0)
|
|
"; ..."))
|
|
((eq (nth 1 a) 'intv)
|
|
(list 'horiz
|
|
(if (memq (nth 2 a) '(0 1)) "(" "[")
|
|
(math-compose-vector (cdr (cdr (cdr a))) " .. " 0)
|
|
" .. ..."))
|
|
(t (format "%s" a)))
|
|
(cond ((eq (nth 1 a) 'vec) "[ ...")
|
|
((eq (nth 1 a) 'intv)
|
|
(if (memq (nth 2 a) '(0 1)) "( ..." "[ ..."))
|
|
(t "( ..."))))
|
|
((eq (car a) 'var)
|
|
(let ((v (rassq (nth 2 a) math-expr-variable-mapping)))
|
|
(if v
|
|
(symbol-name (car v))
|
|
(if (setq spfn (get calc-language 'math-var-formatter))
|
|
(funcall spfn a prec)
|
|
(math-compose-var a)))))
|
|
((eq (car a) 'intv)
|
|
(list 'horiz
|
|
(if (memq (nth 1 a) '(0 1)) "(" "[")
|
|
(math-compose-expr (nth 2 a) 0)
|
|
" .. "
|
|
(math-compose-expr (nth 3 a) 0)
|
|
(if (memq (nth 1 a) '(0 2)) ")" "]")))
|
|
((eq (car a) 'date)
|
|
(if (eq (car calc-date-format) 'X)
|
|
(math-format-date a)
|
|
(concat "<" (math-format-date a) ">")))
|
|
((and (eq (car a) 'calcFunc-subscr)
|
|
(setq spfn (get calc-language 'math-compose-subscr)))
|
|
(funcall spfn a))
|
|
((and (eq (car a) 'calcFunc-subscr) (= (length a) 3)
|
|
(eq calc-language 'big))
|
|
(let* ((a1 (math-compose-expr (nth 1 a) 1000))
|
|
(calc-language 'flat)
|
|
(a2 (math-compose-expr (nth 2 a) 0)))
|
|
(if (or (eq (car-safe a1) 'subscr)
|
|
(and (eq (car-safe a1) 'tag)
|
|
(eq (car-safe (nth 2 a1)) 'subscr)
|
|
(setq a1 (nth 2 a1))))
|
|
(list 'subscr
|
|
(nth 1 a1)
|
|
(list 'horiz
|
|
(nth 2 a1)
|
|
", "
|
|
a2))
|
|
(list 'subscr a1 a2))))
|
|
((and (eq (car a) '^)
|
|
(eq calc-language 'big))
|
|
(list 'supscr
|
|
(if (or (math-looks-negp (nth 1 a))
|
|
(memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt))
|
|
(and (eq (car-safe (nth 1 a)) 'cplx)
|
|
(math-negp (nth 1 (nth 1 a)))
|
|
(eq (nth 2 (nth 1 a)) 0)))
|
|
(list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
|
|
(math-compose-expr (nth 1 a) 201))
|
|
(let ((calc-language 'flat)
|
|
(calc-number-radix 10))
|
|
(math-compose-expr (nth 2 a) 0))))
|
|
((and (eq (car a) '/)
|
|
(eq calc-language 'big))
|
|
(let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac))
|
|
'flat 'big)))
|
|
(math-compose-expr (nth 1 a) 0)))
|
|
(a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac))
|
|
'flat 'big)))
|
|
(math-compose-expr (nth 2 a) 0))))
|
|
(list 'vcent
|
|
(math-comp-height a1)
|
|
a1 '(rule ?-) a2)))
|
|
((and (eq (car a) 'calcFunc-lambda)
|
|
(> (length a) 2)
|
|
(memq calc-language '(nil flat big)))
|
|
(let ((p (cdr a))
|
|
(ap calc-arg-values)
|
|
(math-compose-hash-args (if (= (length a) 3) 1 t)))
|
|
(while (and (cdr p) (equal (car p) (car ap)))
|
|
(setq p (cdr p) ap (cdr ap)))
|
|
(append '(horiz "<")
|
|
(if (cdr p)
|
|
(list (math-compose-vector
|
|
(nreverse (cdr (reverse (cdr a)))) ", " 0)
|
|
" : ")
|
|
nil)
|
|
(list (math-compose-expr (nth (1- (length a)) a) 0)
|
|
">"))))
|
|
((and (eq (car a) 'calcFunc-string)
|
|
(= (length a) 2)
|
|
(math-vectorp (nth 1 a))
|
|
(math-vector-is-string (nth 1 a)))
|
|
(if (eq calc-language 'unform)
|
|
(concat "string(" (math-vector-to-string (nth 1 a) t) ")")
|
|
(math-vector-to-string (nth 1 a) nil)))
|
|
((and (eq (car a) 'calcFunc-bstring)
|
|
(= (length a) 2)
|
|
(math-vectorp (nth 1 a))
|
|
(math-vector-is-string (nth 1 a)))
|
|
(if (eq calc-language 'unform)
|
|
(concat "bstring(" (math-vector-to-string (nth 1 a) t) ")")
|
|
(let ((c nil)
|
|
(s (math-vector-to-string (nth 1 a) nil))
|
|
p)
|
|
(while (string-match "[^ ] +[^ ]" s)
|
|
(setq p (1- (match-end 0))
|
|
c (cons (list 'break math-compose-level)
|
|
(cons (substring s 0 p)
|
|
c))
|
|
s (substring s p)))
|
|
(setq c (nreverse (cons s c)))
|
|
(or (= prec -123)
|
|
(setq c (cons (list 'set math-compose-level 2) c)))
|
|
(cons 'horiz c))))
|
|
((and (eq (car a) 'calcFunc-cprec)
|
|
(not (eq calc-language 'unform))
|
|
(= (length a) 3)
|
|
(integerp (nth 2 a)))
|
|
(let ((c (math-compose-expr (nth 1 a) -1)))
|
|
(if (> prec (nth 2 a))
|
|
(if (setq spfn (get calc-language 'math-big-parens))
|
|
(list 'horiz (car spfn) c (cdr spfn))
|
|
(list 'horiz "(" c ")"))
|
|
c)))
|
|
((and (eq (car a) 'calcFunc-choriz)
|
|
(not (eq calc-language 'unform))
|
|
(memq (length a) '(2 3 4))
|
|
(math-vectorp (nth 1 a))
|
|
(if (integerp (nth 2 a))
|
|
(or (null (nth 3 a))
|
|
(and (math-vectorp (nth 3 a))
|
|
(math-vector-is-string (nth 3 a))))
|
|
(or (null (nth 2 a))
|
|
(and (math-vectorp (nth 2 a))
|
|
(math-vector-is-string (nth 2 a))))))
|
|
(let* ((cprec (and (integerp (nth 2 a)) (nth 2 a)))
|
|
(sep (nth (if cprec 3 2) a))
|
|
(bprec nil))
|
|
(if sep
|
|
(math-compose-vector (cdr (nth 1 a))
|
|
(math-vector-to-string sep nil)
|
|
(or cprec prec))
|
|
(cons 'horiz (mapcar (function
|
|
(lambda (x)
|
|
(if (eq (car-safe x) 'calcFunc-bstring)
|
|
(prog1
|
|
(math-compose-expr
|
|
x (or bprec cprec prec))
|
|
(setq bprec -123))
|
|
(math-compose-expr x (or cprec prec)))))
|
|
(cdr (nth 1 a)))))))
|
|
((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert))
|
|
(not (eq calc-language 'unform))
|
|
(memq (length a) '(2 3))
|
|
(math-vectorp (nth 1 a))
|
|
(or (null (nth 2 a))
|
|
(integerp (nth 2 a))))
|
|
(let* ((base 0)
|
|
(v 0)
|
|
(prec (or (nth 2 a) prec))
|
|
(c (mapcar (function
|
|
(lambda (x)
|
|
(let ((b nil) (cc nil) a d)
|
|
(if (and (memq (car-safe x) '(calcFunc-cbase
|
|
calcFunc-ctbase
|
|
calcFunc-cbbase))
|
|
(memq (length x) '(1 2)))
|
|
(setq b (car x)
|
|
x (nth 1 x)))
|
|
(if (and (eq (car-safe x) 'calcFunc-crule)
|
|
(memq (length x) '(1 2))
|
|
(or (null (nth 1 x))
|
|
(and (math-vectorp (nth 1 x))
|
|
(= (length (nth 1 x)) 2)
|
|
(math-vector-is-string
|
|
(nth 1 x)))
|
|
(and (natnump (nth 1 x))
|
|
(<= (nth 1 x) 255))))
|
|
(setq cc (list
|
|
'rule
|
|
(if (math-vectorp (nth 1 x))
|
|
(aref (math-vector-to-string
|
|
(nth 1 x) nil) 0)
|
|
(or (nth 1 x) ?-))))
|
|
(or (and (memq (car-safe x) '(calcFunc-cvspace
|
|
calcFunc-ctspace
|
|
calcFunc-cbspace))
|
|
(memq (length x) '(2 3))
|
|
(eq (nth 1 x) 0))
|
|
(null x)
|
|
(setq cc (math-compose-expr x prec))))
|
|
(setq a (if cc (math-comp-ascent cc) 0)
|
|
d (if cc (math-comp-descent cc) 0))
|
|
(if (eq b 'calcFunc-cbase)
|
|
(setq base (+ v a -1))
|
|
(if (eq b 'calcFunc-ctbase)
|
|
(setq base v)
|
|
(if (eq b 'calcFunc-cbbase)
|
|
(setq base (+ v a d -1)))))
|
|
(setq v (+ v a d))
|
|
cc)))
|
|
(cdr (nth 1 a)))))
|
|
(setq c (delq nil c))
|
|
(if c
|
|
(cons (if (eq (car a) 'calcFunc-cvert) 'vcent
|
|
(if (eq (car a) 'calcFunc-clvert) 'vleft 'vright))
|
|
(cons base c))
|
|
" ")))
|
|
((and (memq (car a) '(calcFunc-csup calcFunc-csub))
|
|
(not (eq calc-language 'unform))
|
|
(memq (length a) '(3 4))
|
|
(or (null (nth 3 a))
|
|
(integerp (nth 3 a))))
|
|
(list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr)
|
|
(math-compose-expr (nth 1 a) (or (nth 3 a) 0))
|
|
(math-compose-expr (nth 2 a) 0)))
|
|
((and (eq (car a) 'calcFunc-cflat)
|
|
(not (eq calc-language 'unform))
|
|
(memq (length a) '(2 3))
|
|
(or (null (nth 2 a))
|
|
(integerp (nth 2 a))))
|
|
(let ((calc-language (if (memq calc-language '(nil big))
|
|
'flat calc-language)))
|
|
(math-compose-expr (nth 1 a) (or (nth 2 a) 0))))
|
|
((and (eq (car a) 'calcFunc-cspace)
|
|
(memq (length a) '(2 3))
|
|
(natnump (nth 1 a)))
|
|
(if (nth 2 a)
|
|
(cons 'horiz (make-list (nth 1 a)
|
|
(if (and (math-vectorp (nth 2 a))
|
|
(math-vector-is-string (nth 2 a)))
|
|
(math-vector-to-string (nth 2 a) nil)
|
|
(math-compose-expr (nth 2 a) 0))))
|
|
(make-string (nth 1 a) ?\ )))
|
|
((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
|
|
(memq (length a) '(2 3))
|
|
(natnump (nth 1 a)))
|
|
(if (= (nth 1 a) 0)
|
|
""
|
|
(let* ((c (if (nth 2 a)
|
|
(if (and (math-vectorp (nth 2 a))
|
|
(math-vector-is-string (nth 2 a)))
|
|
(math-vector-to-string (nth 2 a) nil)
|
|
(math-compose-expr (nth 2 a) 0))
|
|
" "))
|
|
(ca (math-comp-ascent c))
|
|
(cd (math-comp-descent c)))
|
|
(cons 'vleft
|
|
(cons (if (eq (car a) 'calcFunc-ctspace)
|
|
(1- ca)
|
|
(if (eq (car a) 'calcFunc-cbspace)
|
|
(+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca))
|
|
(/ (1- (* (nth 1 a) (+ ca cd))) 2)))
|
|
(make-list (nth 1 a) c))))))
|
|
((and (eq (car a) 'calcFunc-evalto)
|
|
(setq calc-any-evaltos t)
|
|
(setq spfn (get calc-language 'math-evalto))
|
|
(= math-compose-level (if math-comp-tagged 2 1))
|
|
(= (length a) 3))
|
|
(list 'horiz
|
|
(car spfn)
|
|
(math-compose-expr (nth 1 a) 0)
|
|
(cdr spfn)
|
|
(math-compose-expr (nth 2 a) 0)))
|
|
(t
|
|
(let ((op (and (not (eq calc-language 'unform))
|
|
(if (and (eq (car a) 'calcFunc-if) (= (length a) 4))
|
|
(assoc "?" math-expr-opers)
|
|
(math-assq2 (car a) math-expr-opers)))))
|
|
(cond ((and op
|
|
(or (= (length a) 3) (eq (car a) 'calcFunc-if))
|
|
(/= (nth 3 op) -1))
|
|
(cond
|
|
((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op))))
|
|
(if (and (memq calc-language '(tex latex))
|
|
(not (math-tex-expr-is-flat a)))
|
|
(if (eq (car-safe a) '/)
|
|
(list 'horiz "{" (math-compose-expr a -1) "}")
|
|
(list 'horiz "\\left( "
|
|
(math-compose-expr a -1)
|
|
" \\right)"))
|
|
(if (eq calc-language 'eqn)
|
|
(if (or (eq (car-safe a) '/)
|
|
(= (/ prec 100) 9))
|
|
(list 'horiz "{" (math-compose-expr a -1) "}")
|
|
(if (math-tex-expr-is-flat a)
|
|
(list 'horiz "( " (math-compose-expr a -1) " )")
|
|
(list 'horiz "{left ( "
|
|
(math-compose-expr a -1)
|
|
" right )}")))
|
|
(list 'horiz "(" (math-compose-expr a 0) ")"))))
|
|
((and (memq calc-language '(tex latex))
|
|
(memq (car a) '(/ calcFunc-choose calcFunc-evalto))
|
|
(>= prec 0))
|
|
(list 'horiz "{" (math-compose-expr a -1) "}"))
|
|
((eq (car a) 'calcFunc-if)
|
|
(list 'horiz
|
|
(math-compose-expr (nth 1 a) (nth 2 op))
|
|
" ? "
|
|
(math-compose-expr (nth 2 a) 0)
|
|
" : "
|
|
(math-compose-expr (nth 3 a) (nth 3 op))))
|
|
(t
|
|
(let* ((math-comp-tagged (and math-comp-tagged
|
|
(not (math-primp a))
|
|
math-comp-tagged))
|
|
(setlev (if (= prec (min (nth 2 op) (nth 3 op)))
|
|
(progn
|
|
(setq math-compose-level
|
|
(1- math-compose-level))
|
|
nil)
|
|
math-compose-level))
|
|
(lhs (math-compose-expr (nth 1 a) (nth 2 op)))
|
|
(rhs (math-compose-expr (nth 2 a) (nth 3 op))))
|
|
(and (equal (car op) "^")
|
|
(eq (math-comp-first-char lhs) ?-)
|
|
(setq lhs (list 'horiz "(" lhs ")")))
|
|
(and (memq calc-language '(tex latex))
|
|
(or (equal (car op) "^") (equal (car op) "_"))
|
|
(not (and (stringp rhs) (= (length rhs) 1)))
|
|
(setq rhs (list 'horiz "{" rhs "}")))
|
|
(or (and (eq (car a) '*)
|
|
(or (null calc-language)
|
|
(assoc "2x" math-expr-opers))
|
|
(let* ((prevt (math-prod-last-term (nth 1 a)))
|
|
(nextt (math-prod-first-term (nth 2 a)))
|
|
(prevc (or (math-comp-last-char lhs)
|
|
(and (memq (car-safe prevt)
|
|
'(^ calcFunc-subscr
|
|
calcFunc-sqrt
|
|
frac))
|
|
(eq calc-language 'big)
|
|
?0)))
|
|
(nextc (or (math-comp-first-char rhs)
|
|
(and (memq (car-safe nextt)
|
|
'(calcFunc-sqrt
|
|
calcFunc-sum
|
|
calcFunc-prod
|
|
calcFunc-integ))
|
|
(eq calc-language 'big)
|
|
?0))))
|
|
(and prevc nextc
|
|
(or (and (>= nextc ?a) (<= nextc ?z))
|
|
(and (>= nextc ?A) (<= nextc ?Z))
|
|
(and (>= nextc ?0) (<= nextc ?9))
|
|
(memq nextc '(?. ?_ ?#
|
|
?\( ?\[ ?\{))
|
|
(and (eq nextc ?\\)
|
|
(not (string-match
|
|
"\\`\\\\left("
|
|
(math-comp-first-string
|
|
rhs)))))
|
|
(not (and (eq (car-safe prevt) 'var)
|
|
(eq nextc ?\()))
|
|
(list 'horiz
|
|
(list 'set setlev 1)
|
|
lhs
|
|
(list 'break math-compose-level)
|
|
" "
|
|
rhs))))
|
|
(list 'horiz
|
|
(list 'set setlev 1)
|
|
lhs
|
|
(list 'break math-compose-level)
|
|
(if (or (equal (car op) "^")
|
|
(equal (car op) "_")
|
|
(equal (car op) "**")
|
|
(and (equal (car op) "*")
|
|
(math-comp-last-char lhs)
|
|
(math-comp-first-char rhs))
|
|
(and (equal (car op) "/")
|
|
(math-num-integerp (nth 1 a))
|
|
(math-integerp (nth 2 a))))
|
|
(car op)
|
|
(if (and (eq calc-language 'big)
|
|
(equal (car op) "=>"))
|
|
" => "
|
|
(concat " " (car op) " ")))
|
|
rhs))))))
|
|
((and op (= (length a) 2) (= (nth 3 op) -1))
|
|
(cond
|
|
((or (> prec (or (nth 4 op) (nth 2 op)))
|
|
(and (not (eq (assoc (car op) math-expr-opers) op))
|
|
(> prec 0))) ; don't write x% + y
|
|
(if (and (memq calc-language '(tex latex))
|
|
(not (math-tex-expr-is-flat a)))
|
|
(list 'horiz "\\left( "
|
|
(math-compose-expr a -1)
|
|
" \\right)")
|
|
(if (eq calc-language 'eqn)
|
|
(if (= (/ prec 100) 9)
|
|
(list 'horiz "{" (math-compose-expr a -1) "}")
|
|
(if (math-tex-expr-is-flat a)
|
|
(list 'horiz "{( " (math-compose-expr a -1) " )}")
|
|
(list 'horiz "{left ( "
|
|
(math-compose-expr a -1)
|
|
" right )}")))
|
|
(list 'horiz "(" (math-compose-expr a 0) ")"))))
|
|
(t
|
|
(let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
|
|
(list 'horiz
|
|
lhs
|
|
(if (or (> (length (car op)) 1)
|
|
(not (math-comp-is-flat lhs)))
|
|
(concat " " (car op))
|
|
(car op)))))))
|
|
((and op (= (length a) 2) (= (nth 2 op) -1))
|
|
(cond
|
|
((eq (nth 3 op) 0)
|
|
(let ((lr (and (memq calc-language '(tex latex))
|
|
(not (math-tex-expr-is-flat (nth 1 a))))))
|
|
(list 'horiz
|
|
(if lr "\\left" "")
|
|
(if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
|
|
(substring (car op) 1)
|
|
(car op))
|
|
(if (or lr (> (length (car op)) 2)) " " "")
|
|
(math-compose-expr (nth 1 a) -1)
|
|
(if (or lr (> (length (car op)) 2)) " " "")
|
|
(if lr "\\right" "")
|
|
(car (nth 1 (memq op math-expr-opers))))))
|
|
((> prec (or (nth 4 op) (nth 3 op)))
|
|
(if (and (memq calc-language '(tex latex))
|
|
(not (math-tex-expr-is-flat a)))
|
|
(list 'horiz "\\left( "
|
|
(math-compose-expr a -1)
|
|
" \\right)")
|
|
(if (eq calc-language 'eqn)
|
|
(if (= (/ prec 100) 9)
|
|
(list 'horiz "{" (math-compose-expr a -1) "}")
|
|
(if (math-tex-expr-is-flat a)
|
|
(list 'horiz "{( " (math-compose-expr a -1) " )}")
|
|
(list 'horiz "{left ( "
|
|
(math-compose-expr a -1)
|
|
" right )}")))
|
|
(list 'horiz "(" (math-compose-expr a 0) ")"))))
|
|
(t
|
|
(let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
|
|
(list 'horiz
|
|
(let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
|
|
(car op))
|
|
(substring (car op) 1)
|
|
(car op))))
|
|
(if (or (> (length ops) 1)
|
|
(not (math-comp-is-flat rhs)))
|
|
(concat ops " ")
|
|
ops))
|
|
rhs)))))
|
|
((and (eq calc-language 'big)
|
|
(setq op (get (car a) 'math-compose-big))
|
|
(funcall op a prec)))
|
|
((and (setq op (assq calc-language
|
|
'( ( nil . math-compose-normal )
|
|
( flat . math-compose-normal )
|
|
( big . math-compose-normal )
|
|
( c . math-compose-c )
|
|
( pascal . math-compose-pascal )
|
|
( fortran . math-compose-fortran )
|
|
( tex . math-compose-tex )
|
|
( latex . math-compose-latex )
|
|
( eqn . math-compose-eqn )
|
|
( yacas . math-compose-yacas )
|
|
( maxima . math-compose-maxima )
|
|
( giac . math-compose-giac )
|
|
( math . math-compose-math )
|
|
( maple . math-compose-maple ))))
|
|
(setq op (get (car a) (cdr op)))
|
|
(funcall op a prec)))
|
|
(t
|
|
(let* ((func (car a))
|
|
(func2 (assq func '(( mod . calcFunc-makemod )
|
|
( sdev . calcFunc-sdev )
|
|
( + . calcFunc-add )
|
|
( - . calcFunc-sub )
|
|
( * . calcFunc-mul )
|
|
( / . calcFunc-div )
|
|
( % . calcFunc-mod )
|
|
( ^ . calcFunc-pow )
|
|
( neg . calcFunc-neg )
|
|
( | . calcFunc-vconcat ))))
|
|
left right args)
|
|
(if func2
|
|
(setq func (cdr func2)))
|
|
(if (setq func2 (rassq func math-expr-function-mapping))
|
|
(setq func (car func2)))
|
|
(setq func (math-remove-dashes
|
|
(if (string-match
|
|
"\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
|
|
(symbol-name func))
|
|
(math-match-substring (symbol-name func) 1)
|
|
(symbol-name func))))
|
|
(if (memq calc-language calc-lang-allow-percentsigns)
|
|
(setq func (math-to-percentsigns func)))
|
|
(if (memq calc-language calc-lang-allow-underscores)
|
|
(setq func (math-to-underscores func)))
|
|
(if (setq spfn (get calc-language 'math-func-formatter))
|
|
(funcall spfn func a)
|
|
|
|
(list 'horiz func calc-function-open
|
|
(math-compose-vector (cdr a) ", " 0)
|
|
calc-function-close))))))))))
|
|
|
|
|
|
(defun math-prod-first-term (x)
|
|
(while (eq (car-safe x) '*)
|
|
(setq x (nth 1 x)))
|
|
x)
|
|
|
|
(defun math-prod-last-term (x)
|
|
(while (eq (car-safe x) '*)
|
|
(setq x (nth 2 x)))
|
|
x)
|
|
|
|
(defun math-compose-vector (a sep prec)
|
|
(if a
|
|
(cons 'horiz
|
|
(cons (list 'set math-compose-level)
|
|
(let ((c (list (math-compose-expr (car a) prec))))
|
|
(while (setq a (cdr a))
|
|
(setq c (cons (if (eq (car-safe (car a))
|
|
'calcFunc-bstring)
|
|
(let ((math-compose-level
|
|
(1- math-compose-level)))
|
|
(math-compose-expr (car a) -123))
|
|
(math-compose-expr (car a) prec))
|
|
(cons (list 'break math-compose-level)
|
|
(cons sep c)))))
|
|
(nreverse c))))
|
|
""))
|
|
|
|
(defun math-vector-no-parens (a)
|
|
(or (cdr (cdr a))
|
|
(not (eq (car-safe (nth 1 a)) '*))))
|
|
|
|
(defun math-compose-matrix (a col cols base)
|
|
(let ((col 0)
|
|
(res nil))
|
|
(while (<= (setq col (1+ col)) cols)
|
|
(setq res (cons (cons math-comp-just
|
|
(cons base
|
|
(mapcar (function
|
|
(lambda (r)
|
|
(list 'horiz
|
|
(math-compose-expr
|
|
(nth col r)
|
|
math-comp-vector-prec)
|
|
(if (= col cols)
|
|
""
|
|
(concat
|
|
math-comp-comma-spc " ")))))
|
|
a)))
|
|
res)))
|
|
(nreverse res)))
|
|
|
|
(defun math-compose-rows (a count first)
|
|
(if (cdr a)
|
|
(if (<= count 0)
|
|
(if (< count 0)
|
|
(math-compose-rows (cdr a) -1 nil)
|
|
(cons (concat
|
|
(let ((mdots (get calc-language 'math-dots)))
|
|
(if mdots
|
|
(concat " " mdots)
|
|
" ..."))
|
|
math-comp-comma)
|
|
(math-compose-rows (cdr a) -1 nil)))
|
|
(cons (list 'horiz
|
|
(if first (concat math-comp-left-bracket " ") " ")
|
|
(math-compose-expr (car a) math-comp-vector-prec)
|
|
math-comp-comma)
|
|
(math-compose-rows (cdr a) (1- count) nil)))
|
|
(list (list 'horiz
|
|
(if first (concat math-comp-left-bracket " ") " ")
|
|
(math-compose-expr (car a) math-comp-vector-prec)
|
|
(concat " " math-comp-right-bracket)))))
|
|
|
|
(defun math-vector-is-string (a)
|
|
(while (and (setq a (cdr a))
|
|
(or (and (natnump (car a))
|
|
(<= (car a) 255))
|
|
(and (eq (car-safe (car a)) 'cplx)
|
|
(natnump (nth 1 (car a)))
|
|
(eq (nth 2 (car a)) 0)
|
|
(<= (nth 1 (car a)) 255)))))
|
|
(null a))
|
|
|
|
(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" )
|
|
( ?\\ . "\\\\" )
|
|
( ?\a . "\\a" )
|
|
( ?\b . "\\b" )
|
|
( ?\e . "\\e" )
|
|
( ?\f . "\\f" )
|
|
( ?\n . "\\n" )
|
|
( ?\r . "\\r" )
|
|
( ?\t . "\\t" )
|
|
( ?\^? . "\\^?" )))
|
|
|
|
(defun math-vector-to-string (a &optional quoted)
|
|
(setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x)))
|
|
(cdr a))))
|
|
(if (string-match "[\000-\037\177\\\"]" a)
|
|
(let ((p 0)
|
|
(pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]"))
|
|
(codes (if quoted math-vector-to-string-chars '((?\^? . "^?"))))
|
|
(fmt (if quoted "\\^%c" "^%c"))
|
|
new)
|
|
(while (setq p (string-match pat a p))
|
|
(if (setq new (assq (aref a p) codes))
|
|
(setq a (concat (substring a 0 p)
|
|
(cdr new)
|
|
(substring a (1+ p)))
|
|
p (+ p (length (cdr new))))
|
|
(setq a (concat (substring a 0 p)
|
|
(format fmt (+ (aref a p) 64))
|
|
(substring a (1+ p)))
|
|
p (+ p 2))))))
|
|
(if quoted
|
|
(concat "\"" a "\"")
|
|
a))
|
|
|
|
|
|
(defun math-to-underscores (x)
|
|
(if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x)
|
|
(math-to-underscores
|
|
(concat (math-match-substring x 1) "_" (math-match-substring x 2)))
|
|
x))
|
|
|
|
(defun math-to-percentsigns (x)
|
|
(if (string-match "\\`\\(.*\\)o'o\\(.*\\)\\'" x)
|
|
(math-to-underscores
|
|
(concat (math-match-substring x 1) "%" (math-match-substring x 2)))
|
|
x))
|
|
|
|
(defun math-tex-expr-is-flat (a)
|
|
(or (Math-integerp a)
|
|
(memq (car a) '(float var))
|
|
(and (memq (car a) '(+ - * neg))
|
|
(progn
|
|
(while (and (setq a (cdr a))
|
|
(math-tex-expr-is-flat (car a))))
|
|
(null a)))
|
|
(and (memq (car a) '(^ calcFunc-subscr))
|
|
(math-tex-expr-is-flat (nth 1 a)))))
|
|
|
|
(put 'calcFunc-log 'math-compose-big 'math-compose-log)
|
|
(defun math-compose-log (a prec)
|
|
(and (= (length a) 3)
|
|
(list 'horiz
|
|
(list 'subscr "log"
|
|
(let ((calc-language 'flat))
|
|
(math-compose-expr (nth 2 a) 1000)))
|
|
"("
|
|
(math-compose-expr (nth 1 a) 1000)
|
|
")")))
|
|
|
|
(put 'calcFunc-log10 'math-compose-big 'math-compose-log10)
|
|
(defun math-compose-log10 (a prec)
|
|
(and (= (length a) 2)
|
|
(list 'horiz
|
|
(list 'subscr "log" "10")
|
|
"("
|
|
(math-compose-expr (nth 1 a) 1000)
|
|
")")))
|
|
|
|
(put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv)
|
|
(put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv)
|
|
(defun math-compose-deriv (a prec)
|
|
(when (= (length a) 3)
|
|
(math-compose-expr (list '/
|
|
(list 'calcFunc-choriz
|
|
(list 'vec
|
|
'(calcFunc-string (vec ?d))
|
|
(nth 1 a)))
|
|
(list 'calcFunc-choriz
|
|
(list 'vec
|
|
'(calcFunc-string (vec ?d))
|
|
(nth 2 a))))
|
|
prec)))
|
|
|
|
(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt)
|
|
(defun math-compose-sqrt (a prec)
|
|
(when (= (length a) 2)
|
|
(let* ((c (math-compose-expr (nth 1 a) 0))
|
|
(a (math-comp-ascent c))
|
|
(d (math-comp-descent c))
|
|
(h (+ a d))
|
|
(w (math-comp-width c)))
|
|
(list 'vleft
|
|
a
|
|
(concat (if (= h 1) " " " ")
|
|
(make-string (+ w 2) ?\_))
|
|
(list 'horiz
|
|
(if (= h 1)
|
|
"V"
|
|
(append (list 'vleft (1- a))
|
|
(make-list (1- h) " |")
|
|
'("\\|")))
|
|
" "
|
|
c)))))
|
|
|
|
(put 'calcFunc-choose 'math-compose-big 'math-compose-choose)
|
|
(defun math-compose-choose (a prec)
|
|
(let ((a1 (math-compose-expr (nth 1 a) 0))
|
|
(a2 (math-compose-expr (nth 2 a) 0)))
|
|
(list 'horiz
|
|
"("
|
|
(list 'vcent
|
|
(math-comp-height a1)
|
|
a1 " " a2)
|
|
")")))
|
|
|
|
(put 'calcFunc-integ 'math-compose-big 'math-compose-integ)
|
|
(defun math-compose-integ (a prec)
|
|
(and (memq (length a) '(3 5))
|
|
(eq (car-safe (nth 2 a)) 'var)
|
|
(let* ((parens (and (>= prec 196) (/= prec 1000)))
|
|
(var (math-compose-expr (nth 2 a) 0))
|
|
(over (and (eq (car-safe (nth 2 a)) 'var)
|
|
(or (and (eq (car-safe (nth 1 a)) '/)
|
|
(math-numberp (nth 1 (nth 1 a))))
|
|
(and (eq (car-safe (nth 1 a)) '^)
|
|
(math-looks-negp (nth 2 (nth 1 a)))))))
|
|
(expr (math-compose-expr (if over
|
|
(math-mul (nth 1 a)
|
|
(math-build-var-name
|
|
(format
|
|
"d%s"
|
|
(nth 1 (nth 2 a)))))
|
|
(nth 1 a)) 185))
|
|
(calc-language 'flat)
|
|
(low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
|
|
(high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))))
|
|
(list 'horiz
|
|
(if parens "(" "")
|
|
(append (list 'vcent (if high 3 2))
|
|
(and high (list (list 'horiz " " high)))
|
|
'(" /"
|
|
" | "
|
|
" | "
|
|
" | "
|
|
"/ ")
|
|
(and low (list (list 'horiz low " "))))
|
|
expr
|
|
(if over
|
|
""
|
|
(list 'horiz " d" var))
|
|
(if parens ")" "")))))
|
|
|
|
(put 'calcFunc-sum 'math-compose-big 'math-compose-sum)
|
|
(defun math-compose-sum (a prec)
|
|
(and (memq (length a) '(3 5 6))
|
|
(let* ((expr (math-compose-expr (nth 1 a) 185))
|
|
(calc-language 'flat)
|
|
(var (math-compose-expr (nth 2 a) 0))
|
|
(low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
|
|
(high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
|
|
(list 'horiz
|
|
(if (memq prec '(180 201)) "(" "")
|
|
(append (list 'vcent (if high 3 2))
|
|
(and high (list high))
|
|
'("---- "
|
|
"\\ "
|
|
" > "
|
|
"/ "
|
|
"---- ")
|
|
(if low
|
|
(list (list 'horiz var " = " low))
|
|
(list var)))
|
|
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
|
|
" " "")
|
|
expr
|
|
(if (memq prec '(180 201)) ")" "")))))
|
|
|
|
(put 'calcFunc-prod 'math-compose-big 'math-compose-prod)
|
|
(defun math-compose-prod (a prec)
|
|
(and (memq (length a) '(3 5 6))
|
|
(let* ((expr (math-compose-expr (nth 1 a) 198))
|
|
(calc-language 'flat)
|
|
(var (math-compose-expr (nth 2 a) 0))
|
|
(low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
|
|
(high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
|
|
(list 'horiz
|
|
(if (memq prec '(196 201)) "(" "")
|
|
(append (list 'vcent (if high 3 2))
|
|
(and high (list high))
|
|
'("----- "
|
|
" | | "
|
|
" | | "
|
|
" | | ")
|
|
(if low
|
|
(list (list 'horiz var " = " low))
|
|
(list var)))
|
|
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
|
|
" " "")
|
|
expr
|
|
(if (memq prec '(196 201)) ")" "")))))
|
|
|
|
;; The variables math-svo-c, math-svo-wid and math-svo-off are local
|
|
;; to math-stack-value-offset in calc.el, but are used by
|
|
;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
|
|
(defvar math-svo-c)
|
|
(defvar math-svo-wid)
|
|
(defvar math-svo-off)
|
|
|
|
(defun math-stack-value-offset-fancy ()
|
|
(let ((cwid (+ (math-comp-width math-svo-c))))
|
|
(cond ((eq calc-display-just 'right)
|
|
(if calc-display-origin
|
|
(setq math-svo-wid (max calc-display-origin 5))
|
|
(if (integerp calc-line-breaking)
|
|
(setq math-svo-wid calc-line-breaking)))
|
|
(setq math-svo-off (- math-svo-wid cwid
|
|
(max (- (length calc-right-label)
|
|
(if (and (integerp calc-line-breaking)
|
|
calc-display-origin)
|
|
(max (- calc-line-breaking
|
|
calc-display-origin)
|
|
0)
|
|
0))
|
|
0))))
|
|
(t
|
|
(if calc-display-origin
|
|
(progn
|
|
(setq math-svo-off (- calc-display-origin (/ cwid 2)))
|
|
(if (integerp calc-line-breaking)
|
|
(setq math-svo-off (min math-svo-off (- calc-line-breaking cwid
|
|
(length calc-right-label)))))
|
|
(if (>= math-svo-off 0)
|
|
(setq math-svo-wid (max math-svo-wid (+ math-svo-off cwid)))))
|
|
(if (integerp calc-line-breaking)
|
|
(setq math-svo-wid calc-line-breaking))
|
|
(setq math-svo-off (/ (- math-svo-wid cwid) 2)))))
|
|
(and (integerp calc-line-breaking)
|
|
(or (< math-svo-off 0)
|
|
(and calc-display-origin
|
|
(> calc-line-breaking calc-display-origin)))
|
|
(setq math-svo-wid calc-line-breaking))))
|
|
|
|
|
|
;;; Convert a composition to string form, with embedded \n's if necessary.
|
|
|
|
(defun math-composition-to-string (c &optional width)
|
|
(or width (setq width (calc-window-width)))
|
|
(if calc-display-raw
|
|
(math-comp-to-string-raw c 0)
|
|
(if (math-comp-is-flat c)
|
|
(math-comp-to-string-flat c width)
|
|
(math-vert-comp-to-string
|
|
(math-comp-simplify c width)))))
|
|
|
|
(defvar math-comp-buf-string (make-vector 10 ""))
|
|
(defvar math-comp-buf-margin (make-vector 10 0))
|
|
(defvar math-comp-buf-level (make-vector 10 0))
|
|
(defun math-comp-is-flat (c) ; check if c's height is 1.
|
|
(cond ((not (consp c)) t)
|
|
((memq (car c) '(set break)) t)
|
|
((eq (car c) 'horiz)
|
|
(while (and (setq c (cdr c))
|
|
(math-comp-is-flat (car c))))
|
|
(null c))
|
|
((memq (car c) '(vleft vcent vright))
|
|
(and (= (length c) 3)
|
|
(= (nth 1 c) 0)
|
|
(math-comp-is-flat (nth 2 c))))
|
|
((eq (car c) 'tag)
|
|
(math-comp-is-flat (nth 2 c)))
|
|
(t nil)))
|
|
|
|
|
|
;;; Convert a one-line composition to a string. Break into multiple
|
|
;;; lines if necessary, choosing break points according to the structure
|
|
;;; of the formula.
|
|
|
|
;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
|
|
;; math-comp-level, math-comp-margin and math-comp-buf are local to
|
|
;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
|
|
;; which is called by math-comp-to-string-flat.
|
|
;; math-comp-highlight and math-comp-buf are also local to
|
|
;; math-comp-simplify-term and math-comp-simplify respectively, but are used
|
|
;; by math-comp-add-string.
|
|
(defvar math-comp-full-width)
|
|
(defvar math-comp-highlight)
|
|
(defvar math-comp-word)
|
|
(defvar math-comp-level)
|
|
(defvar math-comp-margin)
|
|
(defvar math-comp-buf)
|
|
;; The variable math-comp-pos is local to math-comp-to-string-flat, but
|
|
;; is used by math-comp-to-string-flat-term and math-comp-sel-first-term,
|
|
;; which are called by math-comp-to-string-flat.
|
|
(defvar math-comp-pos)
|
|
|
|
(defun math-comp-to-string-flat (c math-comp-full-width)
|
|
(if math-comp-sel-hpos
|
|
(let ((math-comp-pos 0))
|
|
(math-comp-sel-flat-term c))
|
|
(let ((math-comp-buf "")
|
|
(math-comp-word "")
|
|
(math-comp-pos 0)
|
|
(math-comp-margin 0)
|
|
(math-comp-highlight (and math-comp-selected calc-show-selections))
|
|
(math-comp-level -1))
|
|
(math-comp-to-string-flat-term '(set -1 0))
|
|
(math-comp-to-string-flat-term c)
|
|
(math-comp-to-string-flat-term '(break -1))
|
|
(let ((str (aref math-comp-buf-string 0))
|
|
(prefix ""))
|
|
(and (> (length str) 0) (= (aref str 0) ? )
|
|
(> (length math-comp-buf) 0)
|
|
(let ((k (length math-comp-buf)))
|
|
(while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
|
|
(aset math-comp-buf k ? )
|
|
(if (and (< (1+ k) (length math-comp-buf))
|
|
(= (aref math-comp-buf (1+ k)) ? ))
|
|
(progn
|
|
(aset math-comp-buf (1+ k) ?\n)
|
|
(setq prefix " "))
|
|
(setq prefix "\n"))))
|
|
(concat math-comp-buf prefix str)))))
|
|
|
|
(defun math-comp-to-string-flat-term (c)
|
|
(cond ((not (consp c))
|
|
(if math-comp-highlight
|
|
(setq c (math-comp-highlight-string c)))
|
|
(setq math-comp-word (if (= (length math-comp-word) 0) c
|
|
(concat math-comp-word c))
|
|
math-comp-pos (+ math-comp-pos (length c))))
|
|
|
|
((eq (car c) 'horiz)
|
|
(while (setq c (cdr c))
|
|
(math-comp-to-string-flat-term (car c))))
|
|
|
|
((eq (car c) 'set)
|
|
(if (nth 1 c)
|
|
(progn
|
|
(setq math-comp-level (1+ math-comp-level))
|
|
(if (>= math-comp-level (length math-comp-buf-string))
|
|
(setq math-comp-buf-string (vconcat math-comp-buf-string
|
|
math-comp-buf-string)
|
|
math-comp-buf-margin (vconcat math-comp-buf-margin
|
|
math-comp-buf-margin)
|
|
math-comp-buf-level (vconcat math-comp-buf-level
|
|
math-comp-buf-level)))
|
|
(aset math-comp-buf-string math-comp-level "")
|
|
(aset math-comp-buf-margin math-comp-level (+ math-comp-pos
|
|
(or (nth 2 c) 0)))
|
|
(aset math-comp-buf-level math-comp-level (nth 1 c)))))
|
|
|
|
((eq (car c) 'break)
|
|
(if (not calc-line-breaking)
|
|
(setq math-comp-buf (concat math-comp-buf math-comp-word)
|
|
math-comp-word "")
|
|
(let ((i 0) str)
|
|
(if (and (> math-comp-pos math-comp-full-width)
|
|
(progn
|
|
(while (progn
|
|
(setq str (aref math-comp-buf-string i))
|
|
(and (= (length str) 0) (< i math-comp-level)))
|
|
(setq i (1+ i)))
|
|
(or (> (length str) 0) (> (length math-comp-buf) 0))))
|
|
(let ((prefix "") mrg wid)
|
|
(setq mrg (aref math-comp-buf-margin i))
|
|
(if (> mrg 12) ; indenting too far, go back to far left
|
|
(let ((j i) (new (if calc-line-numbering 5 1)))
|
|
'(while (<= j math-comp-level)
|
|
(aset math-comp-buf-margin j
|
|
(+ (aref math-comp-buf-margin j) (- new mrg)))
|
|
(setq j (1+ j)))
|
|
(setq mrg new)))
|
|
(setq wid (+ (length str) math-comp-margin))
|
|
(and (> (length str) 0) (= (aref str 0) ? )
|
|
(> (length math-comp-buf) 0)
|
|
(let ((k (length math-comp-buf)))
|
|
(while (not (= (aref math-comp-buf (setq k (1- k))) ?\n)))
|
|
(aset math-comp-buf k ? )
|
|
(if (and (< (1+ k) (length math-comp-buf))
|
|
(= (aref math-comp-buf (1+ k)) ? ))
|
|
(progn
|
|
(aset math-comp-buf (1+ k) ?\n)
|
|
(setq prefix " "))
|
|
(setq prefix "\n"))))
|
|
(setq math-comp-buf (concat math-comp-buf prefix str "\n"
|
|
(make-string mrg ? ))
|
|
math-comp-pos (+ math-comp-pos (- mrg wid))
|
|
math-comp-margin mrg)
|
|
(aset math-comp-buf-string i "")
|
|
(while (<= (setq i (1+ i)) math-comp-level)
|
|
(if (> (aref math-comp-buf-margin i) wid)
|
|
(aset math-comp-buf-margin i
|
|
(+ (aref math-comp-buf-margin i)
|
|
(- mrg wid))))))))
|
|
(if (and (= (nth 1 c) (aref math-comp-buf-level math-comp-level))
|
|
(< math-comp-pos (+ (aref math-comp-buf-margin math-comp-level) 2)))
|
|
() ; avoid stupid breaks, e.g., "1 +\n really_long_expr"
|
|
(let ((str (aref math-comp-buf-string math-comp-level)))
|
|
(setq str (if (= (length str) 0)
|
|
math-comp-word
|
|
(concat str math-comp-word))
|
|
math-comp-word "")
|
|
(while (< (nth 1 c) (aref math-comp-buf-level math-comp-level))
|
|
(setq math-comp-level (1- math-comp-level))
|
|
(or (= (length (aref math-comp-buf-string math-comp-level)) 0)
|
|
(setq str (concat (aref math-comp-buf-string math-comp-level)
|
|
str))))
|
|
(aset math-comp-buf-string math-comp-level str)))))
|
|
|
|
((eq (car c) 'tag)
|
|
(cond ((eq (nth 1 c) math-comp-selected)
|
|
(let ((math-comp-highlight (not calc-show-selections)))
|
|
(math-comp-to-string-flat-term (nth 2 c))))
|
|
((eq (nth 1 c) t)
|
|
(let ((math-comp-highlight nil))
|
|
(math-comp-to-string-flat-term (nth 2 c))))
|
|
(t (math-comp-to-string-flat-term (nth 2 c)))))
|
|
|
|
(t (math-comp-to-string-flat-term (nth 2 c)))))
|
|
|
|
(defun math-comp-highlight-string (s)
|
|
(setq s (copy-sequence s))
|
|
(let ((i (length s)))
|
|
(while (>= (setq i (1- i)) 0)
|
|
(or (memq (aref s i) '(32 ?\n))
|
|
(aset s i (if calc-show-selections ?\. ?\#)))))
|
|
s)
|
|
|
|
|
|
;; The variable math-comp-sel-tag is local to calc-find-selected-part
|
|
;; in calc-sel.el, but is used by math-comp-sel-flat-term and
|
|
;; math-comp-add-string-sel, which are called (indirectly) by
|
|
;; calc-find-selected-part.
|
|
(defvar math-comp-sel-tag)
|
|
|
|
(defun math-comp-sel-flat-term (c)
|
|
(cond ((not (consp c))
|
|
(setq math-comp-pos (+ math-comp-pos (length c))))
|
|
((memq (car c) '(set break)))
|
|
((eq (car c) 'horiz)
|
|
(while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000))
|
|
(math-comp-sel-flat-term (car c))))
|
|
((eq (car c) 'tag)
|
|
(if (<= math-comp-pos math-comp-sel-cpos)
|
|
(progn
|
|
(math-comp-sel-flat-term (nth 2 c))
|
|
(if (> math-comp-pos math-comp-sel-cpos)
|
|
(setq math-comp-sel-tag c
|
|
math-comp-sel-cpos 1000000)))
|
|
(math-comp-sel-flat-term (nth 2 c))))
|
|
(t (math-comp-sel-flat-term (nth 2 c)))))
|
|
|
|
|
|
;;; Simplify a composition to a canonical form consisting of
|
|
;;; (vleft n "string" "string" "string" ...)
|
|
;;; where 0 <= n < number-of-strings.
|
|
|
|
;; The variables math-comp-base, math-comp-hgt, math-comp-tag,
|
|
;; math-comp-hpos and math-comp-vpos are local to math-comp-simplify,
|
|
;; but are used by math-comp-add-string (math-comp-base, math-comp-hgt),
|
|
;; math-comp-add-string-sel (math-comp-tag) and math-comp-simplify-term
|
|
;; (math-comp-tag, math-comp-vpos, math-comp-hpos), which are called by
|
|
;; math-comp-simplify.
|
|
(defvar math-comp-base)
|
|
(defvar math-comp-hgt)
|
|
(defvar math-comp-tag)
|
|
(defvar math-comp-hpos)
|
|
(defvar math-comp-vpos)
|
|
|
|
(defun math-comp-simplify (c full-width)
|
|
(let ((math-comp-buf (list ""))
|
|
(math-comp-base 0)
|
|
(math-comp-hgt 1)
|
|
(math-comp-hpos 0)
|
|
(math-comp-vpos 0)
|
|
(math-comp-highlight (and math-comp-selected calc-show-selections))
|
|
(math-comp-tag nil))
|
|
(math-comp-simplify-term c)
|
|
(cons 'vleft (cons math-comp-base math-comp-buf))))
|
|
|
|
(defun math-comp-add-string (s h v)
|
|
(and (> (length s) 0)
|
|
(let ((vv (+ v math-comp-base)))
|
|
(if math-comp-sel-hpos
|
|
(math-comp-add-string-sel h vv (length s) 1)
|
|
(if (< vv 0)
|
|
(setq math-comp-buf (nconc (make-list (- vv) "") math-comp-buf)
|
|
math-comp-base (- v)
|
|
math-comp-hgt (- math-comp-hgt vv)
|
|
vv 0)
|
|
(if (>= vv math-comp-hgt)
|
|
(setq math-comp-buf (nconc math-comp-buf
|
|
(make-list (1+ (- vv math-comp-hgt)) ""))
|
|
math-comp-hgt (1+ vv))))
|
|
(let ((str (nthcdr vv math-comp-buf)))
|
|
(setcar str (concat (car str)
|
|
(make-string (- h (length (car str))) 32)
|
|
(if math-comp-highlight
|
|
(math-comp-highlight-string s)
|
|
s))))))))
|
|
|
|
(defun math-comp-add-string-sel (x y w h)
|
|
(if (and (<= y math-comp-sel-vpos)
|
|
(> (+ y h) math-comp-sel-vpos)
|
|
(<= x math-comp-sel-hpos)
|
|
(> (+ x w) math-comp-sel-hpos))
|
|
(setq math-comp-sel-tag math-comp-tag
|
|
math-comp-sel-vpos 10000)))
|
|
|
|
(defun math-comp-simplify-term (c)
|
|
(cond ((stringp c)
|
|
(math-comp-add-string c math-comp-hpos math-comp-vpos)
|
|
(setq math-comp-hpos (+ math-comp-hpos (length c))))
|
|
((memq (car c) '(set break))
|
|
nil)
|
|
((eq (car c) 'horiz)
|
|
(while (setq c (cdr c))
|
|
(math-comp-simplify-term (car c))))
|
|
((memq (car c) '(vleft vcent vright))
|
|
(let* ((math-comp-vpos (+ (- math-comp-vpos (nth 1 c))
|
|
(1- (math-comp-ascent (nth 2 c)))))
|
|
(widths (mapcar 'math-comp-width (cdr (cdr c))))
|
|
(maxwid (apply 'max widths))
|
|
(bias (cond ((eq (car c) 'vleft) 0)
|
|
((eq (car c) 'vcent) 1)
|
|
(t 2))))
|
|
(setq c (cdr c))
|
|
(while (setq c (cdr c))
|
|
(if (eq (car-safe (car c)) 'rule)
|
|
(math-comp-add-string (make-string maxwid (nth 1 (car c)))
|
|
math-comp-hpos math-comp-vpos)
|
|
(let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid
|
|
(car widths)))
|
|
2))))
|
|
(math-comp-simplify-term (car c))))
|
|
(and (cdr c)
|
|
(setq math-comp-vpos (+ math-comp-vpos
|
|
(+ (math-comp-descent (car c))
|
|
(math-comp-ascent (nth 1 c))))
|
|
widths (cdr widths))))
|
|
(setq math-comp-hpos (+ math-comp-hpos maxwid))))
|
|
((eq (car c) 'supscr)
|
|
(let* ((asc (or 1 (math-comp-ascent (nth 1 c))))
|
|
(desc (math-comp-descent (nth 2 c)))
|
|
(oldh (prog1
|
|
math-comp-hpos
|
|
(math-comp-simplify-term (nth 1 c))))
|
|
(math-comp-vpos (- math-comp-vpos (+ asc desc))))
|
|
(math-comp-simplify-term (nth 2 c))
|
|
(if math-comp-sel-hpos
|
|
(math-comp-add-string-sel oldh
|
|
(- math-comp-vpos
|
|
-1
|
|
(math-comp-ascent (nth 2 c)))
|
|
(- math-comp-hpos oldh)
|
|
(math-comp-height c)))))
|
|
((eq (car c) 'subscr)
|
|
(let* ((asc (math-comp-ascent (nth 2 c)))
|
|
(desc (math-comp-descent (nth 1 c)))
|
|
(oldv math-comp-vpos)
|
|
(oldh (prog1
|
|
math-comp-hpos
|
|
(math-comp-simplify-term (nth 1 c))))
|
|
(math-comp-vpos (+ math-comp-vpos (+ asc desc))))
|
|
(math-comp-simplify-term (nth 2 c))
|
|
(if math-comp-sel-hpos
|
|
(math-comp-add-string-sel oldh oldv
|
|
(- math-comp-hpos oldh)
|
|
(math-comp-height c)))))
|
|
((eq (car c) 'tag)
|
|
(cond ((eq (nth 1 c) math-comp-selected)
|
|
(let ((math-comp-highlight (not calc-show-selections)))
|
|
(math-comp-simplify-term (nth 2 c))))
|
|
((eq (nth 1 c) t)
|
|
(let ((math-comp-highlight nil))
|
|
(math-comp-simplify-term (nth 2 c))))
|
|
(t (let ((math-comp-tag c))
|
|
(math-comp-simplify-term (nth 2 c))))))))
|
|
|
|
|
|
;;; Measuring a composition.
|
|
|
|
(defun math-comp-first-char (c)
|
|
(cond ((stringp c)
|
|
(and (> (length c) 0)
|
|
(elt c 0)))
|
|
((memq (car c) '(horiz subscr supscr))
|
|
(while (and (setq c (cdr c))
|
|
(math-comp-is-null (car c))))
|
|
(and c (math-comp-first-char (car c))))
|
|
((eq (car c) 'tag)
|
|
(math-comp-first-char (nth 2 c)))))
|
|
|
|
(defun math-comp-first-string (c)
|
|
(cond ((stringp c)
|
|
(and (> (length c) 0)
|
|
c))
|
|
((eq (car c) 'horiz)
|
|
(while (and (setq c (cdr c))
|
|
(math-comp-is-null (car c))))
|
|
(and c (math-comp-first-string (car c))))
|
|
((eq (car c) 'tag)
|
|
(math-comp-first-string (nth 2 c)))))
|
|
|
|
(defun math-comp-last-char (c)
|
|
(cond ((stringp c)
|
|
(and (> (length c) 0)
|
|
(elt c (1- (length c)))))
|
|
((eq (car c) 'horiz)
|
|
(let ((c (reverse (cdr c))))
|
|
(while (and c (math-comp-is-null (car c)))
|
|
(setq c (cdr c)))
|
|
(and c (math-comp-last-char (car c)))))
|
|
((eq (car c) 'tag)
|
|
(math-comp-last-char (nth 2 c)))))
|
|
|
|
(defun math-comp-is-null (c)
|
|
(cond ((stringp c) (= (length c) 0))
|
|
((memq (car c) '(horiz subscr supscr))
|
|
(while (and (setq c (cdr c))
|
|
(math-comp-is-null (car c))))
|
|
(null c))
|
|
((eq (car c) 'tag)
|
|
(math-comp-is-null (nth 2 c)))
|
|
((memq (car c) '(set break)) t)))
|
|
|
|
(defun math-comp-width (c)
|
|
(cond ((not (consp c)) (length c))
|
|
((memq (car c) '(horiz subscr supscr))
|
|
(let ((accum 0))
|
|
(while (setq c (cdr c))
|
|
(setq accum (+ accum (math-comp-width (car c)))))
|
|
accum))
|
|
((memq (car c) '(vcent vleft vright))
|
|
(setq c (cdr c))
|
|
(let ((accum 0))
|
|
(while (setq c (cdr c))
|
|
(setq accum (max accum (math-comp-width (car c)))))
|
|
accum))
|
|
((eq (car c) 'tag)
|
|
(math-comp-width (nth 2 c)))
|
|
(t 0)))
|
|
|
|
(defun math-comp-height (c)
|
|
(if (stringp c)
|
|
1
|
|
(+ (math-comp-ascent c) (math-comp-descent c))))
|
|
|
|
(defun math-comp-ascent (c)
|
|
(cond ((not (consp c)) 1)
|
|
((eq (car c) 'horiz)
|
|
(let ((accum 0))
|
|
(while (setq c (cdr c))
|
|
(setq accum (max accum (math-comp-ascent (car c)))))
|
|
accum))
|
|
((memq (car c) '(vcent vleft vright))
|
|
(if (> (nth 1 c) 0) (1+ (nth 1 c)) 1))
|
|
((eq (car c) 'supscr)
|
|
(max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c)))))
|
|
((eq (car c) 'subscr)
|
|
(math-comp-ascent (nth 1 c)))
|
|
((eq (car c) 'tag)
|
|
(math-comp-ascent (nth 2 c)))
|
|
(t 1)))
|
|
|
|
(defun math-comp-descent (c)
|
|
(cond ((not (consp c)) 0)
|
|
((eq (car c) 'horiz)
|
|
(let ((accum 0))
|
|
(while (setq c (cdr c))
|
|
(setq accum (max accum (math-comp-descent (car c)))))
|
|
accum))
|
|
((memq (car c) '(vcent vleft vright))
|
|
(let ((accum (- (nth 1 c))))
|
|
(setq c (cdr c))
|
|
(while (setq c (cdr c))
|
|
(setq accum (+ accum (math-comp-height (car c)))))
|
|
(max (1- accum) 0)))
|
|
((eq (car c) 'supscr)
|
|
(math-comp-descent (nth 1 c)))
|
|
((eq (car c) 'subscr)
|
|
(+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c))))
|
|
((eq (car c) 'tag)
|
|
(math-comp-descent (nth 2 c)))
|
|
(t 0)))
|
|
|
|
(defun calcFunc-cwidth (a &optional prec)
|
|
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
(math-comp-width (math-compose-expr a (or prec 0))))
|
|
|
|
(defun calcFunc-cheight (a &optional prec)
|
|
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
(if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
|
|
(memq (length a) '(2 3))
|
|
(eq (nth 1 a) 0))
|
|
0
|
|
(math-comp-height (math-compose-expr a (or prec 0)))))
|
|
|
|
(defun calcFunc-cascent (a &optional prec)
|
|
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
(if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace))
|
|
(memq (length a) '(2 3))
|
|
(eq (nth 1 a) 0))
|
|
0
|
|
(math-comp-ascent (math-compose-expr a (or prec 0)))))
|
|
|
|
(defun calcFunc-cdescent (a &optional prec)
|
|
(if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump))
|
|
(math-comp-descent (math-compose-expr a (or prec 0))))
|
|
|
|
|
|
;;; Convert a simplified composition into string form.
|
|
|
|
(defun math-vert-comp-to-string (c)
|
|
(if (stringp c)
|
|
c
|
|
(math-vert-comp-to-string-step (cdr (cdr c)))))
|
|
|
|
(defun math-vert-comp-to-string-step (c)
|
|
(if (cdr c)
|
|
(concat (car c) "\n" (math-vert-comp-to-string-step (cdr c)))
|
|
(car c)))
|
|
|
|
|
|
;;; Convert a composition to a string in "raw" form (for debugging).
|
|
|
|
(defun math-comp-to-string-raw (c indent)
|
|
(cond ((or (not (consp c)) (eq (car c) 'set))
|
|
(prin1-to-string c))
|
|
((null (cdr c))
|
|
(concat "(" (symbol-name (car c)) ")"))
|
|
(t
|
|
(let ((next-indent (+ indent 2 (length (symbol-name (car c))))))
|
|
(concat "("
|
|
(symbol-name (car c))
|
|
" "
|
|
(math-comp-to-string-raw (nth 1 c) next-indent)
|
|
(math-comp-to-string-raw-step (cdr (cdr c))
|
|
next-indent)
|
|
")")))))
|
|
|
|
(defun math-comp-to-string-raw-step (cl indent)
|
|
(if cl
|
|
(concat "\n"
|
|
(make-string indent 32)
|
|
(math-comp-to-string-raw (car cl) indent)
|
|
(math-comp-to-string-raw-step (cdr cl) indent))
|
|
""))
|
|
|
|
(provide 'calccomp)
|
|
|
|
;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
|
|
;;; calccomp.el ends here
|