;;;;
;;;;  LaTeX stylesheet
;;;; 

(define nl (list->string (list #\newline)))

; Given a string, check to make sure it does not contain characters
; such as '_' or '&' that require encoding. Return either the original
; string, or a list of string fragments with special characters
; replaced by appropriate "escape sequences"

(define string->goodTeX
  (make-char-quotator
   '((#\# . "\\#") (#\$ . "\\$") (#\% . "\\%") (#\& . "\\&")
     (#\~ . "\\textasciitilde{}") (#\_ . "\\_") (#\^ . "\\^")
     (#\\ . "$\\backslash$") (#\{ . "\\{") (#\} . "\\}"))))

(define string->goodTeX-in-verbatim
  (make-char-quotator
   '((#\space "~")	; All spaces are "hard"
     (#\# . "\\#") (#\$ . "\\$") (#\% . "\\%")
     (#\& . "\\&") (#\~ . "\\textasciitilde{}")
     (#\_ . "\\_") (#\^ . "\\^")
     (#\\ . "$\\backslash$") (#\{ . "\\{")
     (#\} . "\\}"))))

(define LaTeX-packages
  (make-parameter (list)))

(define (LaTeX-add-package! package-name . options)
  (let ((packages (LaTeX-packages)))
    (if (not (assoc package-name packages))
	(LaTeX-packages (cons (list package-name options)
			      packages)))))

;;
;; Place the 'body' within the LaTeX environment named 'env-name'
;; options is a string or a list of strings that specify optional or
;; mandatory parameters for the environment
;; Return the list of fragments.
;;
(define (in-LaTeX-env env-name options body)
  (list "\\begin{" env-name "}" options nl
	body
	"\\end{" env-name "}" nl))

(define (LaTeX-use-package package-name . options)
  (list "\\usepackage"
	(if (pair? options) (list "[" options "]") '()) 
	"{" package-name "}" 
	nl))

(define (LaTeX-label str)
  (define (f0 str)
    (let* ((cs   (string-split str " "))
	   (ins  (map (lambda (s) 
			(let ((s (string-downcase s)))
			  (string-copy s 0 (min 3 (- (string-length s) 1))))) cs)))
      (string-concatenate ins)))
  (cond ((pair? str)   (string-concatenate (map f0 str)))
	(else          (f0 (->string str)))))


(define (LaTeX-transformation-rules content)
  `((
    (@ . ,(lambda (trigger value) (cons '@ value)))

     (*default* . ,(lambda (tag elems) (cons tag elems)))

     (*text* . ,(lambda (trigger str) 
		  (if (string? str) (string->goodTeX str) str)))

     (n_		; a non-breaking space
      . ,(lambda (tag elems)
	   (list "~" elems)))

     (Header		
      *preorder*
      . ,(lambda (tag elems) '()))

     (section	; (section level head-word . contents)
      . ,(lambda (tag elems)
	   (let* ((level (car elems))
		  (head-word (cadr elems))
                  (contents (cddr elems)))
	    (cond ((and (integer? level) head-word)
		    `(#\\
                      ,(case level
                         ((2) "section")
                         ((3) "subsection*") ;; No nesting?
                         ((4) "subsubsection*")
                         ((5) "paragraph")
                         ((6) "subparagraph")
                         (else (error "unsupported section level: " level)))
                      "{" ,head-word "}"  ,nl
                      ,(if (= level 1) 
                           (list "\\label{" (LaTeX-label head-word)  "}") 
                           (list)) ,nl . ,contents))
		  (else
		   (error 'latex-transformation-rules
			  "section elements must be of the form (Section level head-word)")))
	     )))


     (toc . ,(lambda (tag elems) (list nl "\\tableofcontents{}" nl)))

     (body
      . ,(lambda (tag elems)
	   (in-LaTeX-env "document" '() 
			 (list elems)
			 )))

     (link
      . ,(lambda (tag elems)
           (LaTeX-add-package! 'url)
           (list "\\url{" (car elems) "}")))

     ; Standard typography
     (small
      . ,(lambda (tag elems)
	   (list "{\\small{}" elems "}")))

     (strong
      . ,(lambda (tag elems)
	   (list "{\\rmfamily\\bfseries{}" elems "}")))

     (tt
      . ,(lambda (tag elems)
	   (list "{\\ttfamily{}" elems "}")))

     (em
      . ,(lambda (tag elems)
	   (list "\\emph{" elems "}")))

     (p
      . ,(lambda (tag elems)
	   (list elems nl nl)))

     (div
      . ,(lambda (tag elems)
	   (list elems nl)))

     (br
      . ,(lambda (tag elems)
	   (list "\\\\ ")))

     (hr . ,(lambda (tag elems) 
	      (list "\\begin{center}" 
		    "\\rule{0.8\\textwidth}{0.4pt}" 
		    "\\end{center}" nl)))

     (indent 
      . ,(lambda (tag elems) "\\indent{}"))

     (ul			; Unnumbered lists
      . ,(lambda (tag elems)
	   (in-LaTeX-env "itemize" '() elems)))

     (ol			; Numbered lists
      . ,(lambda (tag elems)
	   (in-LaTeX-env "enumerate" '() elems)))

     (li
      . ,(lambda (tag elems)
	   (list "\\item " elems nl)))

     (dl			; Definition list

      ;; dl and dt are translated to procedures that take one argument:
      ;; previously set label: list of fragments or #f if none
      ;; The procedure returns a pair: (new-label . generate-fragments)
      ;; Initially, label is #f

      ((dt			;; The item title
	. ,(lambda (tag elems)
	    (lambda (label)
	      (cons elems	;; elems become the new label
		    (if label	;; the label was set: we've seen dt without dd
			(list "\\item [" label "]" nl) ; empty body
			'())))))
       (dd			;; The item body
	. ,(lambda (tag elems)
	    (lambda (label)
	      (cons #f		;; consume the existing label
		    (list "\\item [" (or label "") "] " elems nl)))))
       )
      . ,(lambda (tag procs)	;; execute procs generated by dt/dd
	  (let loop ((procs (flatten procs)) (label #f) (accum '()))
	    (if (null? procs) (in-LaTeX-env "description" '() (reverse accum))
		(let ((result ((car procs) label)))
		  (loop (cdr procs) (car result) (cons (cdr result) accum))))))
      )
	
     (def
       ((sig . ,(lambda (tag types)
                  (map (lambda (spec)
                         (in-LaTeX-env
                          "description" '()
                          (list  "\\item[" (car spec) "] {\\ttfamily{}"
                                 (cdr spec) "}")))
                       types))))
       . ,(lambda (tag elems) elems))

     (blockquote
      . ,(lambda (tag elems)
	   (in-LaTeX-env "quote" '() elems)))

     (pre
      *macro*
      . ,(lambda (tag elems)
           `(verbatim . ,elems)))
     
     (verbatim	; set off pieces of code: one or several lines
      ((*text* . ; Different quotation rules apply within a "verbatim" block
	       ,(lambda (trigger str) 
		  (if (string? str) (string->goodTeX-in-verbatim str) str)))
	       
	(strong
	  . ,(lambda (tag elems)
	       (list "\\textrm{\\small\\bfseries{}" elems "}")))
	)
      . ,(lambda (tag lines)
	   (in-LaTeX-env "lyxcode" '()
		       (map (lambda (line) 
			      (if (or (pair? line) (string? line))
                                  line
				  (list (if (equal? line "") "~" line) 
					"\\\\" nl)))
			    lines))))

     (table
      ((@
	((*default* . ,(lambda (tag value)
			 (cons tag value))))
	. ,(lambda (tag elems) (cons tag elems))))
      ;; (table [(@ attrib ...)] tr ...
      . ,(lambda (tag elems)
	   (let*-values
	    (((attrs rows) (if (and (pair? elems) 
				    (pair? (car elems))
				    (eq? '@ (caar elems)))
			       (values (cdar elems) (cdr elems))
			       (values '() elems)))
	     ((border?)
	      (cond
	       ((assq 'border attrs) => 
		(lambda (border-attr) (not (equal? "0" (cadr border-attr)))))
	       (else #f)))

	     ((caption label table-type table-alignment)
	      (apply values
		     (map (lambda (name)
			    (cond
			     ((assq name attrs) => cadr)
			     (else #f)))
			  '(caption key table-type align))))

	     (dummy (assert (pair? rows))) ; at least one row must be given

	     ((ncols) (length (car rows)))
	     ((tex-cols)
	      (let* ((verbatim? 
		      (lambda (r) 
			(pre-post-order* r
			  `(
			    (verbatim
			     . ,(lambda (tag elems) elems))
			    
			    (*default*
			     . ,(lambda (tag elems) elems))
			    
			    (*text* . ,(lambda (trigger str) (list))))
			  )))

		     (col-codes (map (lambda (r) (if (verbatim? r) "p" "l")) (car rows)))

		     (col-codes (if border? 
				    (intersperse (flatten (list "" col-codes "")) "|") 
				    col-codes)))
		(apply string-append col-codes)))
	     )
	    (list
	      (list
	       (and (equal? table-alignment "center")
		    "\\centering")
	       (in-LaTeX-env "tabular" (list "{" tex-cols "}")
		(list (and border? "\\hline\n")
		  (map
		   (lambda (row)
		     (and (pair? row)
			  (print "row = " row)
			  (let ((row-content
				 (pre-post-order*
				  row
				  `(
				    
				    (tr *macro*
					. ,(lambda (tag elems) 
					     (list "{" elems "}")))
				    
				    (td *macro*
					. ,(lambda (tag elems) 
					     (let ((maybe-attrs (car elems)))
					       (let ((alignment (alist-ref 'align maybe-attrs)))
						 (if alignment
						     (list "{" (cdr elems) "}")
						     (list "{" elems "}"))))))
				    
				    
				    (th *macro*
				     . ,(lambda (tag elems) 
					  (list "{" elems "}")))
				    
				    (*text* . ,(lambda (trigger str) str))

				    ;;(@ *preorder* . ,(lambda (attr-key value) (cons attr-key value)))
				    
				    ;;(*default* . ,(lambda (tag elems) (print "tag = " tag) (cons tag elems)))
				    
				    
				    ))))

				 (list (intersperse row-content " & ")
				       "\\\\" (and border? "\\hline") nl))))
			  rows)
		     nl))
		  ))
	       )))
	   

     (tex      ; raw tex expression
       *preorder*
       . ,(lambda (tag str) str))
	    
     )))