--- Raymond Toy wrote:
> This is a good start. The only comment I have is that the package
> names are too "generic". Considering the package conflict between
> maxima's nregex and slime's nregex, perhaps we should prefix all the
> package names with "MAXIMA-". It seems package names of
> the form "MAXIMA.FOO" are also common.
Agreed. I've updated to the "maxima-" style. The wiki isn't doing too
well at the moment, so I'll upload the current state of affairs once it
settles down. I've successfully gotten mactex into its own package (in
the sense that I got tex(a) to work anyway) but I need to reshuffle the
order of things so I don't get so many STYLE warnings about things
being undefined which are defined later. I've added those files to the
bottom of this email so I've got some kind of backup.
Cheers,
CY
Files:
;; This set of commands makes EVERY symbol in MAXIMA
;; external, and then defines a maxima-user package
;; which imports all of them. Basically, we just
;; cloned MAXIMA. By itself, this isn't very exciting,
;; but it sets the stage for things to come.
(do-symbols (s (find-package "MAXIMA")) (export s "MAXIMA"))
(defpackage :maxima-user
(:use :maxima))
;; Now we get slightly more interesting:
(defpackage :maxima-declarations
(:use :maxima))
(defpackage :maxima-destructuring-let
(:use :maxima))
(defpackage :maxima-compatibility-macros1
(:use :maxima))
(defpackage :maxima-compatibility-macros
(:use :maxima))
(defpackage :maxima-prerequisites
(:use :maxima))
;; This one is apparently already defined
;;(defpackage :maxima-command-line
;; (:use :maxima))
(defpackage :maxima-fundamental-macros
(:use :maxima))
(defpackage :maxima-utility-macros
(:use :maxima))
(defpackage :maxima-other-macros
(:use :maxima))
(defpackage :maxima-rat-macros
(:use :maxima))
(defpackage :maxima-numerical-macros
(:use :maxima))
(defpackage :maxima-commands
(:use :maxima))
(defpackage :maxima-evaluator
(:use :maxima))
(defpackage :maxima-numerical
(:use :maxima))
(defpackage :maxima-simplification
(:use :maxima))
(defpackage :maxima-server
(:use :maxima))
(defpackage :maxima-i-o
(:use :maxima))
(defpackage :maxima-factoring
(:use :maxima))
(defpackage :maxima-rational-functions
(:use :maxima))
(defpackage :maxima-language-compiler-macros
(:use :maxima))
(defpackage :maxima-language-compiler
(:use :maxima))
(defpackage :maxima-numerical-functions
(:use :maxima))
(defpackage :maxima-reader
(:use :maxima))
(defpackage :maxima-display
(:use :maxima))
(defpackage :maxima-gcd
(:use :maxima))
(defpackage :maxima-documentation
(:use :maxima))
(defpackage :maxima-algebraic-database
(:use :maxima))
(defpackage :maxima-integration
(:use :maxima))
(defpackage :maxima-definite-integration
(:use :maxima))
(defpackage :maxima-taylor-series
(:use :maxima))
(defpackage :maxima-trigonometry
(:use :maxima))
(defpackage :maxima-special-functions
(:use :maxima))
(defpackage :maxima-matrix-algebra
(:use :maxima))
(defpackage :maxima-determinants
(:use :maxima))
(defpackage :maxima-pattern-matching
(:use :maxima))
(defpackage :maxima-limits
(:use :maxima))
(defpackage :maxima-solve
(:use :maxima))
(defpackage :maxima-debugging
(:use :maxima))
(defpackage :maxima-miscellaneous
(:use :maxima))
(defpackage :maxima-poisson-series
(:use :maxima))
(defpackage :maxima-sets
(:use :maxima))
(defpackage :maxima-fortran
(:use :maxima))
(defpackage :maxima-ordinary-differential-equations
(:use :maxima))
(defpackage :maxima-laplace
(:use :maxima))
(defpackage :maxima-TeX
(:use :maxima :common-lisp)
(:shadow common-lisp:tan common-lisp:tanh common-lisp:continue
common-lisp:gcd common-lisp:signum common-lisp:complement
common-lisp:cosh common-lisp:array common-lisp:asinh
common-lisp:sinh common-lisp:functionp common-lisp:acosh
common-lisp:float common-lisp:atan common-lisp:exp
common-lisp:acos common-lisp:makunbound common-lisp://
common-lisp:atanh common-lisp:asin common-lisp:listen
common-lisp:break))
(defpackage :maxima-plotting
(:use :maxima))
(defpackage :maxima-initialization
(:use :maxima))
(use-package :maxima-declarations :maxima-user)
(use-package :maxima-destructuring-let :maxima-user)
(use-package :maxima-compatibility-macros1 :maxima-user)
(use-package :maxima-compatibility-macros :maxima-user)
(use-package :maxima-prerequisites :maxima-user)
;;(use-package :maxima-command-line :maxima-user)
(use-package :maxima-fundamental-macros :maxima-user)
(use-package :maxima-utility-macros :maxima-user)
(use-package :maxima-other-macros :maxima-user)
(use-package :maxima-rat-macros :maxima-user)
(use-package :maxima-numerical-macros :maxima-user)
(use-package :maxima-commands :maxima-user)
(use-package :maxima-evaluator :maxima-user)
(use-package :maxima-numerical :maxima-user)
(use-package :maxima-simplification :maxima-user)
(use-package :maxima-server :maxima-user)
(use-package :maxima-i-o :maxima-user)
(use-package :maxima-factoring :maxima-user)
(use-package :maxima-rational-functions :maxima-user)
(use-package :maxima-language-compiler-macros :maxima-user)
(use-package :maxima-language-compiler :maxima-user)
(use-package :maxima-numerical-functions :maxima-user)
(use-package :maxima-reader :maxima-user)
(use-package :maxima-display :maxima-user)
(use-package :maxima-gcd :maxima-user)
(use-package :maxima-documentation :maxima-user)
(use-package :maxima-algebraic-database :maxima-user)
(use-package :maxima-integration :maxima-user)
(use-package :maxima-definite-integration :maxima-user)
(use-package :maxima-taylor-series :maxima-user)
(use-package :maxima-trigonometry :maxima-user)
(use-package :maxima-special-functions :maxima-user)
(use-package :maxima-matrix-algebra :maxima-user)
(use-package :maxima-determinants :maxima-user)
(use-package :maxima-pattern-matching :maxima-user)
(use-package :maxima-limits :maxima-user)
(use-package :maxima-solve :maxima-user)
(use-package :maxima-debugging :maxima-user)
(use-package :maxima-miscellaneous :maxima-user)
(use-package :maxima-poisson-series :maxima-user)
(use-package :maxima-sets :maxima-user)
(use-package :maxima-fortran :maxima-user)
(use-package :maxima-ordinary-differential-equations :maxima-user)
(use-package :maxima-laplace :maxima-user)
(use-package :maxima-TeX :maxima-user)
(use-package :maxima-plotting :maxima-user)
(use-package :maxima-initialization :maxima-user)
;; OK, so what just happened? We defined a whole lot of
;; empty packages, and had them all import the MAXIMA package,
;; in effect creating a large number of gateways to the MAXIMA
;; environment. The reason for this is to allow us to begin
;; to separate out logical groupings of Maxima commands without
;; riping Maxima apart functionally speaking. Now we can create
;; files for each of these packages, and move selected definitions
;; to them rather than having them in MAXIMA.
;; Now, we'll load the package files that have been created.
;; Currently, that's just the TeX package.
(load "./src/TeX-package.lisp")
(in-package :maxima-TeX)
(declare-top
(special lop rop ccol $gcprint texport $labels $inchar
vaxima-main-dir
)
(*expr tex-lbp tex-rbp))
(export '($tex $texend $texinit $texput))
#+franz
($bothcases t) ;; allow alpha and Alpha to be different
#+franz
(export $bothcases)
;;*************************************
;; Internal functions and definitions
;;*************************************
(defun quote-% (sym)
(let* ((strsym (string sym))
(pos (position-if #'(lambda (c) (find c "%_")) strsym)))
(if pos
(concatenate 'string (subseq strsym 0 pos) "\\" (subseq strsym
pos (1+ pos))
(quote-% (subseq strsym (1+ pos))))
strsym)))
;;; myprinc is an intelligent low level printing routine. it keeps
track of
;;; the size of the output for purposes of allowing the TeX file to
;;; have a reasonable line-line. myprinc will break it at a space
;;; once it crosses a threshold.
;;; this has nothign to do with breaking the resulting equations.
;;- arg: chstr - string or number to princ
;;- scheme: This function keeps track of the current location
;;- on the line of the cursor and makes sure
;;- that a value is all printed on one line (and not
divided
;;- by the crazy top level os routines)
(defun myprinc (chstr)
(prog (chlst)
(cond ((greaterp (plus (length (setq chlst (exploden chstr)))
ccol)
70.)
(terpri texport) ;would have exceeded the line length
(setq ccol 1.)
(myprinc " ") ; lead off with a space for safety
)) ;so we split it up.
(do ((ch chlst (cdr ch))
(colc ccol (add1 colc)))
((null ch) (setq ccol colc))
(tyo (car ch) texport))))
(defun myterpri nil
(cond (texport (terpri texport))
(t (mterpri)))
(setq ccol 1))
(defun tex (x l r lop rop)
;; x is the expression of interest; l is the list of strings to its
;; left, r to its right. lop and rop are the operators on the left
;; and right of x in the tree, and will determine if parens must
;; be inserted
(setq x (nformat x))
(cond ((atom x) (tex-atom x l r))
((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (> (tex-lbp rop) (tex-rbp
(caar x))))
(tex-paren x l r))
;; special check needed because macsyma notates arrays peculiarly
((memq 'array (cdar x)) (tex-array x l r))
;; dispatch for object-oriented tex-ifiying
((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r))
(t (tex-function x l r nil))))
(defun tex1 (mexplabel &optional filename ) ;; mexplabel, and optional
filename
(prog (mexp texport $gcprint ccol x y itsalabel)
;; $gcprint = nil turns gc messages off
(setq ccol 1)
(cond ((null mexplabel)
(displa " No eqn given to TeX")
(return nil)))
;; collect the file-name, if any, and open a port if needed
(setq texport (cond((null filename) *standard-output* ) ; t=
output to terminal
(t
(open (string (print-invert-case (stripdollar filename)))
:direction :output
:if-exists :append
:if-does-not-exist :create))))
;; go back and analyze the first arg more thoroughly now.
;; do a normal evaluation of the expression in macsyma
(setq mexp (meval mexplabel))
(cond ((memq mexplabel $labels) ; leave it if it is a label
(setq mexplabel (concatenate 'string "(" (print-invert-case
(stripdollar mexplabel))
")"))
(setq itsalabel t))
(t (setq mexplabel nil))) ;flush it otherwise
;; maybe it is a function?
(cond((symbolp (setq x mexp)) ;;exclude strings, numbers
(setq x ($verbify x))
(cond ((setq y (mget x 'mexpr))
(setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
((setq y (mget x 'mmacro))
(setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr
y))))
((setq y (mget x 'aexpr))
(setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr
y)))))))
(cond ((and (null(atom mexp))
(memq (caar mexp) '(mdefine mdefmacro)))
(if mexplabel (setq mexplabel (quote-% mexplabel)))
(format texport "|~%" ) ;delimit with |marks
(cond (mexplabel (format texport "~a " mexplabel)))
(mgrind mexp texport) ;write expression as string
(format texport ";|~%"))
((and
itsalabel ;; but is it a user-command-label?
(<= (length (string $inchar)) (length (string mexplabel)))
(eq (getchars $inchar 2 (1+ (length (string $inchar))))
(getchars mexplabel 2 (1+ (length (string $inchar)))))
;; Check to make sure it isn't an outchar in disguise
(not
(and
(<= (length (string $outchar)) (length (string mexplabel)))
(eq (getchars $outchar 2 (1+ (length (string $outchar))))
(getchars mexplabel 2 (1+ (length (string $outchar))))))))
;; aha, this is a C-line: do the grinding:
(format texport "~%|~a " mexplabel) ;delimit with |marks
(mgrind mexp texport) ;write expression as string
(format texport ";|~%"))
(t
(if mexplabel (setq mexplabel (quote-% mexplabel)))
; display the expression for TeX now:
(myprinc "$$")
(mapc #'myprinc
;;initially the left and right contexts are
;; empty lists, and there are implicit parens
;; around the whole expression
(tex mexp nil nil 'mparen 'mparen))
(cond (mexplabel
(format texport "\\leqno{\\tt ~a}" mexplabel)))
(format texport "$$")))
(terpri texport)
(cond (filename ; and close port if not terminal
(close texport)))
(return mexplabel)))
(defun tex-atom (x l r) ;; atoms: note: can we lose by leaving out {}s
?
(append l
(list (cond ((numberp x) (texnumformat x))
((and (symbolp x) (get x 'texword)))
((stringp x) (tex-string x))
((characterp x) (tex-char x))
(t (tex-stripdollar x))))
r))
(defun tex-string (x)
(cond ((equal x "") "")
((eql (elt x 0) #\\) x)
(t (concatenate 'string "\\mbox{{}" x "{}}"))))
(defun tex-char (x)
(if (eql x #\|) "\\mbox{\\verb/|/}"
(concatenate 'string "\\mbox{\\verb|" (string x) "|}")))
(defvar *tex-translations* nil)
;; '(("ab" . "a")("x" . "x")) would cause AB12 and X3 C4 to print
a_{12} and x_3 C_4
;; Read forms from file F1 and output them to F2
(defun tex-forms (f1 f2 &aux tem (eof *mread-eof-obj*))
(with-open-file (st f1)
(loop while (not (eq (setq tem (mread-raw st eof)) eof))
do (tex1 (third tem) f2))))
(defun tex-stripdollar(sym &aux )
(or (symbolp sym) (return-from tex-stripdollar sym))
(let* ((pname (quote-% sym))
(l (length pname))
(begin-sub
(loop for i downfrom (1- l)
when (not (digit-char-p (aref pname i)))
do (return (1+ i))))
(tem (make-array (+ l 4) :element-type ' #.(array-element-type
"abc") :fill-pointer 0)))
(loop for i below l
do
(cond ((eql i begin-sub)
(let ((a (assoc tem *tex-translations* :test 'equal)))
(cond (a
(setq a (cdr a))
(setf (fill-pointer tem) 0)
(loop for i below (length a)
do
(vector-push (aref a i) tem)))))
(vector-push #\_ tem)
(unless (eql i (- l 1))
(vector-push #\{ tem)
(setq begin-sub t))))
(cond ((not (and (eql i 0) (eql (aref pname i) #\$)))
(vector-push (aref pname i) tem)))
finally
(cond ((eql begin-sub t)
(vector-push #\} tem))))
(intern tem)))
(defun strcat (&rest args)
(apply #'concatenate 'string (mapcar #'string args)))
;; 10/14/87 RJF convert 1.2e20 to 1.2 \cdot 10^{20}
;; 03/30/01 RLT make that 1.2 \times 10^{20}
(defun texnumformat(atom)
(let (r firstpart exponent)
(cond ((integerp atom)
atom)
(t
(setq r (explode atom))
(setq exponent (member 'e r :test #'string-equal)) ;; is it
ddd.ddde+EE
(cond ((null exponent)
;; it is not. go with it as given
atom)
(t
(setq firstpart
(nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
(strcat (apply #'strcat firstpart )
" \\times 10^{"
(apply #'strcat (cdr exponent))
"}")))))))
(defun tex-paren (x l r)
(tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen))
(defun tex-array (x l r)
(let ((f))
(if (eq 'mqapply (caar x))
(setq f (cadr x)
x (cdr x)
l (tex f (append l (list "\\left(")) (list "\\right)") 'mparen
'mparen))
(setq f (caar x)
l (tex (texword f) l nil lop 'mfunction)))
(setq
r (nconc (tex-list (cdr x) nil (list "}") ",") r))
(nconc l (list "_{") r )))
;; we could patch this so sin x rather than sin(x), but instead we made
sin a prefix
;; operator
(defun tex-function (x l r op) op
(setq l (tex (texword (caar x)) l nil 'mparen 'mparen)
r (tex (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
(nconc l r))
;; set up a list , separated by symbols (, * ...) and then tack on the
;; ending item (e.g. "]" or perhaps ")"
(defun tex-list (x l r sym)
(if (null x) r
(do ((nl))
((null (cdr x))
(setq nl (nconc nl (tex (car x) l r 'mparen 'mparen)))
nl)
(setq nl (nconc nl (tex (car x) l (list sym) 'mparen 'mparen))
x (cdr x)
l nil))))
(defun tex-prefix (x l r)
(tex (cadr x) (append l (texsym (caar x))) r (caar x) rop))
(defun tex-infix (x l r)
;; check for 2 args
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
(setq l (tex (cadr x) l nil lop (caar x)))
(tex (caddr x) (append l (texsym (caar x))) r (caar x) rop))
(defun tex-postfix (x l r)
(tex (cadr x) l (append (texsym (caar x)) r) lop (caar x)))
(defun tex-nary (x l r)
(let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop)
(ext-rop rop))
(cond ((null y) (tex-function x l r t)) ; this should not
happen
((null (cdr y)) (tex-function x l r t)) ; this should not
happen, too
(t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y))
ext-rop op)))
((null (cdr y)) (setq nl (nconc nl (tex (car y) l r
lop rop))) nl)
(setq nl (nconc nl (tex (car y) l (list sym) lop rop))
y (cdr y)
l nil))))))
(defun tex-nofix (x l r) (tex (caar x) l r (caar x) rop))
(defun tex-matchfix (x l r)
(setq l (append l (car (texsym (caar x))))
;; car of texsym of a matchfix operator is the lead op
r (append (cdr (texsym (caar x))) r)
;; cdr is the trailing op
x (tex-list (cdr x) nil r ","))
(append l x))
(defun texsym (x)
(or (get x 'texsym) (get x 'strsym)
(get x 'dissym)
(stripdollar x)))
(defun texword (x)
(or (get x 'texword)
(stripdollar x)))
(defprop bigfloat tex-bigfloat tex)
(defun tex-bigfloat (x l r) (fpformat x))
(defprop mprog "\\mathbf{block}\\;" texword)
(defprop %erf "\\mathrm{erf}" texword)
(defprop $erf "\\mathrm{erf}" texword) ;; etc for multicharacter names
(defprop $true "\\mathbf{true}" texword)
(defprop $false "\\mathbf{false}" texword)
(defprop mprogn tex-matchfix tex) ;; mprogn is (, ...)
(defprop mprogn (("\\left(") "\\right)") texsym)
(defprop mlist tex-matchfix tex)
(defprop mlist (("\\left[ ")" \\right] ") texsym)
;;absolute value
(defprop mabs tex-matchfix tex)
(defprop mabs (("\\left| ")"\\right| ") texsym)
(defprop mqapply tex-mqapply tex)
(defun tex-mqapply (x l r)
(setq l (tex (cadr x) l (list "(" ) lop 'mfunction)
r (tex-list (cddr x) nil (cons ")" r) ","))
(append l r)) ;; fixed 9/24/87 RJF
(defprop $%i "i" texword)
(defprop $%pi "\\pi" texword)
(defprop $%e "e" texword)
(defprop $inf "\\infty " texword)
(defprop $minf " -\\infty " texword)
(defprop %laplace "\\mathcal{L}" texword)
(defprop $alpha "\\alpha" texword)
(defprop $beta "\\beta" texword)
(defprop $gamma "\\gamma" texword)
(defprop %gamma "\\Gamma" texword)
(defprop $%gamma "\\gamma" texword)
(defprop $delta "\\delta" texword)
(defprop $epsilon "\\varepsilon" texword)
(defprop $zeta "\\zeta" texword)
(defprop $eta "\\eta" texword)
(defprop $theta "\\vartheta" texword)
(defprop $iota "\\iota" texword)
(defprop $kappa "\\varkappa" texword)
;;(defprop $lambda "\\lambda" texword)
(defprop $mu "\\mu" texword)
(defprop $nu "\\nu" texword)
(defprop $xi "\\xi" texword)
(defprop $pi "\\pi" texword)
(defprop $rho "\\rho" texword)
(defprop $sigma "\\sigma" texword)
(defprop $tau "\\tau" texword)
(defprop $upsilon "\\upsilon" texword)
(defprop $phi "\\varphi" texword)
(defprop $chi "\\chi" texword)
(defprop $psi "\\psi" texword)
(defprop $omega "\\omega" texword)
(defprop |$Gamma| "\\Gamma" texword)
(defprop |$Delta| "\\Delta" texword)
(defprop |$Theta| "\\Theta" texword)
(defprop |$Lambda| "\\Lambda" texword)
(defprop |$Xi| "\\Xi" texword)
(defprop |$Pi| "\\Pi" texword)
(defprop |$Sigma| "\\Sigma" texword)
(defprop |$Upsilon| "\\Upsilon" texword)
(defprop |$Phi| "\\Phi" texword)
(defprop |$Psi| "\\Psi" texword)
(defprop |$Omega| "\\Omega" texword)
(defprop mquote tex-prefix tex)
(defprop mquote ("'") texsym)
(defprop mquote 201. tex-rbp)
(defprop msetq tex-infix tex)
(defprop msetq (":") texsym)
(defprop msetq 180. tex-rbp)
(defprop msetq 20. tex-rbp)
(defprop mset tex-infix tex)
(defprop mset ("::") texsym)
(defprop mset 180. tex-lbp)
(defprop mset 20. tex-rbp)
(defprop mdefine tex-infix tex)
(defprop mdefine (":=") texsym)
(defprop mdefine 180. tex-lbp)
(defprop mdefine 20. tex-rbp)
(defprop mdefmacro tex-infix tex)
(defprop mdefmacro ("::=") texsym)
(defprop mdefmacro 180. tex-lbp)
(defprop mdefmacro 20. tex-rbp)
(defprop marrow tex-infix tex)
(defprop marrow ("\\rightarrow ") texsym)
(defprop marrow 25 tex-lbp)
(defprop marrow 25 tex-rbp)
(defprop mfactorial tex-postfix tex)
(defprop mfactorial ("!") texsym)
(defprop mfactorial 160. tex-lbp)
(defprop mexpt tex-mexpt tex)
(defprop mexpt 140. tex-lbp)
(defprop mexpt 139. tex-rbp)
(defprop %sum 110. tex-rbp) ;; added by BLW, 1 Oct 2001
(defprop %product 115. tex-rbp) ;; added by BLW, 1 Oct 2001
;; If the number contains a exponent marker when printed, we need to
;; put parens around it.
(defun numneedsparen (number)
(unless (integerp number)
(let ((r (exploden number)))
(member 'e r :test #'string-equal))))
;; insert left-angle-brackets for mncexpt. a^ is how a^^n looks.
(defun tex-mexpt (x l r)
(let((nc (eq (caar x) 'mncexpt))) ; true if a^^b rather than a^b
;; here is where we have to check for f(x)^b to be displayed
;; as f^b(x), as is the case for sin(x)^2 .
;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
;; yet we must not display (a+b)^2 as +^2(a,b)...
;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
(cond ;; this whole clause
;; should be deleted if this hack is unwanted and/or the
;; time it takes is of concern.
;; it shouldn't be too expensive.
((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt
(let*
((fx (cadr x)) ; this is f(x)
(f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or
nil]
(bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
(expon (caddr x)) ;; this is the exponent
(doit (and
f ; there is such a function
(memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
(not (eq (car (last (car fx))) 'array)) ; fix for x[i]^2
; Jesper Harder
(not (memq f '(%sum %product %derivative %integrate %at
%lsum %limit))) ;; what else? what a hack...
(or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
(and (atom expon) (numberp expon) (> expon 0))))))
; f(x)^3 is ok, but not f(x)^-1, which could
; inverse of f, if written f^-1 x
; what else? f(x)^(1/2) is sqrt(f(x)), ??
(cond (doit
(setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
(if (and (null (cdr bascdr))
(eq (get f 'tex) 'tex-prefix))
(setq r (tex (car bascdr) nil r f 'mparen))
(setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
(t nil))))) ; won't doit. fall through
(t (setq l (cond ((and (numberp (cadr x))
(numneedsparen (cadr x)))
(tex (cadr x) (cons "\\left(" l) '("\\right)") lop
(caar x)))
(t (tex (cadr x) l nil lop (caar x))))
r (if (mmminusp (setq x (nformat (caddr x))))
;; the change in base-line makes parens unnecessary
(if nc
(tex (cadr x) '("^ {-\\langle ")(cons "\\rangle }" r) 'mparen
'mparen)
(tex (cadr x) '("^ {- ")(cons " }" r) 'mparen 'mparen))
(if nc
(tex x (list "^{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
(if (and (integerp x) (< x 10))
(tex x (list "^")(cons "" r) 'mparen 'mparen)
(tex x (list "^{")(cons "}" r) 'mparen 'mparen))
)))))
(append l r)))
(defprop mncexpt tex-mexpt tex)
(defprop mncexpt 135. tex-lbp)
(defprop mncexpt 134. tex-rbp)
(defprop mnctimes tex-nary tex)
(defprop mnctimes "\\cdot " texsym)
(defprop mnctimes 110. tex-lbp)
(defprop mnctimes 109. tex-rbp)
(defprop mtimes tex-nary tex)
(defprop mtimes "\\," texsym)
(defprop mtimes 120. tex-lbp)
(defprop mtimes 120. tex-rbp)
(defprop %sqrt tex-sqrt tex)
(defun tex-sqrt(x l r)
;; format as \\sqrt { } assuming implicit parens for sqr grouping
(tex (cadr x) (append l '("\\sqrt{")) (append '("}") r) 'mparen
'mparen))
;; macsyma doesn't know about cube (or nth) roots,
;; but if it did, this is what it would look like.
(defprop $cubrt tex-cubrt tex)
(defun tex-cubrt (x l r)
(tex (cadr x) (append l '("\\root 3 \\of{")) (append '("}") r)
'mparen 'mparen))
(defprop mquotient tex-mquotient tex)
(defprop mquotient ("\\over") texsym)
(defprop mquotient 122. tex-lbp) ;;dunno about this
(defprop mquotient 123. tex-rbp)
(defun tex-mquotient (x l r)
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
(setq l (tex (cadr x) (append l '("{{")) nil 'mparen 'mparen)
;the divide bar groups things
r (tex (caddr x) (list "}\\over{") (append '("}}")r) 'mparen 'mparen))
(append l r))
(defprop $matrix tex-matrix tex)
(defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b)
...)
(append l `("\\pmatrix{")
(mapcan #'(lambda(y)
(tex-list (cdr y) nil (list "\\cr ") "&"))
(cdr x))
'("}") r))
;; macsyma sum or prod is over integer range, not low <= index <= high
;; TeX is lots more flexible .. but
(defprop %sum tex-sum tex)
(defprop %lsum tex-lsum tex)
(defprop %product tex-sum tex)
;; easily extended to union, intersect, otherops
(defun tex-lsum(x l r)
(let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
;; extend here
))
;; gotta be one of those above
(s1 (tex (cadr x) nil nil 'mparen rop)) ;; summand
(index ;; "index = lowerlimit"
(tex `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen
'mparen)))
(append l `( ,op ,@index "}}{" ,@s1 "}") r)))
(defun tex-sum(x l r)
(let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
((eq (caar x) '%product) "\\prod_{")
;; extend here
))
;; gotta be one of those above
(s1 (tex (cadr x) nil nil 'mparen rop)) ;; summand
(index ;; "index = lowerlimit"
(tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
(toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
(append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
(defprop %integrate tex-int tex)
(defun tex-int (x l r)
(let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integrand delims
/ & d
(var (tex (caddr x) nil nil 'mparen rop))) ;; variable
(cond((= (length x) 3)
(append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
(t ;; presumably length 5
(let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
;; 1st item is 0
(hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
(append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}")
r))))))
(defprop %limit tex-limit tex)
(defun tex-limit(x l r) ;; ignoring direction, last optional arg to
limit
(let ((s1 (tex (cadr x) nil nil 'mparen rop)) ;; limitfunction
(subfun ;; the thing underneath "limit"
(subst "\\rightarrow " '=
(tex `((mequal simp) ,(caddr x),(cadddr x))
nil nil 'mparen 'mparen))))
(append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
(defprop %at tex-at tex)
;; e.g. at(diff(f(x)),x=a)
(defun tex-at (x l r)
(let ((s1 (tex (cadr x) nil nil lop rop))
(sub (tex (caddr x) nil nil 'mparen 'mparen)))
(append l '("\\left.") s1 '("\\right|_{") sub '("}") r)))
(defprop mbox tex-mbox tex)
;; \boxed is defined in amsmath.sty,
;; \newcommand{\boxed}[1]{\fbox{\m@th$\displaystyle#1$}}
(defun tex-mbox (x l r)
(append l '("\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}")
r))
(defprop mlabox tex-mlabox tex)
(defun tex-mlabox (x l r)
(append l '("\\stackrel{") (tex (caddr x) nil nil 'mparen 'mparen)
'("}{\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}}") r))
;;binomial coefficients
(defprop %binomial tex-choose tex)
(defun tex-choose (x l r)
`(,@l
"\\pmatrix{"
,@(tex (cadr x) nil nil 'mparen 'mparen)
"\\\\"
,@(tex (caddr x) nil nil 'mparen 'mparen)
"}"
,@r))
(defprop rat tex-rat tex)
(defprop rat 120. tex-lbp)
(defprop rat 121. tex-rbp)
(defun tex-rat(x l r) (tex-mquotient x l r))
(defprop mplus tex-mplus tex)
(defprop mplus 100. tex-lbp)
(defprop mplus 100. tex-rbp)
(defun tex-mplus (x l r)
;(declare (fixnum w))
(cond ((memq 'trunc (car x))(setq r (cons "+\\cdots " r))))
(cond ((null (cddr x))
(if (null (cdr x))
(tex-function x l r t)
(tex (cadr x) (cons "+" l) r 'mplus rop)))
(t (setq l (tex (cadr x) l nil lop 'mplus)
x (cddr x))
(do ((nl l) (dissym))
((null (cdr x))
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
(setq l (car x) dissym (list "+")))
(setq r (tex l dissym r 'mplus rop))
(append nl r))
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
(setq l (car x) dissym (list "+")))
(setq nl (append nl (tex l dissym nil 'mplus 'mplus))
x (cdr x))))))
(defprop mminus tex-prefix tex)
(defprop mminus ("-") texsym)
(defprop mminus 100. tex-rbp)
(defprop mminus 100. tex-lbp)
(defprop min tex-infix tex)
(defprop min ("\\in{") texsym)
(defprop min 80. tex-lbp)
(defprop min 80. tex-rbp)
(defprop mequal tex-infix tex)
(defprop mequal (=) texsym)
(defprop mequal 80. tex-lbp)
(defprop mequal 80. tex-rbp)
(defprop mnotequal tex-infix tex)
(defprop mnotequal 80. tex-lbp)
(defprop mnotequal 80. tex-rbp)
(defprop mgreaterp tex-infix tex)
(defprop mgreaterp (>) texsym)
(defprop mgreaterp 80. tex-lbp)
(defprop mgreaterp 80. tex-rbp)
(defprop mgeqp tex-infix tex)
(defprop mgeqp ("\\geq ") texsym)
(defprop mgeqp 80. tex-lbp)
(defprop mgeqp 80. tex-rbp)
(defprop mlessp tex-infix tex)
(defprop mlessp (<) texsym)
(defprop mlessp 80. tex-lbp)
(defprop mlessp 80. tex-rbp)
(defprop mleqp tex-infix tex)
(defprop mleqp ("\\leq ") texsym)
(defprop mleqp 80. tex-lbp)
(defprop mleqp 80. tex-rbp)
(defprop mnot tex-prefix tex)
(defprop mnot ("\\not ") texsym)
(defprop mnot 70. tex-rbp)
(defprop mand tex-nary tex)
(defprop mand ("\\and") texsym)
(defprop mand 60. tex-lbp)
(defprop mand 60. tex-rbp)
(defprop mor tex-nary tex)
(defprop mor ("\\or") texsym)
;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
;; etc
(defun tex-setup (x)
(let((a (car x))
(b (cadr x)))
(setf (get a 'tex) 'tex-prefix)
(setf (get a 'texword) b) ;This means "sin" will always be roman
(setf (get a 'texsym) (list b))
(setf (get a 'tex-rbp) 130)))
;; JM 09/01 expand and re-order to follow table of "log-like"
functions,
;; see table in Lamport, 2nd edition, 1994, p. 44, table 3.9.
;; I don't know if these are Latex-specific so you may have to define
;; them if you use plain Tex.
(mapc #'tex-setup
'(
(%acos "\\arccos ")
(%asin "\\arcsin ")
(%atan "\\arctan ")
; Latex's arg(x) is ... ?
(%cos "\\cos ")
(%cosh "\\cosh ")
(%cot "\\cot ")
(%coth "\\coth ")
(%csc "\\csc ")
; Latex's "deg" is ... ?
(%determinant "\\det ")
(%dim "\\dim ")
(%exp "\\exp ")
(%gcd "\\gcd ")
; Latex's "hom" is ... ?
(%inf "\\inf ") ; many will prefer "\\infty". Hmmm.
; Latex's "ker" is ... ?
; Latex's "lg" is ... ?
; lim is handled by tex-limit.
; Latex's "liminf" ... ?
; Latex's "limsup" ... ?
(%ln "\\ln ")
(%log "\\log ")
(%max "\\max ")
(%min "\\min ")
; Latex's "Pr" ... ?
(%sec "\\sec ")
(%sin "\\sin ")
(%sinh "\\sinh ")
; Latex's "sup" ... ?
(%tan "\\tan ")
(%tanh "\\tanh ")
;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
;(%laplace "{\\cal L}")
)) ;; etc
(defprop mor tex-nary tex)
(defprop mor 50. tex-lbp)
(defprop mor 50. tex-rbp)
(defprop mcond tex-mcond tex)
(defprop mcond 25. tex-lbp)
(defprop mcond 25. tex-rbp)
(defprop %derivative tex-derivative tex)
(defun tex-derivative (x l r)
(tex (if $derivabbrev
(tex-dabbrev x)
(tex-d x '$d)) l r lop rop ))
(defun tex-d(x dsym) ;dsym should be $d or "$\\partial"
;; format the macsyma derivative form so it looks
;; sort of like a quotient times the deriva-dand.
(let*
((arg (cadr x)) ;; the function being differentiated
(difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
(ords (odds difflist 0)) ;; e.g. (1 2)
(vars (odds difflist 1)) ;; e.g. (x y)
(numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
(denom (cons '(mtimes)
(mapcan #'(lambda(b e)
`(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
vars ords))))
`((mtimes)
((mquotient) ,(simplifya numer nil) ,denom)
,arg)))
(defun tex-dabbrev (x)
;; Format diff(f,x,1,y,1) so that it looks like
;; f
;; x y
(let*
((arg (cadr x)) ;; the function being differentiated
(difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
(ords (odds difflist 0)) ;; e.g. (1 2)
(vars (odds difflist 1))) ;; e.g. (x y)
(append
(if (symbolp arg)
`((,arg array))
`((mqapply array) ,arg))
(if (and (= (length vars) 1)
(= (car ords) 1))
vars
`(((mtimes) ,@(mapcan #'(lambda (var ord)
(make-list ord :initial-element var))
vars ords)))))))
(defun odds(n c)
;; if c=1, get the odd terms (first, third...)
(cond ((null n) nil)
((= c 1)(cons (car n)(odds (cdr n) 0)))
((= c 0)(odds (cdr n) 1))))
(defun tex-mcond (x l r)
(append l
(tex (cadr x) '("\\mathbf{if}\\;")
'("\\;\\mathbf{then}\\;") 'mparen 'mparen)
(if (eql (fifth x) '$false)
(tex (caddr x) nil r 'mcond rop)
(append (tex (caddr x) nil nil 'mparen 'mparen)
(tex (fifth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))))
(defprop mdo tex-mdo tex)
(defprop mdo 30. tex-lbp)
(defprop mdo 30. tex-rbp)
(defprop mdoin tex-mdoin tex)
(defprop mdoin 30. tex-rbp)
(defun tex-lbp(x)(cond((get x 'tex-lbp))(t(lbp x))))
(defun tex-rbp(x)(cond((get x 'tex-rbp))(t(lbp x))))
;; these aren't quite right
(defun tex-mdo (x l r)
(tex-list (texmdo x) l r "\\;"))
(defun tex-mdoin (x l r)
(tex-list (texmdoin x) l r "\\;"))
(defun texmdo (x)
(nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
(cond ((equal 1 (third x)) nil)
((third x) `("\\mathbf{from}" ,(third x))))
(cond ((equal 1 (fourth x)) nil)
((fourth x) `("\\mathbf{step}" ,(fourth x)))
((fifth x) `("\\mathbf{next}" ,(fifth x))))
(cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
(cond ((null (seventh x)) nil)
((eq 'mnot (caar (seventh x)))
`("\\mathbf{while}" ,(cadr (seventh x))))
(t `("\\mathbf{unless}" ,(seventh x))))
`("\\mathbf{do}" ,(eighth x))))
(defun texmdoin (x)
(nconc `("\\mathbf{for}" ,(second x) "\\mathbf{in}" ,(third x))
(cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
(cond ((null (seventh x)) nil)
((eq 'mnot (caar (seventh x)))
`("\\mathbf{while}" ,(cadr (seventh x))))
(t `("\\mathbf{unless}" ,(seventh x))))
`("\\mathbf{do}" ,(eighth x))))
(defprop mtext tex-mtext tex)
(defprop text-string tex-mtext tex)
(defprop mlable tex-mlable tex)
(defprop spaceout tex-spaceout tex)
;; Additions by Marek Rychlik (rychlik@u.arizona.edu)
;; This stuff handles setting of LET rules
(defprop | --> | "\\longrightarrow " texsym)
(defprop | WHERE | "\\;\\mathbf{where}\\;" texsym)
(defprop &>= ("\\ge ") texsym)
(defprop &>= tex-infix tex)
(defprop &> (">") texsym)
(defprop &> tex-infix tex)
(defprop &<= ("\\le ") texsym)
(defprop &<= tex-infix tex)
(defprop &< ("<") texsym)
(defprop &< tex-infix tex)
(defprop &= ("=") texsym)
(defprop &= tex-infix tex)
(defprop |&#| ("\\ne ") texsym)
(defprop |&#| tex-infix tex)
;; end of additions by Marek Rychlik
(defun tex-try-sym (x)
(if (symbolp x)
(let ((tx (get x 'texsym))) (if tx tx x))
x))
(defun tex-mtext (x l r)
(tex-list (map 'list #'tex-try-sym (cdr x)) l r ""))
(defun tex-mlable (x l r)
(tex (caddr x)
(append l
(if (cadr x)
(list (format nil "\\mbox{\\tt\\red(~A) \\black}" (tex-stripdollar
(cadr x))))
nil))
r 'mparen 'mparen))
(defun tex-spaceout (x l r)
(append l (cons (format nil "\\hspace{~dmm}" (* 3 (cadr x))) r)))
;; Undone and trickier:
;; handle reserved symbols stuff, just in case someone
;; has a macsyma variable named (yuck!!) \over or has a name with
;; {} in it.
;; Maybe do some special hacking for standard notations for
;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
;;Undone and really pretty hard: line breaking
;;*************************************
;; External functions and definitions
;;*************************************
(defmspec $tex(l) ;; mexplabel, and optional filename
;; top level command the result of tex'ing the expression x.
;; Lots of messing around here to get C-labels verbatim printed
;; and function definitions verbatim "ground"
;;if filename supplied but 'nil' then return a string
(let ((args (cdr l)))
(cond ((and (cdr args) (null (cadr args)))
(let ((*standard-output* (make-string-output-stream)))
(apply 'tex1 args)
(get-output-stream-string *standard-output*)
)
)
(t (apply 'tex1 args)))))
(defun $texend(filename)
;; this just prints a \\end on the file; this is something a TeXnician
would
;; probably have no trouble spotting, and will generally be
unnecessary, since
;; we anticipate almost all use of tex would be involved in inserting
this
;; stuff into larger files that would have their own \\end or
equivalent.
(with-open-file (st (stripdollar filename)
:direction :output
:if-exists :append
:if-does-not-exist :create)
(format st "\\end~%")
'$done))
(defun $texinit(file)
;; initialize a file so that c-lines will look ok in verbatim mode
;; run this first before tex(, file);
;; copy header from some generic place
(funcall 'exec (list
(concat "cp "
vaxima-main-dir
"//ucb//verbwin " ;extra slashes for maclisp // = /
(stripdollar file))))
'$done )
(defun $texput (e s &optional tx)
;; The texput function was written by Barton Willis.
(cond ((mstringp e)
(setq e (define-symbol (string-left-trim '(#\&) e)))))
(cond (($listp s)
(setq s (margs s)))
(t
(setq s (list s))))
(setq s (mapcar #'stripdollar s))
(cond ((null tx)
(putprop e (nth 0 s) 'texword))
((eq tx '$matchfix)
(putprop e 'tex-matchfix 'tex)
(cond ((< (length s) 2)
(merror "Improper 2nd argument to `texput' for matchfix operator."))
((eq (length s) 2)
(putprop e (list (list (nth 0 s)) (nth 1 s)) 'texsym))
(t
(putprop e (list (list (nth 0 s)) (nth 1 s) (nth 2 s)) 'texsym))))
; The left and right binding powers may be wrong.
((eq tx '$prefix)
(putprop e 'tex-prefix 'tex)
(putprop e s 'texsym)
(putprop e 200 'tex-lbp)
(putprop e 180 'tex-rbp))
((eq tx '$infix)
(putprop e 'tex-infix 'tex)
(putprop e s 'texsym)
(putprop e 200 'tex-lbp)
(putprop e 180 'tex-rbp))
((eq tx '$postfix)
(putprop e 'tex-postfix 'tex)
(putprop e s 'texsym)
(putprop e 160 'tex-lbp))))
____________________________________________________
Yahoo! Sports
Rekindle the Rivalries. Sign up for Fantasy Football
http://football.fantasysports.yahoo.com