share/contrib/tex2ooo.lisp

   1 ; Modifications of tex properties and formatting functions to yield output suitable for OpenOffice formula writer.
   2 ; Modifications to src/mactex.lisp made by Dieter Schuster,
   3 ; extracted into this file by Robert Dodier.
   4 ; Lines beginning with ";-" are lines which have been modified.
   5 ; In addition, all of the defprops here have been modified.
   6
   7 ; Usage:
   8 ;  load (tex2ooo);
   9 ;  tex (expr);
  10
  11
  12 (declare-top
  13  (special lop rop ccol $gcprint texport $labels $inchar))
  14
  15 (defun quote-% (sym)
  16   (let* ((strsym (string sym))
  17          (pos (position-if #'(lambda (c) (find c "%_")) strsym)))
  18     (if pos
  19 ;-      (concatenate 'string (subseq strsym 0 pos) "\\" (subseq strsym pos (1+ pos))
  20         (concatenate 'string (subseq strsym 0 pos) "" (subseq strsym pos (1+ pos))
  21                            (quote-% (subseq strsym (1+ pos))))
  22       strsym)))
  23
  24 (defun tex1 (mexplabel &optional filename ) ;; mexplabel, and optional filename
  25   (prog (mexp  texport $gcprint ccol x y itsalabel)
  26      ;; $gcprint = nil turns gc messages off
  27      (setq ccol 1)
  28      (cond ((null mexplabel)
  29             (displa " No eqn given to TeX")
  30             (return nil)))
  31      ;; collect the file-name, if any, and open a port if needed
  32      (setq texport (cond((null filename) *standard-output* ) ; t= output to terminal
  33                         (t
  34                          (open (string (print-invert-case (stripdollar filename)))
  35                                :direction :output
  36                                :if-exists :append
  37                                :if-does-not-exist :create))))
  38      ;; go back and analyze the first arg more thoroughly now.
  39      ;; do a normal evaluation of the expression in macsyma
  40      (setq mexp (meval mexplabel))
  41      (cond ((member mexplabel $labels :test #'eq)       ; leave it if it is a label
  42             (setq mexplabel (concatenate 'string "(" (print-invert-case (stripdollar mexplabel))
  43                                          ")"))
  44             (setq itsalabel t))
  45            (t (setq mexplabel nil)))    ;flush it otherwise
  46
  47      ;; maybe it is a function?
  48      (cond((symbolp (setq x mexp)) ;;exclude strings, numbers
  49            (setq x ($verbify x))
  50            (cond ((setq y (mget x 'mexpr))
  51                   (setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
  52                  ((setq y (mget x 'mmacro))
  53                   (setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
  54                  ((setq y (mget x 'aexpr))
  55                   (setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
  56      (cond ((and (null(atom mexp))
  57                  (member (caar mexp) '(mdefine mdefmacro) :test #'eq))
  58             (if mexplabel (setq mexplabel (quote-% mexplabel)))
  59             (format texport "|~%" )     ;delimit with |marks
  60             (cond (mexplabel (format texport "~a " mexplabel)))
  61             (mgrind mexp texport)       ;write expression as string
  62             (format texport ";|~%"))
  63            ((and
  64              itsalabel ;; but is it a user-command-label?
  65              (<= (length (string $inchar)) (length (string mexplabel)))
  66              (string= (subseq (string $inchar) 1 (length (string $inchar)))
  67                       (subseq (string mexplabel) 1 (length (string $inchar))))
  68              ;; Check to make sure it isn't an outchar in disguise
  69              (not
  70               (and
  71                (<= (length (string $outchar)) (length (string mexplabel)))
  72                (string= (subseq (string $outchar) 1 (length (string $outchar)))
  73                         (subseq (string mexplabel) 1 (length (string $outchar)))))))
  74             ;; aha, this is a C-line: do the grinding:
  75             (format texport "~%|~a " mexplabel) ;delimit with |marks
  76             (mgrind mexp texport)       ;write expression as string
  77             (format texport ";|~%"))
  78            (t
  79             (if mexplabel (setq mexplabel (quote-% mexplabel)))
  80                                         ; display the expression for TeX now:
  81 ;-          (myprinc "$$")
  82             (myprinc "" texport)
  83             (mapc #'(lambda (x) (myprinc x texport))
  84                   ;;initially the left and right contexts are
  85                   ;; empty lists, and there are implicit parens
  86                   ;; around the whole expression
  87                   (tex mexp nil nil 'mparen 'mparen))
  88             (cond (mexplabel
  89 ;-                 (format texport "\\leqno{\\tt ~a}" mexplabel)))
  90 ;-          (format texport "$$")))
  91                    (format texport "" mexplabel)))
  92             (format texport "")))
  93      (terpri texport)
  94      (cond (filename   ; and close port if not terminal
  95             (close texport)))
  96      (return mexplabel)))
  97
  98 (defun tex-string (x)
  99   (cond ((equal x "") "")
 100         ((eql (elt x 0) #\\) x)
 101 ;-      (t (concatenate 'string "\\mbox{{}" x "{}}"))))
 102         (t (concatenate 'string "" x ""))))
 103
 104 (defun tex-char (x)
 105 ;-  (if (eql x #\|) "\\mbox{\\verb/|/}"
 106 ;-      (concatenate 'string "\\mbox{\\verb|" (string x) "|}")))
 107     (if (eql x #\|) ""
 108         (concatenate 'string "" (string x) "")))
 109
 110 (defun tex-stripdollar(sym &aux )
 111   (or (symbolp sym) (return-from tex-stripdollar sym))
 112   (let* ((pname (quote-% sym))
 113          (l (length pname))
 114          (begin-sub
 115           (loop for i downfrom (1- l)
 116                  when (not (digit-char-p (aref pname i)))
 117                  do (return (1+ i))))
 118          (tem  (make-array (+ l 4) :element-type ' #.(array-element-type "abc") :fill-pointer 0)))
 119     (loop for i below l
 120            do
 121            (cond ((eql i begin-sub)
 122                   (let ((a (assoc tem  *tex-translations* :test 'equal)))
 123                     (cond (a
 124                            (setq a (cdr a))
 125                            (setf (fill-pointer tem) 0)
 126                            (loop for i below (length a)
 127                                   do
 128                                   (vector-push (aref a i) tem)))))
 129 ;-                (vector-push #\_ tem)
 130                   ;; (vector-push #\_ tem)
 131                   (unless (eql i (- l 1))
 132                     (vector-push #\{ tem)
 133                     (setq begin-sub t))))
 134            (cond ((not (and (eql i 0) (eql (aref pname i) #\$)))
 135                   (vector-push (aref pname i) tem)))
 136            finally
 137            (cond ((eql begin-sub t)
 138                   (vector-push #\} tem))))
 139     (intern tem)))
 140
 141 (defun texnumformat(atom)
 142   (let (r firstpart exponent)
 143     (cond ((integerp atom)
 144            atom)
 145           (t
 146            (setq r (explode atom))
 147            (setq exponent (member 'e r :test #'string-equal)) ;; is it ddd.ddde+EE
 148            (cond ((null exponent)
 149                   ;; it is not. go with it as given
 150                   atom)
 151                  (t
 152                   (setq firstpart
 153                         (nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
 154                   (strcat (apply #'strcat firstpart )
 155 ;-                        " \\times 10^{"
 156                           " times 10^{"
 157                           (apply #'strcat (cdr exponent))
 158                           "}")))))))
 159
 160 (defun tex-paren (x l r)
 161 ;-  (tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen))
 162     (tex x (append l '(" left( ")) (cons " right)" r) 'mparen 'mparen))
 163
 164 (defun tex-array (x l r)
 165   (let ((f))
 166     (if (eq 'mqapply (caar x))
 167         (setq f (cadr x)
 168               x (cdr x)
 169 ;-            l (tex f (append l (list "\\left(")) (list "\\right)") 'mparen 'mparen))
 170               l (tex f (append l (list " left( ")) (list " right) ") 'mparen 'mparen))
 171         (setq f (caar x)
 172               l (tex f l nil lop 'mfunction)))
 173     (setq
 174      r (nconc (tex-list (cdr x) nil (list "}") ",") r))
 175     (nconc l (list "_{") r  )))
 176
 177 (defprop mprog "" texword)
 178 (defprop %erf " erf " texword)
 179 (defprop $erf " erf " texword) ;; etc for multicharacter names
 180 (defprop $true  " true "  texword)
 181 (defprop $false " false " texword)
 182 (defprop mprogn ((" left( ") " right) ") texsym)
 183 (defprop mlist ((" left[ ")" right] ") texsym)
 184 (defprop mabs ((" left lline ")" right rline ") texsym)
 185 (defprop $%pi "%pi" texword)
 186 (defprop $inf " infty " texword)
 187 (defprop $minf " - infty " texword)
 188 (defprop %laplace "%DELTA" texword)
 189 (defprop $alpha "%alpha" texword)
 190 (defprop $beta "%beta" texword)
 191 (defprop $gamma "%gamma" texword)
 192 (defprop %gamma "%GAMMA" texword)
 193 (defprop $%gamma "%gamma" texword)
 194 (defprop $delta "%delta" texword)
 195 (defprop $epsilon "%varepsilon" texword)
 196 (defprop $zeta "%zeta" texword)
 197 (defprop $eta "%eta" texword)
 198 (defprop $theta "%vartheta" texword)
 199 (defprop $iota "%iota" texword)
 200 (defprop $kappa "%varkappa" texword)
 201 (defprop $mu "%my" texword)
 202 (defprop $nu "%nu" texword)
 203 (defprop $xi "%xi" texword)
 204 (defprop $pi "%pi" texword)
 205 (defprop $rho "%rho" texword)
 206 (defprop $sigma "%sigma" texword)
 207 (defprop $tau "%tau" texword)
 208 (defprop $upsilon "%ypsilon" texword)
 209 (defprop $phi "%varphi" texword)
 210 (defprop $chi "%chi" texword)
 211 (defprop $psi "%psi" texword)
 212 (defprop $omega "%omega" texword)
 213 (defprop |$Gamma| "%GAMMA" texword)
 214 (defprop |$Delta| "%DELTA" texword)
 215 (defprop |$Theta| "%ThETA" texword)
 216 (defprop |$Lambda| "%LAMBDA" texword)
 217 (defprop |$Xi| "%XI" texword)
 218 (defprop |$Pi| "%PI" texword)
 219 (defprop |$Sigma| "%SIGMA" texword)
 220 (defprop |$Upsilon| "%YPSILON" texword)
 221 (defprop |$Phi| "%PHI" texword)
 222 (defprop |$Psi| "%PSI" texword)
 223 (defprop |$Omega| "%OMEGA" texword)
 224 (defprop marrow (" rightarrow ") texsym)
 225
 226 (defun tex-mexpt (x l r)
 227   (let((nc (eq (caar x) 'mncexpt)))     ; true if a^^b rather than a^b
 228     ;; here is where we have to check for f(x)^b to be displayed
 229     ;; as f^b(x), as is the case for sin(x)^2 .
 230     ;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
 231     ;; yet we must not display (a+b)^2 as +^2(a,b)...
 232     ;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
 233     (cond ;; this whole clause
 234       ;; should be deleted if this hack is unwanted and/or the
 235       ;; time it takes is of concern.
 236       ;; it shouldn't be too expensive.
 237       ((and (eq (caar x) 'mexpt)      ; don't do this hack for mncexpt
 238             (let*
 239                 ((fx (cadr x))          ; this is f(x)
 240                  (f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
 241                  (bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
 242                  (expon (caddr x)) ;; this is the exponent
 243                  (doit (and
 244                         f               ; there is such a function
 245                         (member (get-first-char f) '(#\% #\$) :test #'char=) ;; insist it is a % or $ function
 246                         (not (member 'array (cdar fx) :test #'eq))      ; fix for x[i]^2
 247                                         ; Jesper Harder <harder@ifa.au.dk>
 248                         (not (member f '(%sum %product %derivative %integrate %at
 249                                        %lsum %limit) :test #'eq)) ;; what else? what a hack...
 250                         (or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
 251                             (and (atom expon) (numberp expon) (> expon 0))))))
 252                                         ; f(x)^3 is ok, but not f(x)^-1, which could
 253                                         ; inverse of f, if written f^-1 x
 254                                         ; what else? f(x)^(1/2) is sqrt(f(x)), ??
 255               (cond (doit
 256                      (setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
 257                      (if (and (null (cdr bascdr))
 258                               (eq (get f 'tex) 'tex-prefix))
 259                          (setq r (tex (car bascdr) nil r f 'mparen))
 260                          (setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
 261                     (t nil)))))         ; won't doit. fall through
 262       (t (setq l (cond ((and (numberp (cadr x))
 263                              (numneedsparen (cadr x)))
 264 ;-                      (tex (cadr x) (cons "\\left(" l) '("\\right)") lop
 265                         (tex (cadr x) (cons " left( " l) '(" right) ") lop
 266                              (caar x)))
 267                        (t (tex (cadr x) l nil lop (caar x))))
 268                r (if (mmminusp (setq x (nformat (caddr x))))
 269                      ;; the change in base-line makes parens unnecessary
 270                      (if nc
 271 ;-                       (tex (cadr x) '("^ {-\\langle ")(cons "\\rangle }" r) 'mparen 'mparen)
 272                          (tex (cadr x) '("^ {- langle ")(cons " rangle }" r) 'mparen 'mparen)
 273                          (tex (cadr x) '("^ {- ")(cons " }" r) 'mparen 'mparen))
 274                      (if nc
 275 ;-                       (tex x (list "^{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
 276                          (tex x (list "^{ langle ")(cons " rangle }" r) 'mparen 'mparen)
 277                          (if (and (integerp x) (< x 10))
 278 ;-                           (tex x (list "^")(cons "" r) 'mparen 'mparen)
 279                              (tex x (list "^")(cons " " r) 'mparen 'mparen)
 280                              (tex x (list "^{")(cons "}" r) 'mparen 'mparen))
 281                          )))))
 282     (append l r)))
 283
 284 (defprop mnctimes (" cdot ") texsym)
 285 (defprop mtimes (" cdot ") texsym)    ;; HMM, SEEMS INADVISABLE
 286
 287 (defun tex-sqrt(x l r)
 288   ;; format as \\sqrt { } assuming implicit parens for sqr grouping
 289 ;-  (tex (cadr x) (append l  '("\\sqrt{")) (append '("}") r) 'mparen 'mparen))
 290     (tex (cadr x) (append l  '(" sqrt {")) (append '("}") r) 'mparen 'mparen))
 291
 292 (defun tex-cubrt (x l r)
 293 ;-  (tex (cadr x) (append l  '("\\root 3 \\of{")) (append '("}") r) 'mparen 'mparen))
 294     (tex (cadr x) (append l  '(" nroot {3} {")) (append '("}") r) 'mparen 'mparen))
 295
 296 (defprop mquotient (" over ") texsym)
 297
 298 (defun tex-mquotient (x l r)
 299   (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
 300 ;-  (setq l (tex (cadr x) (append l '("{{")) nil 'mparen 'mparen)
 301     (setq l (tex (cadr x) (append l '("{alignc {")) nil 'mparen 'mparen)
 302                                         ;the divide bar groups things
 303 ;-      r (tex (caddr x) (list "}\\over{") (append '("}}")r) 'mparen 'mparen))
 304         r (tex (caddr x) (list "} over {") (append '("}}")r) 'mparen 'mparen))
 305   (append l r))
 306
 307 (defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
 308 ;-  (append l `("\\pmatrix{")
 309     (append l `(" left( matrix {")
 310           (let ((foo (mapcan #'(lambda(y)
 311 ;-                    (tex-list (cdr y) nil (list "\\cr ") "&"))
 312                       (tex-list (cdr y) nil (list " ## ") " # "))
 313                   (cdr x))))
 314             (setf (car (last foo)) " ")
 315             foo)
 316 ;-        '("}") r))
 317           '("} right) ") r))
 318
 319 (defun tex-lsum(x l r)
 320 ;-  (let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
 321     (let ((op (cond ((eq (caar x) '%lsum) "sum from {")
 322                   ;; extend here
 323                   ))
 324         ;; gotta be one of those above
 325         (s1 (tex (cadr x) nil nil 'mparen rop)) ;; summand
 326         (index ;; "index = lowerlimit"
 327          (tex `((min simp) , (caddr x), (cadddr x))  nil nil 'mparen 'mparen)))
 328     (append l `( ,op ,@index "}}{" ,@s1 "}") r)))
 329
 330 (defun tex-sum(x l r)
 331 ;-  (let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
 332 ;-                ((eq (caar x) '%product) "\\prod_{")
 333     (let ((op (cond ((eq (caar x) '%sum) " sum from {")
 334                   ((eq (caar x) '%product) " prod from {")
 335                   ;; extend here
 336                   ))
 337         ;; gotta be one of those above
 338         (s1 (tex (cadr x) nil nil 'mparen rop)) ;; summand
 339         (index ;; "index = lowerlimit"
 340          (tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
 341         (toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
 342 ;-    (append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
 343       (append l `( ,op ,@index "} to {" ,@toplim "}{" ,@s1 "}") r)))
 344
 345 (defun tex-int (x l r)
 346   (let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integrand delims / & d
 347         (var (tex (caddr x) nil nil 'mparen rop))) ;; variable
 348     (cond((= (length x) 3)
 349 ;-        (append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
 350           (append l `(" int {" ,@s1 "}{`d" ,@var "}") r))
 351          (t ;; presumably length 5
 352           (let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
 353                 ;; 1st item is 0
 354                 (hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
 355 ;-          (append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
 356             (append l `(" int from {" ,@low "} to {" ,@hi "}{" ,@s1 " d" ,@var "}") r))))))
 357
 358 (defun tex-limit(x l r) ;; ignoring direction, last optional arg to limit
 359   (let ((s1 (tex (cadr x) nil nil 'mparen rop)) ;; limitfunction
 360         (subfun ;; the thing underneath "limit"
 361 ;-       (subst "\\rightarrow " '=
 362          (subst " rightarrow " '=
 363                 (tex `((mequal simp) ,(caddr x),(cadddr x))
 364                      nil nil 'mparen 'mparen))))
 365 ;-    (append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
 366       (append l `(" lim from {" ,@subfun "}{" ,@s1 "}") r)))
 367
 368 (defun tex-at (x l r)
 369   (let ((s1 (tex (cadr x) nil nil lop rop))
 370         (sub (tex (caddr x) nil nil 'mparen 'mparen)))
 371 ;-    (append l '("\\left.") s1  '("\\right|_{") sub '("}") r)))
 372       (append l '(" left .") s1  '(" right |_{") sub '("}") r)))
 373
 374 (defun tex-mbox (x l r)
 375 ;-  (append l '("\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}") r))
 376     (append l '("{") (tex (cadr x) nil nil 'mparen 'mparen) '("}") r))
 377
 378 (defun tex-choose (x l r)
 379   `(,@l
 380 ;-    "\\pmatrix{"
 381       " matrix {"
 382     ,@(tex (cadr x) nil nil 'mparen 'mparen)
 383 ;-    "\\\\"
 384       " ## "
 385     ,@(tex (caddr x) nil nil 'mparen 'mparen)
 386     "}"
 387     ,@r))
 388
 389 (defun tex-mplus (x l r)
 390 ;-  (cond ((member 'trunc (car x) :test #'eq)(setq r (cons "+\\cdots " r))))
 391     (cond ((member 'trunc (car x) :test #'eq)(setq r (cons " + dotsaxis " r))))
 392   (cond ((null (cddr x))
 393          (if (null (cdr x))
 394              (tex-function x l r t)
 395 ;-           (tex (cadr x) (cons "+" l) r 'mplus rop)))
 396              (tex (cadr x) (cons " + " l) r 'mplus rop)))
 397         (t (setq l (tex (cadr x) l nil lop 'mplus)
 398                  x (cddr x))
 399            (do ((nl l)  (dissym))
 400                ((null (cdr x))
 401 ;-              (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
 402 ;-                  (setq l (car x) dissym (list "+")))
 403                 (if (mmminusp (car x)) (setq l (cadar x) dissym (list " - "))
 404                     (setq l (car x) dissym (list " + ")))
 405                 (setq r (tex l dissym r 'mplus rop))
 406                 (append nl r))
 407 ;-           (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
 408 ;-               (setq l (car x) dissym (list "+")))
 409              (if (mmminusp (car x)) (setq l (cadar x) dissym (list " - "))
 410                  (setq l (car x) dissym (list " + ")))
 411              (setq nl (append nl (tex l dissym nil 'mplus 'mplus))
 412                    x (cdr x))))))
 413
 414 (defprop mminus (" `-`") texsym)
 415 (defprop min (" in ") texsym)
 416 (defprop mgeqp (" geq ") texsym)
 417 (defprop mleqp (" leq ") texsym)
 418 (defprop mnot (" not ") texsym)
 419 (defprop mand (" and ") texsym)
 420 (defprop mor (" or ") texsym)
 421 (defprop mnotequal (" neq ") texsym)
 422
 423 (mapc #'tex-setup
 424       '(
 425         (%acos " arccos ")
 426         (%asin " arcsin ")
 427         (%atan " arctan ")
 428         (%cos " cos ")
 429         (%cosh " cosh ")
 430         (%cot " cot ")
 431         (%coth " coth ")
 432         (%csc " csc ")
 433         (%determinant " det ")
 434         (%dim " dim ")
 435         (%exp " exp ")
 436         (%gcd " gcd ")
 437         (%inf " inf ")
 438         (%ln " ln ")
 439         (%log " log ")
 440         (%max " max ")
 441         (%min " min ")
 442         (%sec " sec ")
 443         (%sin " sin ")
 444         (%sinh " sinh ")
 445         (%tan " tan ")
 446         (%tanh " tanh ")
 447         ))
 448
 449 (defun tex-mcond (x l r)
 450   (append l
 451 ;-        (tex (cadr x) '("\\mathbf{if}\\;")
 452 ;-             '("\\;\\mathbf{then}\\;") 'mparen 'mparen)
 453           (tex (cadr x) '(" bold if")
 454                '(" bold then") 'mparen 'mparen)
 455      (if (eql (fifth x) '$false)
 456          (tex (caddr x) nil r 'mcond rop)
 457          (append (tex (caddr x) nil nil 'mparen 'mparen)
 458 ;-                    (tex (fifth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))))
 459                       (tex (fifth x) '(" bold else") r 'mcond rop)))))
 460
 461 (defun tex-mdo (x l r)
 462 ;-  (tex-list (texmdo x) l r "\\;"))
 463     (tex-list (texmdo x) l r "`"))
 464
 465 (defun tex-mdoin (x l r)
 466 ;-  (tex-list (texmdoin x) l r "\\;"))
 467     (tex-list (texmdoin x) l r "`"))
 468
 469 (defun texmdo (x)
 470 ;-  (nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
 471     (nconc (cond ((second x) `(" bold for" ,(second x))))
 472          (cond ((equal 1 (third x)) nil)
 473 ;-             ((third x)  `("\\mathbf{from}" ,(third x))))
 474                ((third x)  `(" bold from" ,(third x))))
 475          (cond ((equal 1 (fourth x)) nil)
 476 ;-             ((fourth x) `("\\mathbf{step}" ,(fourth x)))
 477 ;-             ((fifth x)  `("\\mathbf{next}" ,(fifth x))))
 478 ;-       (cond ((sixth x)  `("\\mathbf{thru}" ,(sixth x))))
 479                ((fourth x) `(" bold step" ,(fourth x)))
 480                ((fifth x)  `(" bold next" ,(fifth x))))
 481          (cond ((sixth x)  `(" bold thru" ,(sixth x))))
 482          (cond ((null (seventh x)) nil)
 483                ((eq 'mnot (caar (seventh x)))
 484 ;-              `("\\mathbf{while}" ,(cadr (seventh x))))
 485 ;-             (t `("\\mathbf{unless}" ,(seventh x))))
 486 ;-       `("\\mathbf{do}" ,(eighth x))))
 487                 `(" bold while" ,(cadr (seventh x))))
 488                (t `(" bold unless" ,(seventh x))))
 489          `(" bold do" ,(eighth x))))
 490
 491 (defun texmdoin (x)
 492 ;-  (nconc `("\\mathbf{for}" ,(second x) "\\mathbf{in}" ,(third x))
 493 ;-       (cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
 494     (nconc `(" bold for" ,(second x) " bold in" ,(third x))
 495          (cond ((sixth x) `(" bold thru" ,(sixth x))))
 496          (cond ((null (seventh x)) nil)
 497                ((eq 'mnot (caar (seventh x)))
 498 ;-              `("\\mathbf{while}" ,(cadr (seventh x))))
 499 ;-             (t `("\\mathbf{unless}" ,(seventh x))))
 500 ;-       `("\\mathbf{do}" ,(eighth x))))
 501                 `(" bold while" ,(cadr (seventh x))))
 502                (t `(" bold unless" ,(seventh x))))
 503          `(" bold do" ,(eighth x))))
 504
 505 (defprop | --> | " rightarrow " texsym)
 506 (defprop | WHERE | "` bold where`" texsym)
 507
 508 (defun tex-mlabel (x l r)
 509   (tex (caddr x)
 510        (append l
 511                (if (cadr x)
 512 ;-                 (list (format nil "\\mbox{\\tt\\red(~A) \\black}" (tex-stripdollar (cadr x))))
 513                    (list (format nil "" (tex-stripdollar (cadr x))))
 514                    nil))
 515        r 'mparen 'mparen))
 516
 517 (defun tex-spaceout (x l r)
 518 ;-  (append l (cons (format nil "\\hspace{~dmm}" (* 3 (cadr x))) r)))
 519     (append l (cons (format nil "~" (* 3 (cadr x))) r)))