
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : tmtex.scm
;; DESCRIPTION : conversion of TeXmacs trees into TeX/LaTeX trees
;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
;;
;; This software falls under the GNU general public license and comes WITHOUT
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
;; If you don't have this file, write to the Free Software Foundation, Inc.,
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define tmtex-initialized #f)
(define tmtex-methods (make-hash-table 500))
(define tmtex-tmstyle (make-hash-table 500))
(define tmtex-env (make-hash-table 1000))
(define tmtex-table-props (make-hash-table 100))
(define tex-mathops (make-hash-table 100))
(define tex-with-cmd (make-hash-table 100))
(define tex-assign-cmd (make-hash-table 100))

(define tmtex-methods-def
  '((document tmtex-document)
    (paragraph tmtex-paragraph)
    (surround tmtex-surround)
    (concat tmtex-concat)
    (format tmtex-format)
    (hspace tmtex-hspace)
    (vspace* tmtex-noop) (vspace tmtex-vspace)
    (space tmtex-space)
    (htab tmtex-htab)
    (split tmtex-noop)
    (move tmtex-noop) (resize tmtex-noop)
    (float tmtex-float)
    (repeat datoms dlines dpages dbox tmtex-noop)
    (group tmtex-group)
    (left tmtex-left) (mid tmtex-mid) (right tmtex-right)
    (big tmtex-big)
    (lprime tmtex-lprime) (rprime tmtex-rprime)
    (below tmtex-below) (above tmtex-above)
    (lsub tmtex-lsub) (lsup tmtex-lsup)
    (rsub tmtex-rsub) (rsup tmtex-rsup)
    (frac tmtex-frac) (sqrt tmtex-sqrt) (wide tmtex-wide) (neg tmtex-neg)
    (tree tmtex-noop)
    (old_matrix old_table old_mosaic old_mosaic_item tmtex-noop)
    (tformat tmtex-tformat)
    (twith cwith tmarker tmtex-noop)
    (table tmtex-table)
    (row cell sub_table tmtex-noop)
    (assign tmtex-assign)
    (with tmtex-with)
    (set reset tmtex-noop)
    (var_expand expand apply tmtex-expand)
    (begin end tmtex-noop)
    (include tmtex-noop)
    (macro func env eval tmtex-noop)
    (value tmtex-expand)
    (arg tmtex-noop)
    (backup quote delay hold release tmtex-noop)
    (or xor and not plus minus times over div mod merge length range
     number date translate is_tuple look_up equal unequal less lesseq
     greater greatereq if case while extern authorize tmtex-noop)
    (inactive symbol latex hybrid tuple collection associate tmtex-noop)
    (label tmtex-label) (reference tmtex-reference) (pageref tmtex-pageref)
    (write tmtex-noop)
    (specific tmtex-specific)
    (hlink tmtex-hyperlink) (action tmtex-action)
    (tag tmtex-noop) (meaning tmtex-noop)
    (graphics point line arc bezier tmtex-noop)
    (postscript tmtex-postscript)

    (!file tmtex-file)
    (!arg tmtex-tex-arg)))

(define tmtex-tmstyle-def
  '((make-title (tmtex-make-title 1))
    (abstract (tmtex-std-env 1))
    (theorem proposition lemma corollary proof axiom definition conjecture
     remark note example exercise warning convention quote
     quotation verse (tmtex-std-env 1))
    (verbatim code (tmtex-verbatim 1))
    (center indent body (tmtex-std-env 1))
    (description itemize itemize-minus itemize-dot itemize-arrow
     enumerate enumerate-numeric enumerate-roman enumerate-Roman
     enumerate-alpha enumerate-Alpha (tmtex-list-env 1))
    (equation equation* (tmtex-equation 1))
    (eqnarray* leqnarray$ (tmtex-eqnarray 1))
    (the-index the-glossary (tmtex-dummy -1))
    (table-of-contents (tmtex-toc 2))
    (bibliography (tmtex-bib 4))
    (small-figure big-figure small-table big-table (tmtex-figure 2))
    (item (tmtex-item 0))
    (item* (tmtex-item-arg 1))
    (session (tmtex-session 3))
    (input (tmtex-input 2))
    (output (tmtex-output 1))
    (cite nocite (tmtex-cite -1))
    (choose (tmtex-choose 2))
    (strong em tt name samp abbr
     dfn kbd var acronym person (tmtex-modifier 1))))

(define tmtex-table-props-def
  '((block ("" "l" "" #t))
    (block* ("" "c" "" #t))
    (tabular ("" "l" "" #f))
    (tabular* ("" "c" "" #f))
    (matrix ((#{left\(}#) "c" (#{right\)}#) #f))
    (det ((left|) "c" (right|) #f))
    (choice ((left\{) "c" (right.) #f))))

(define tex-mathops-def
  '(arccos arcsin arctan cos cosh cot coth csc deg det dim exp gcd
    hom inf ker lg lim liminf limsup ln log max min Pr sec sin
    sinh sup tan tanh))

(define tex-with-cmd-def
  '((("font family" "rm") textrm)
    (("font family" "ss") textss)
    (("font family" "tt") texttt)
    (("font series" "medium") textmd)
    (("font series" "bold") textbf)
    (("font shape" "right") textup)
    (("font shape" "slanted") textsl)
    (("font shape" "italic") textit)
    (("font shape" "small-caps") textsc)
    (("math font" "cal") mathcal)
    (("math font" "cal*") mathcal)
    (("math font" "cal**") mathcal)
    (("math font" "Euler") mathfrak)
    (("math font" "Bbb") mathbb)
    (("math font" "Bbb*") mathbb)
    (("math font" "Bbb**") mathbb)
    (("math font" "Bbb***") mathbb)
    (("math font" "Bbb****") mathbb)
    (("math font family" "mr") mathrm)
    (("math font family" "ms") mathsf)
    (("math font family" "mt") mathtt)
    (("math font family" "normal") mathnormal)
    (("math font family" "rm") mathrm)
    (("math font family" "ss") mathsf)
    (("math font family" "tt") mathtt)
    (("math font family" "bf") mathbf)
    (("math font family" "it") mathit)
    (("math font series" "bold") tmmathbf)))

(define tex-assign-cmd-def
  '((("font family" "rm") rmfamily)
    (("font family" "ss") ssfamily)
    (("font family" "tt") ttfamily)
    (("font series" "medium") mdseries)
    (("font series" "bold") bfseries)
    (("font shape" "right") upshape)
    (("font shape" "slanted") slshape)
    (("font shape" "italic") itshape)
    (("font shape" "small-caps") scshape)
    (("color" "black") black)
    (("color" "grey") grey)
    (("color" "white") white)
    (("color" "red") red)
    (("color" "blue") blue)
    (("color" "yellow") yellow)
    (("color" "magenta") magenta)
    (("color" "orange") orange)
    (("color" "green") green)
    (("color" "brown") brown)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-initialize)
  (if (not tmtex-initialized)
      (begin
	(set! tmtex-initialized #t)
	(fill-dictionary tmtex-methods tmtex-methods-def)
	(fill-dictionary tmtex-tmstyle tmtex-tmstyle-def)
	(fill-set tex-mathops tex-mathops-def)
	(fill-dictionary tmtex-table-props tmtex-table-props-def)
	(fill-dictionary tex-with-cmd tex-with-cmd-def)
	(fill-dictionary tex-assign-cmd tex-assign-cmd-def)))
  (set! tmtex-env (make-hash-table 1000)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Manipulation of the environment
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-env-list var)
  (let ((r (hash-ref tmtex-env var)))
    (if r r '())))

(define (tmtex-env-get var)
  (let ((val (tmtex-env-list var)))
    (if (null? val) #f
	(car val))))

(define (tmtex-math-mode?)
  (equal? (tmtex-env-get "mode") "math"))

(define (tmtex-env-set var val)
  (hash-set! tmtex-env var (cons val (tmtex-env-list var))))

(define (tmtex-env-reset var)
  (let ((val (tmtex-env-list var)))
    (if (not (null? val))
	(hash-set! tmtex-env var (cdr val)))))

(define (tmtex-env-assign var val)
  (tmtex-env-reset var)
  (tmtex-env-set var val))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Frequently used TeX construction subroutines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tex-concat-similar l)
  (if (or (null? l) (null? (cdr l))) l
      (let ((r (tex-concat-similar (cdr l))))
	(if (and (string? (car l)) (string? (car r)))
	    (cons (string-append (car l) (car r)) (cdr r))
	    (if (and (func? (car l) '!sup) (func? (car r) '!sup))
		(cons (list '!sup (tex-concat (list (cadar l) (cadar r))))
		      (cdr r))
		(cons (car l) r))))))

(define (tex-concat-list l)
  (cond ((null? l) l)
	((equal? (car l) "") (tex-concat-list (cdr l)))
	((func? (car l) '!concat) (append (cdar l) (tex-concat-list (cdr l))))
	(else (cons (car l) (tex-concat-list (cdr l))))))

(define (tex-concat l)
  (let ((r (tex-concat-similar (tex-concat-list l))))
    (if (null? r) ""
	(if (null? (cdr r)) (car r)
	    (cons '!concat r)))))

(define tex-apply
  (lambda l
    (if (or (tmtex-math-mode?) (hash-ref tmpre-sectional (car l))) l
	(list '!group l))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-token-sub s)
  (cond ((equal? s "less") #\<)
	((equal? s "gtr") #\>)
	((equal? s "box") (list 'Box))
	((equal? s "||") (list '|))
	(else (list (string->symbol s)))))

(define (tmtex-token l routine)
  (let* ((p (split (cdr l) (lambda (x) (equal? x #\>))))
	 (s (list->string (car p)))
	 (q (if (null? (cadr p)) '() (cdadr p)))
	 (r (routine q)))
    (cons (tmtex-token-sub s) r)))

(define (tmtex-text-sub head l)
  (append (string->list head) (tmtex-text-list (cdr l))))

(define (tmtex-special-char? c)
  (in? c '(#\# #\$ #\% #\& #\_ #\{ #\})))

(define (tmtex-text-list l)
  (if (null? l) l
      (let ((c (car l)))
	(cond ((equal? c #\<) (tmtex-token l tmtex-text-list))
	      ((tmtex-special-char? c)
	       (cons (list (char->string c)) (tmtex-text-list (cdr l))))
	      ((equal? c #\~) (cons (list '~ " ") (tmtex-text-list (cdr l))))
	      ((equal? c #\^) (cons (list '^ " ") (tmtex-text-list (cdr l))))
	      ((equal? c #\\) (cons (list 'tmbsl) (tmtex-text-list (cdr l))))
	      ((equal? c #\21) (tmtex-text-sub "''" l))
	      ((equal? c #\22) (tmtex-text-sub ",," l))
	      ((equal? c #\25) (tmtex-text-sub "--" l))
	      ((equal? c #\26) (tmtex-text-sub "---" l))
	      ((equal? c #\337) (tmtex-text-sub "SS" l))
	      ((equal? c #\377) (tmtex-text-sub "ß" l))
	      (else (cons c (tmtex-text-list (cdr l))))))))

(define (tmtex-math-operator l)
  (let* ((p (split l (lambda (c) (not (char-alphabetic? c)))))
	 (op (list->string (car p)))
	 (tail (tmtex-math-list (cadr p))))
    (if (hash-ref tex-mathops (string->symbol op))
	(cons (tex-apply (string->symbol op)) tail)
	(cons (tex-apply 'tmop op) tail))))

(define (tmtex-math-list l)
  (if (null? l) l
      (let ((c (car l)))
	(cond ((equal? c #\<) (tmtex-token l tmtex-math-list))
	      ((tmtex-special-char? c)
	       (cons (list (char->string c)) (tmtex-math-list (cdr l))))
	      ((equal? c #\~) (tmtex-math-list (cdr l)))
	      ((equal? c #\^) (tmtex-math-list (cdr l)))
	      ((equal? c #\\)
	       (cons (list 'backslash) (tmtex-math-list (cdr l))))
;;	      ((equal? c #\*) (cons '(*) (tmtex-math-list (cdr l))))
	      ((equal? c #\*) (tmtex-math-list (cdr l)))
	      ((equal? c #\space) (tmtex-math-list (cdr l)))
	      ((and (char-alphabetic? c)
		    (not (null? (cdr l)))
		    (char-alphabetic? (cadr l)))
	       (tmtex-math-operator l))
	      (else (cons c (tmtex-math-list (cdr l))))))))

(define (tmtex-no-math-space c1 c2)
  (or (equal? c2 #\,)
      (and (equal? c1 c2) (in? c1 '(#\( #\) #\[ #\])))
      (and (char? c1) (char? c2)
	   (char-numeric? c1) (char-numeric? c2))))

(define (tmtex-math-spaces l)
  (if (or (null? l) (null? (cdr l))) l
      (let ((tail (tmtex-math-spaces (cdr l))))
	(if (tmtex-no-math-space (car l) (cadr l))
	    (cons (car l) tail)
	    (cons* (car l) #\space tail)))))

(define (tmtex-verb-list l)
  (if (null? l) l
      (let ((c (car l)))
	(if (equal? c #\<)
	    (let ((r (tmtex-token l tmtex-verb-list)))
	      (if (char? (car r)) r (cdr r)))
	    (cons c (tmtex-verb-list (cdr l)))))))

(define (tmtex-string-produce l)
  (if (null? l) l
      (if (char? (car l))
	  (let ((p (split l (lambda (x) (not (char? x))))))
	    (cons (list->string (car p))
		  (tmtex-string-produce (cadr p))))
	  (cons (car l) (tmtex-string-produce (cdr l))))))

(define (tmtex-text-string s)
  (let* ((l (string->list s))
	 (t (tmtex-text-list l))
	 (r (tmtex-string-produce t)))
    (tex-concat r)))

(define (tmtex-math-string s)
  (let* ((l (string->list s))
	 (t (tmtex-math-list l))
	 (u (tmtex-math-spaces t))
	 (r (tmtex-string-produce u)))
    (tex-concat r)))

(define (tmtex-verb-string s)
  (let* ((l (string->list s))
	 (t (tmtex-verb-list l))
	 (r (tmtex-string-produce t)))
    (tex-concat r)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple text
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-noop l) "")

(define (tmtex-file l)
  (let* ((doc (car l))
	 (styles (cdadr l))
	 (lang (caddr l))
	 (tmpath (cadddr l)))
    (if (null? styles) (tmtex doc)
	(list '!file (tmtex doc) styles lang tmpath))))

(define (tmtex-document l)
  (cons '!document (tmtex-list l)))

(define (tmtex-paragraph l)
  (cons '!paragraph (tmtex-list l)))

(define (tmtex-surround-sub l z)
  (if (null? (cdr l))
      (list (tex-concat (list (car l) z)))
      (cons (car l) (tmtex-surround-sub (cdr l) z))))

(define (tmtex-surround l)
  (let* ((ll (tmtex-list l))
	 (x (car ll))
	 (y (caddr ll))
	 (z (cadr ll)))
    (if (func? y '!document)
	(let* ((a (cadr y))
	       (b (cddr y)))
	  (cons '!document
		(tmtex-surround-sub
		 (cons (tex-concat (list x a)) b) z)))
	(tex-concat (list x y z)))))

(define (tmtex-script? x)
  (or (func? x '!sub)
      (func? x '!sup)
      (and (string? x) (not (equal? x "")) (in? (string-ref x 0) '(#\' #\,)))
      (and (func? x '!concat) (tmtex-script? (cadr x)))))

(define (tmtex-math-concat-spaces l)
  (if (or (null? l) (null? (cdr l))) l
      (let* ((head (car l))
	     (tail (tmtex-math-concat-spaces (cdr l))))
	(if (tmtex-script? (car tail))
	    (cons head tail)
	    (cons* head " " tail)))))

(define (tmtex-concat l)
  (if (tmtex-math-mode?)
      (tex-concat (tmtex-math-concat-spaces (tmtex-list l)))
      (tex-concat (tmtex-list l))))

(define (tmtex-format l)
  (let ((s (car l)))
    (cond ((equal? s "no first indentation") (tex-apply 'noindent))
	  ((equal? s "line break") (tex-apply 'linebreak))
	  ((equal? s "page break") (tex-apply 'pagebreak))
	  ((equal? s "new page") (tex-apply 'newpage))
	  ((equal? s "new line") (list '!newline))
	  ((equal? s "next line") (list '!nextline))
	  (else ""))))

(define (tmtex-decode-length s)
  (cond ((string-ends? s "fn") (string-replace s "fn" "em"))
	((string-ends? s "spc") (string-replace s "spc" "em"))
	(else s)))

(define (tmtex-hspace l)
  (let ((s (if (= (length l) 1) (car l) (cadr l))))
    (cond ((equal? s "1fn") (list 'quad))
	  ((equal? s "-0.6spc")
	   (list '!concat
		 (list (string->symbol "!"))
		 (list (string->symbol "!"))
		 (list (string->symbol "!"))))
	  ((equal? s "-0.4spc")
	   (list '!concat
		 (list (string->symbol "!"))
		 (list (string->symbol "!"))))
	  ((equal? s "-0.2spc") (list (string->symbol "!")))
	  ((equal? s "0.2spc") (list (string->symbol ",")))
	  ((equal? s "0.4spc") (list (string->symbol ":")))
	  ((equal? s "0.6spc") (list (string->symbol ";")))
	  (else (tex-apply 'hspace (tmtex-decode-length s))))))

(define (tmtex-vspace l)
  (let ((s (if (= (length l) 1) (car l) (cadr l))))
    (cond ((equal? s "0.5fn") (tex-apply 'smallskip))
	  ((equal? s "1fn") (tex-apply 'medskip))
	  ((equal? s "2fn") (tex-apply 'bigskip))
	  (else (tex-apply 'vspace (tmtex-decode-length s))))))

(define (tmtex-space l)
  (tmtex-hspace (list (car l))))

(define (tmtex-float-make type position x caption)
  (list (list '!begin type (list '!option position))
	(list (list '!begin "center")
	      (if (equal? caption "") (tmtex x)
		  (list '!paragraph
			(tmtex x)
			(list 'caption (tmtex caption)))))))

(define (tmtex-float-table? x)
  (or (func? x 'small-table 2) (func? x 'big-table 2)))

(define (tmtex-float-figure? x)
  (or (func? x 'small-figure 2) (func? x 'big-figure 2)))

(define (tmtex-float-sub position l)
  (cond ((func? l 'document 1) (tmtex-float-sub position (cadr l)))
	((or (func? l 'var_expand) (func? l 'expand) (func? l 'apply))
	 (let ((ll (cons (string->symbol (cadr l)) (cddr l))))
	   (if (or (tmtex-float-table? ll) (tmtex-float-figure?))
	       (tmtex-float-sub position ll)
	       (tmtex-float-make "figure" position l ""))))
	((tmtex-float-figure? l)
	 (tmtex-float-make "figure" position (cadr l) (caddr l)))
	((tmtex-float-table? l)
	 (tmtex-float-make "table" position (cadr l) (caddr l)))
	(else (tmtex-float-make "figure" position l ""))))

(define (tmtex-float l)
  (tmtex-float-sub (force-string (cadr l)) (caddr l)))

(define (tmtex-htab l)
  (tex-apply 'hspace* (list 'fill)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mathematics
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-group l)
  (tmtex-function '!group l))

(define (tmtex-large-decode s)
  (cond ((not (string? s)) ".")
        ((in? s '("(" ")" "[" "]" "|" "/")) s)
	((equal? s "||") "\\|")
	((equal? s "\\") "\\backslash")
	(else (string-append "\\" s))))

(define (tmtex-left l)
  (list (string->symbol (string-append "left" (tmtex-large-decode (car l))))))

(define (tmtex-mid l)
  (let ((s (tmtex-large-decode (car l))))
    (if (equal? (string-ref s 0) #\\)
	(list (string->symbol (substring s 1 (string-length s))))
	s)))

(define (tmtex-right l)
  (list (string->symbol (string-append "right" (tmtex-large-decode (car l))))))

(define (tmtex-big-decode s)
  (cond ((not (string? s)) "bignone")
        ((in? s '("sum" "prod" "int" "oint")) s)
	((equal? s "amalg") "coprod")
	((equal? s "pluscup") "uplus")
	((equal? s ".") "bignone")
	(else (string-append "big" s))))

(define (tmtex-big l)
  (list (string->symbol (tmtex-big-decode (car l)))))

(define (tmtex-prime-list l)
  (if (null? l) l
      (cond ((equal? (car l) #\<)
	     (let* ((p (split (cdr l) (lambda (c) (equal? c #\>))))
		    (next (if (null? (cadr p)) '() (cdadr p))))
	       (cons (list '!sup (list (string->symbol
					(list->string (car p)))))
		     (tmtex-prime-list next))))
	    ((equal? (car l) #\') (cons "'" (tmtex-prime-list (cdr l))))
	    ((equal? (car l) #\`)
	     (cons (list '!sup (list 'backprime))
		   (tmtex-prime-list (cdr l))))
	    (else (cons (list '!sup (char->string (car l)))
			(tmtex-prime-list (cdr l)))))))

(define (tmtex-lprime l)
  (tmtex (list 'concat (list 'text "") (list 'rprime (car l)))))

(define (tmtex-rprime l)
  (tex-concat (tmtex-prime-list (string->list (car l)))))

(define (tmtex-below l)
  (list 'underset (tmtex (cadr l)) (tmtex (car l))))

(define (tmtex-above l)
  (list 'overset (tmtex (cadr l)) (tmtex (car l))))

(define (tmtex-lsub l)
  (tmtex (list 'concat (list 'text "") (list 'rsub (car l)))))

(define (tmtex-lsup l)
  (tmtex (list 'concat (list 'text "") (list 'rsup (car l)))))

(define (tmtex-rsub l)
  (tmtex-function '!sub l))

(define (tmtex-rsup l)
  (tmtex-function '!sup l))

(define (tmtex-frac l)
  (tmtex-function 'frac l))

(define (tmtex-sqrt l)
  (if (= (length l) 1)
      (tmtex-function 'sqrt l)
      (list 'sqrt
	    (list '!option (tmtex (cadr l)))
	    (tmtex (car l)))))

(define (tmtex-token? s)
  (or (= (string-length s) 1)
      (and (not (equal? s ""))
	   (equal? (string-ref s 0) #\<)
	   (equal? (string-index s #\>) (- (string-length s) 1)))))

(define (tmtex-wide? x)
  (cond ((func? x 'wide 1) (tmtex-wide? (cadr x)))
	((not (string? x)) #t)
	(else (not (tmtex-token? x)))))

(define (tmtex-wide l)
  (let ((wide (tmtex-wide? (car l))) (arg (tmtex (car l))) (acc (cadr l)))
    (cond ((not (string? acc)) arg)
	  ((equal? acc "<check>") (list 'check arg))
	  ((equal? acc "<vect>") (list 'vec arg))
	  ((equal? acc "<acute>") (list 'acute arg))
	  ((equal? acc "<grave>") (list 'grave arg))
	  ((equal? acc "~") (list (if wide 'widetilde 'tilde) arg))
	  ((equal? acc "^") (list (if wide 'widehat 'hat) arg))
	  (else arg))))

(define (tmtex-neg l)
  (tmtex-function 'not l))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-cell-make x)
  (if (func? x 'cell 1) (tmtex-cell-make (cadr x))
      (tmtex x)))

(define (tmtex-row-make x)
  (if (func? x 'tformat) (tmtex-row-make (carr x))
      (cons '!row (map-unary tmtex-cell-make (cdr x)))))

(define (tmtex-table-list l border)
  (let ((r (if (null? l) l
	       (cons (tmtex-row-make (car l))
		     (tmtex-table-list (cdr l) border)))))
    (if border (cons (list 'hline) r) r)))

(define (tmtex-table-make x border)
  (if (func? x 'tformat) (tmtex-table-make (carr x) border)
      (cons '!table (tmtex-table-list (cdr x) border))))

(define tmtex-table-border #f)
(define tmtex-table-halign #f)

(define (tmtex-table-set-halign j1 j2 val)
  (if (<= j1 j2)
      (begin
	(vector-set! tmtex-table-halign j1 val)
	(tmtex-table-set-halign (+ j1 1) j2 val))))

(define (tmtex-table-set-prop x)
  (if (and (func? x 'cwith 6) (equal? (cadr x) "1") (equal? (caddr x) "-1"))
      (let* ((J1 (string->number (cadr (cddr x))))
	     (J2 (string->number (caddr (cddr x))))
	     (n (vector-length tmtex-table-halign))
	     (j1 (cond ((< J1 0) (+ J1 n)) ((> J1 0) (- J1 1)) (else 0)))
	     (j2 (cond ((< J2 0) (+ J2 n)) ((> J2 0) (- J2 1)) (else 0)))
	     (var (cadr (cddddr x)))
	     (val (caddr (cddddr x))))
	(cond ((equal? var "cell halign")
	       (if (in? val '("l" "c" "r"))
		   (tmtex-table-set-halign (max 0 j1) (min j2 (- n 1)) val)))
	      ((in? var '("cell lborder" "cell rborder"
			  "cell tborder" "cell bborder"))
	       (set! tmtex-table-border #t))))))

(define (tmtex-table-args-list border l)
  (cons (if border "|" "")
	(if (null? l) l
	    (cons (car l) (tmtex-table-args-list border (cdr l))))))

(define (tmtex-table-args-sub l nrcols border halign)
  (set! tmtex-table-border border)
  (set! tmtex-table-halign (make-vector nrcols halign))
  (exec-unary tmtex-table-set-prop l)
  (list tmtex-table-border
	(apply string-append (tmtex-table-args-list
			      tmtex-table-border
			      (vector->list tmtex-table-halign)))))

(define (tmtex-nrcols-sub x)
  (if (func? x 'tformat) (tmtex-nrcols-sub (carr x)) (- (length x) 1)))

(define (tmtex-nrcols x)
  (if (func? x 'tformat) (tmtex-nrcols (carr x)) (tmtex-nrcols-sub (cadr x))))

(define (tmtex-table-args x border halign)
  (tmtex-table-args-sub
   (if (func? x 'tformat) (crdrdr x) '())
   (tmtex-nrcols x)
   border halign))

(define (tmtex-table-apply key x)
  (let* ((props (hash-ref tmtex-table-props key)))
    (if props
	(let* ((env (if (tmtex-math-mode?) 'array 'tabular))
	       (before (car props))
	       (after (caddr props))
	       (p (tmtex-table-args x (cadddr props) (cadr props)))
	       (border (car p))
	       (halign (cadr p))
	       (r (tmtex-table-make x border))
	       (e (list '!begin (symbol->string env) halign)))
	  (tex-concat (list before (list e r) after)))
	(list (list '!begin (symbol->string key))
	      (tmtex-table-make x #f)))))

(define (tmtex-tformat l)
  (tmtex-table-apply 'tabular (cons 'tformat l)))

(define (tmtex-table l)
  (tmtex-table-apply 'tabular (cons 'table l)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Local and global environment changes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-get-with-cmd var val)
  (hash-ref tex-with-cmd (list var val)))

(define (tmtex-get-assign-cmd var val)
  (if (equal? var "font size")
      (let ((x (* (string->number val) 10)))
	(cond ((< x 1) #f)
	      ((< x 5.5) 'tiny)
	      ((< x 6.5) 'scriptsize)
	      ((< x 7.5) 'footnotesize)
	      ((< x 9.5) 'small)
	      ((< x 11.5) 'normalsize)
	      ((< x 13.5) 'large)
	      ((< x 15.5) 'Large)
	      ((< x 18.5) 'LARGE)
	      ((< x 22.5) 'huge)
	      ((< x 50) 'Huge)
	      (else #f)))
      (hash-ref tex-assign-cmd (list var val))))

(define (tmtex-with-one var val arg)
  (if (equal? var "mode")
      (cond ((equal? val "text") (list 'text arg))
	    ((equal? val "math") (list '!math arg))
	    (else arg))
      (let ((w (tmtex-get-with-cmd var val))
	    (a (tmtex-get-assign-cmd var val)))
	(cond (w (list w arg))
	      (a (list '!group (tex-concat (list (list a) " " arg))))
	      (else arg)))))

(define (tmtex-with l)
  (if (null? l) ""
      (if (null? (cdr l)) (tmtex (car l))
	  (let ((var (force-string (car l)))
		(val (force-string (cadr l)))
		(next (cddr l)))
	    (tmtex-env-set var val)
	    (let ((r (tmtex-with-one var val (tmtex-with next))))
	      (tmtex-env-reset var)
	      r)))))

(define (tmtex-tex-arg l)
  (cons '!arg l))

(define (tmtex-args-search x args)
  (cond ((null? args) #f)
	((equal? x (car args)) 1)
	(else
	 (let ((n (tmtex-args-search x (cdr args))))
	   (if n (+ 1 n) #f)))))

(define (tmtex-args-sub l args)
  (if (null? l) l
      (cons (tmtex-args (car l) args)
	    (tmtex-args-sub (cdr l) args))))

(define (tmtex-args x args)
  (cond ((not (list? x)) x)
	((or (func? x 'arg) (func? x 'apply) (func? x 'value))
	 (let ((n (tmtex-args-search (cadr x) args)))
	   (if n (list '!arg (number->string n)) (tmtex-args-sub x args))))
	(else (tmtex-args-sub x args))))

(define (tmtex-assign l)
  (let ((var (car l)) (val (cadr l)))
    (if (string? var)
	(begin
	  (tmtex-env-assign var val)
	  (cond ((string? val)
		 (let ((a (tmtex-get-assign-cmd var val)))
		   (if a (list a)
		       (list 'newcommand (string-append "\\" var)
			     (tmtex val)))))
		((or (func? val 'macro) (func? val 'func))
		 (if (null? (cddr val))
		     (list 'newcommand (string-append "\\" var) (tmtex val))
		     (list 'newcommand (string-append "\\" var)
			   (list '!option (number->string (- (length val) 2)))
			   (tmtex (tmtex-args (carr val) (crdrdr val))))))
		(else (list 'newcommand (string-append "\\" var)
			    (tmtex val)))))
	"")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Other primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-label l)
  (list 'label (force-string (car l))))

(define (tmtex-reference l)
  (list 'ref (force-string (car l))))

(define (tmtex-pageref l)
  (list 'pageref (force-string (car l))))

(define (tmtex-specific l)
  (if (equal? (car l) "latex") (tmtex (cadr l)) ""))

(define (tmtex-hyperlink l)
  (tmtex-function 'tmhlink l))

(define (tmtex-action l)
  (tmtex-function 'tmaction l))

(define (tmtex-postscript l)
  (list 'epsfig (string-append "file=" (force-string (car l)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TeXmacs style primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-std-env s l)
  (list (list '!begin s) (tmtex (car l))))

(define (tmtex-title-extract-list l what)
  (if (null? l) #f
      (let ((x (tmtex-title-extract (car l) what)))
	(if x x (tmtex-title-extract-list (cdr l) what)))))

(define (tmtex-title-extract l what)
  (cond ((or (not (list? l)) (null? l)) #f)
	((func? l what) (cadr l))
	((and (func? l 'expand) (equal? (cadr l) (symbol->string what)))
	 (caddr l))
	(else (tmtex-title-extract-list l what))))

(define (tmtex-title-get x what)
  (let ((y (tmtex-title-extract x what)))
    (if y (list what (tmtex y)) "")))

(define (tmtex-make-title s l)
  (tex-concat (list (tmtex-title-get (car l) 'title)
		    (tmtex-title-get (car l) 'author)
		    (list 'maketitle))))

(define (tmtex-tt-document l)
  (cond ((null? l) "")
	((null? (cdr l)) (tmtex-tt (car l)))
	(else (string-append (tmtex-tt (car l)) "\n"
			     (tmtex-tt-document (cdr l))))))

(define (tmtex-tt x)
  (cond ((string? x) (tmtex-verb-string x))
	((equal? x '(format "next line")) "\n")
	((func? x 'document) (tmtex-tt-document (cdr x)))
	((func? x 'paragraph) (tmtex-tt-document (cdr x)))
	((func? x 'concat) (apply string-append (map-unary tmtex-tt (cdr x))))
	(else "")))

(define (tmtex-verbatim s l)
  (if (func? (car l) 'document)
      (list '!verbatim (tmtex-tt (car l)))
      (list '!verb (tmtex-tt (car l)))))

(define (tmtex-list-env s l)
  (let* ((r (string-replace s "-" ""))
	 (t (cond ((equal? r "enumerateRoman") "enumerateromancap")
		  ((equal? r "enumerateAlpha") "enumeratealphacap")
		  (else r))))
    (list (list '!begin t) (tmtex (car l)))))

(define (tmtex-equation s l)
  (tmtex-env-set "mode" "math")
  (let ((r (tmtex (car l))))
    (tmtex-env-reset "mode")
    (if (equal? s "equation")
	(list (list '!begin s) r)
	(list '!eqn r))))

(define (tmtex-eqnarray s l)
  (tmtex-env-set "mode" "math")
  (let ((r (tmtex-table-apply (string->symbol s) (car l))))
    (tmtex-env-reset "mode")
    r))

(define (tmtex-dummy s l)
  "")

(define (tmtex-toc s l)
  (tex-apply 'tableofcontents))

(define (tmtex-bib s l)
  (tex-concat (list (list 'bibliographystyle (force-string (cadr l)))
		    (list 'bibliography (force-string (caddr l))))))

(define (tmtex-figure s l)
  (tmtex-float-sub "H" (cons (string->symbol s) l)))

(define (tmtex-item s l)
  (tex-concat (list (list 'item) " ")))

(define (tmtex-item-arg s l)
  (tex-concat (list (list 'item (list '!option (tmtex (car l)))) " ")))

(define (tmtex-session s l)
  (tmtex (caddr l)))

(define (tmtex-input s l)
  (let ((prompt (car l)) (x (cadr l)))
    (tex-concat
     (list `(!group (!concat (red) (ttfamily ,(tmtex prompt))))
	   (if (and (func? x 'var_expand 2) (equal? (cadr x) "math"))
	       (begin
		 (tmtex-env-set "mode" "math")
		 (let ((r (tmtex (caddr x))))
		   (tmtex-env-reset "mode")
		   `(!math (!group (!concat (blue) ,r)))))
	       `(!group (!concat (blue) (!verb ,(tmtex-tt x)))))))))

(define (tmtex-output s l)
  (list '!group (list 'ttfamily (tmtex (car l)))))

(define (tmtex-cite-list l)
  (cond ((null? l) "")
	((not (string? (car l))) (tmtex-cite-list (cdr l)))
	((null? (cdr l)) (car l))
	(else (string-append (car l) ", " (tmtex-cite-list (cdr l))))))

(define (tmtex-cite s l)
  (tex-apply (string->symbol s) (tmtex-cite-list l)))

(define (tmtex-choose s l)
  (list 'binom (tmtex (car l)) (tmtex (cadr l))))

(define (tmtex-modifier s l)
  (tex-apply (string->symbol (string-append "tm" s)) (tmtex (car l))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The main conversion routines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tmtex-apply key args)
  (let ((n (length args))
	(r (hash-ref tmtex-methods key)))
    (if r ((eval r) args)
	(let ((p (hash-ref tmtex-tmstyle key)))
	  (if (and p (or (= (cadr p) -1) (= (cadr p) n)))
	      ((eval (car p)) (symbol->string key) args)
	      (if (and (= n 1)
		       (or (func? (car args) 'tformat)
			   (func? (car args) 'table)))
		  (tmtex-table-apply key (car args))
		  (tmtex-function key args)))))))

(define (tmtex-function f l)
  (if (equal? (string-ref (symbol->string f) 0) #\!)
      (cons f (map-unary tmtex l))
      (apply tex-apply (cons f (map-unary tmtex l)))))

(define (tmtex-expand l)
  (tmtex-apply (string->symbol (car l)) (cdr l)))

(define (tmtex-list l)
  (map-unary tmtex l))

(define (tmtex x)
  (if (string? x)
      (if (tmtex-math-mode?)
	  (tmtex-math-string x)
	  (tmtex-text-string x))
      (tmtex-apply (car x) (cdr x))))

(define (tmtex-produce x)
  (tmtex-initialize)
  (texout-produce (tmtex (tmpre-produce x))))
