Mercurial > emacs
view lisp/calc/calccomp.el @ 82383:44c9d2ed1665
*** empty log message ***
author | Michaël Cadilhac <michael.cadilhac@lrde.org> |
---|---|
date | Wed, 15 Aug 2007 02:23:42 +0000 |
parents | b98604865ea0 |
children | cf4da0940e73 f55f9811f5d7 |
line wrap: on
line source
;;; calccomp.el --- composition functions for Calc ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007 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, 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; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; This file is autoloaded from calc-ext.el. (require 'calc-ext) (require 'calc-macs) (defconst math-eqn-special-funcs '( calcFunc-log calcFunc-ln calcFunc-exp calcFunc-sin calcFunc-cos calcFunc-tan calcFunc-sec calcFunc-csc calcFunc-cot calcFunc-sinh calcFunc-cosh calcFunc-tanh calcFunc-sech calcFunc-csch calcFunc-coth calcFunc-arcsin calcFunc-arccos calcFunc-arctan calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)) ;;; 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-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) math-expr-special-function-mapping)) (setq spfn (cdr spfn)) (funcall (car spfn) a spfn)) ((math-scalarp a) (if (or (eq (car-safe a) 'frac) (and (nth 1 calc-frac-format) (Math-integerp a))) (if (memq calc-language '(tex latex eqn math maple c fortran pascal)) (let ((aa (math-adjust-fraction a)) (calc-frac-format nil)) (math-compose-expr (list '/ (if (memq calc-language '(c fortran)) (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 (eq calc-language 'tex) (math-matrixp a)) (if (and (integerp calc-language-option) (or (= calc-language-option 0) (> calc-language-option 1) (< calc-language-option -1))) (append '(vleft 0 "\\matrix{") (math-compose-tex-matrix (cdr a)) '("}")) (append '(horiz "\\matrix{ ") (math-compose-tex-matrix (cdr a)) '(" }"))) (if (and (eq calc-language 'latex) (math-matrixp a)) (if (and (integerp calc-language-option) (or (= calc-language-option 0) (> calc-language-option 1) (< calc-language-option -1))) (append '(vleft 0 "\\begin{pmatrix}") (math-compose-tex-matrix (cdr a) t) '("\\end{pmatrix}")) (append '(horiz "\\begin{pmatrix} ") (math-compose-tex-matrix (cdr a) t) '(" \\end{pmatrix}"))) (if (and (eq calc-language 'eqn) (math-matrixp a)) (append '(horiz "matrix { ") (math-compose-eqn-matrix (cdr (math-transpose a))) '("}")) (if (and (eq calc-language 'maple) (math-matrixp a)) (list 'horiz "matrix(" 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 (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 (memq calc-language '(tex latex)) " \\ldots" " ...") 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 (and (memq calc-language '(tex latex)) calc-language-option (not (= calc-language-option 0)) (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" (symbol-name (nth 1 a)))) (if (eq calc-language 'latex) (format "\\text{%s}" (symbol-name (nth 1 a))) (format "\\hbox{%s}" (symbol-name (nth 1 a)))) (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)) (if (memq calc-language '(c fortran pascal maple)) (math-to-underscores (symbol-name (nth 1 a))) (if (and (eq calc-language 'eqn) (string-match ".'\\'" (symbol-name (nth 2 a)))) (math-compose-expr (list 'calcFunc-Prime (list 'var (intern (substring (symbol-name (nth 1 a)) 0 -1)) (intern (substring (symbol-name (nth 2 a)) 0 -1)))) prec) (symbol-name (nth 1 a))))))))) ((eq (car a) 'intv) (list 'horiz (if (eq calc-language 'maple) "" (if (memq (nth 1 a) '(0 1)) "(" "[")) (math-compose-expr (nth 2 a) 0) (if (memq calc-language '(tex latex)) " \\ldots " (if (eq calc-language 'eqn) " ... " " .. ")) (math-compose-expr (nth 3 a) 0) (if (eq calc-language 'maple) "" (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) (cdr (cdr a)) (memq calc-language '(c pascal fortran maple))) (let ((args (cdr (cdr a)))) (while (and (memq calc-language '(pascal fortran)) (eq (car-safe (nth 1 a)) 'calcFunc-subscr)) (setq args (append (cdr (cdr (nth 1 a))) args) a (nth 1 a))) (list 'horiz (math-compose-expr (nth 1 a) 1000) (if (eq calc-language 'fortran) "(" "[") (math-compose-vector args ", " 0) (if (eq calc-language 'fortran) ")" "]")))) ((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) 'calcFunc-subscr) (= (length a) 3) (eq calc-language 'math)) (list 'horiz (math-compose-expr (nth 1 a) 1000) "[[" (math-compose-expr (nth 2 a) 0) "]]")) ((and (eq (car a) 'calcFunc-sqrt) (memq calc-language '(tex latex))) (list 'horiz "\\sqrt{" (math-compose-expr (nth 1 a) 0) "}")) ((and nil (eq (car a) 'calcFunc-sqrt) (eq calc-language 'eqn)) (list 'horiz "sqrt {" (math-compose-expr (nth 1 a) -1) "}")) ((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 (memq (car a) '(calcFunc-sum calcFunc-prod)) (memq calc-language '(tex latex)) (= (length a) 5)) (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod") "_{" (math-compose-expr (nth 2 a) 0) "=" (math-compose-expr (nth 3 a) 0) "}^{" (math-compose-expr (nth 4 a) 0) "}{" (math-compose-expr (nth 1 a) 0) "}")) ((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 (memq calc-language '(tex latex)) (list 'horiz "\\left( " c " \\right)") (if (eq calc-language 'eqn) (list 'horiz "{left ( " c " right )}") (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) (memq calc-language '(tex latex eqn)) (= math-compose-level (if math-comp-tagged 2 1)) (= (length a) 3)) (list 'horiz (if (memq calc-language '(tex latex)) "\\evalto " "evalto ") (math-compose-expr (nth 1 a) 0) (if (memq calc-language '(tex latex)) " \\to " " -> ") (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 ) ( 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 '(c fortran pascal maple)) (setq func (math-to-underscores func))) (if (and (memq calc-language '(tex latex)) calc-language-option (not (= calc-language-option 0)) (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) (if (< (prefix-numeric-value calc-language-option) 0) (setq func (format "\\%s" func)) (setq func (if (eq calc-language 'latex) (format "\\text{%s}" func) (format "\\hbox{%s}" func))))) (if (and (eq calc-language 'eqn) (string-match "[^']'+\\'" func)) (let ((n (- (length func) (match-beginning 0) 1))) (setq func (substring func 0 (- n))) (while (>= (setq n (1- n)) 0) (setq func (concat func " prime"))))) (cond ((and (memq calc-language '(tex latex)) (or (> (length a) 2) (not (math-tex-expr-is-flat (nth 1 a))))) (setq left "\\left( " right " \\right)")) ((and (eq calc-language 'eqn) (or (> (length a) 2) (not (math-tex-expr-is-flat (nth 1 a))))) (setq left "{left ( " right " right )}")) ((and (or (and (memq calc-language '(tex latex)) (eq (aref func 0) ?\\)) (and (eq calc-language 'eqn) (memq (car a) math-eqn-special-funcs))) (not (or (string-match "\\hbox{" func) (string-match "\\text{" func))) (= (length a) 2) (or (Math-realp (nth 1 a)) (memq (car (nth 1 a)) '(var *)))) (setq left (if (eq calc-language 'eqn) "~{" "{") right "}")) ((eq calc-language 'eqn) (setq left " ( " right " )")) (t (setq left calc-function-open right calc-function-close))) (list 'horiz func left (math-compose-vector (cdr a) (if (eq calc-language 'eqn) " , " ", ") 0) right))))))))) (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 (if (memq calc-language '(tex latex)) " \\ldots" " ...") 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-compose-tex-matrix (a &optional ltx) (if (cdr a) (cons (append (math-compose-vector (cdr (car a)) " & " 0) (if ltx '(" \\\\ ") '(" \\cr "))) (math-compose-tex-matrix (cdr a) ltx)) (list (math-compose-vector (cdr (car a)) " & " 0)))) (defun math-compose-eqn-matrix (a) (if a (cons (cond ((eq calc-matrix-just 'right) "rcol ") ((eq calc-matrix-just 'center) "ccol ") (t "lcol ")) (cons (list 'break math-compose-level) (cons "{ " (cons (let ((math-compose-level (1+ math-compose-level))) (math-compose-vector (cdr (car a)) " above " 1000)) (cons " } " (math-compose-eqn-matrix (cdr a))))))) nil)) (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-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