suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

improve latex generation (complex proc specs now readable)

Browse Source 
svn: r6812

original commit: a0bc09e232d595a461d5b088927dfda970569f1a
This commit is contained in:
Matthew Flatt 2007-07-03 21:12:36 +00:00
parent 3eb059df5a
commit edb25384b7
1 changed files with 84 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

147
collects/scribble/latex-render.ss
View File

@ -4,7 +4,7 @@
(lib "class.ss")) (lib "class.ss"))
(provide render-mixin) (provide render-mixin)
(define current-table-depth (make-parameter 0)) (define current-table-mode (make-parameter #f))
(define rendering-tt (make-parameter #f)) (define rendering-tt (make-parameter #f))
(define-struct (toc-paragraph paragraph) ()) (define-struct (toc-paragraph paragraph) ())
@ -21,7 +21,7 @@
lookup) lookup)
(define (define-color s s2) (define (define-color s s2)
(printf "\\newcommand{\\~a}[1]{{\\texttt{\\color{~a}{#1}}}}\n" s s2)) (printf "\\newcommand{\\~a}[1]{{\\mytexttt{\\color{~a}{#1}}}}\n" s s2))
(define/override (render-one d ht fn) (define/override (render-one d ht fn)
(printf "\\documentclass{article}\n") (printf "\\documentclass{article}\n")
@ -34,8 +34,9 @@
(printf "\\usepackage{longtable}\n") (printf "\\usepackage{longtable}\n")
(printf "\\usepackage[usenames,dvipsnames]{color}\n") (printf "\\usepackage[usenames,dvipsnames]{color}\n")
(printf "\\hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true}\n") (printf "\\hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true}\n")
(printf "\\newcommand{\\mytexttt}[1]{{\\small \\texttt{#1}}}\n")
(define-color "schemeplain" "black") (define-color "schemeplain" "black")
(printf "\\newcommand{\\schemekeyword}[1]{{\\color{black}{\\texttt{\\textbf{#1}}}}}\n") (printf "\\newcommand{\\schemekeyword}[1]{{\\color{black}{\\mytexttt{\\textbf{#1}}}}}\n")
(printf "\\newcommand{\\schemesyntaxlink}[1]{\\schemekeyword{#1}}\n") (printf "\\newcommand{\\schemesyntaxlink}[1]{\\schemekeyword{#1}}\n")
(printf "\\definecolor{CommentColor}{rgb}{0.76,0.45,0.12}\n") (printf "\\definecolor{CommentColor}{rgb}{0.76,0.45,0.12}\n")
(printf "\\definecolor{ParenColor}{rgb}{0.52,0.24,0.14}\n") (printf "\\definecolor{ParenColor}{rgb}{0.52,0.24,0.14}\n")
@ -141,7 +142,7 @@
(case style (case style
[(italic) (wrap e "textit" #f)] [(italic) (wrap e "textit" #f)]
[(bold) (wrap e "textbf" #f)] [(bold) (wrap e "textbf" #f)]
[(tt) (wrap e "texttt" #t)] [(tt) (wrap e "mytexttt" #t)]
[(sf) (wrap e "textsf" #f)] [(sf) (wrap e "textsf" #f)]
[(subscript) (wrap e "textsub" #f)] [(subscript) (wrap e "textsub" #f)]
[(superscript) (wrap e "textsuper" #f)] [(superscript) (wrap e "textsuper" #f)]
@ -149,7 +150,7 @@
(case (string-length s) (case (string-length s)
[(0) (void)] [(0) (void)]
[else [else
(printf "{\\texttt{~a}}" (printf "{\\mytexttt{~a}}"
(regexp-replace* #rx"." s "~"))]))] (regexp-replace* #rx"." s "~"))]))]
[else (error 'latex-render "unrecognzied style symbol: ~s" style)])] [else (error 'latex-render "unrecognzied style symbol: ~s" style)])]
[(string? style) [(string? style)
@ -165,70 +166,90 @@
(define/override (render-table t part ht) (define/override (render-table t part ht)
(let* ([boxed? (eq? 'boxed (table-style t))] (let* ([boxed? (eq? 'boxed (table-style t))]
[index? (eq? 'index (table-style t))] [index? (eq? 'index (table-style t))]
[inline? (and (not boxed?)
(not index?)
(or (null? (table-flowss t))
(= 1 (length (car (table-flowss t)))))
(let ([m (current-table-mode)])
(and m
(equal? "longtable" (car m))
(= 1 (length (car (table-flowss (cadr m))))))))]
[tableform (cond [tableform (cond
[index? "theindex"] [index? "theindex"]
[(zero? (current-table-depth)) [(not (current-table-mode))
"longtable"] "longtable"]
[else "tabular"])] [else "tabular"])]
[opt (if (zero? (current-table-depth)) [opt (cond
"[l]" [(equal? tableform "longtable") "[l]"]
"")]) [(equal? tableform "tabular") "[t]"]
[else ""])])
(unless (or (null? (table-flowss t)) (unless (or (null? (table-flowss t))
(null? (car (table-flowss t)))) (null? (car (table-flowss t))))
(parameterize ([current-table-depth (add1 (current-table-depth))]) (parameterize ([current-table-mode (if inline?
(if index? (current-table-mode)
(printf "\n\n\\begin{theindex}\n") (list tableform t))])
(printf "\n\n~a\\begin{~a}~a{@{}~a}\n" (cond
(if boxed? [index?
(format "{~a\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}~a\n\\nopagebreak\n" (printf "\n\n\\begin{theindex}\n")]
"\\setlength{\\unitlength}{\\linewidth}" [inline? (void)]
(if (equal? tableform "longtable") [else
"\\vspace{-5ex}" (printf "\n\n~a\\begin{~a}~a{@{}~a}\n"
"\n\n")) (if boxed?
"") (format "{~a\\begin{picture}(1,0)\\put(0,0){\\line(1,0){1}}\\end{picture}}~a\n\\nopagebreak\n"
tableform "\\setlength{\\unitlength}{\\linewidth}"
opt (if (equal? tableform "longtable")
(apply string-append "\\vspace{-5ex}"
(map (lambda (i align) "~a@{}" "\n\n"))
"")
tableform
opt
(apply string-append
(map (lambda (i align)
(format "~a@{}"
(case align (case align
[(center) "c"] [(center) "c"]
[(right) "r"] [(right) "r"]
[else "l"])) [else "l"])))
(car (table-flowss t)) (car (table-flowss t))
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'alignment (or (table-style t) null))) (assoc 'alignment (or (table-style t) null)))
(cons #f (map (lambda (x) #f) (car (table-flowss t)))))))))) (cons #f (map (lambda (x) #f) (car (table-flowss t)))))))))])
(for-each (lambda (flows row-style) (let loop ([flowss (table-flowss t)]
(let loop ([flows flows]) [row-styles (cdr (or (and (list? (table-style t))
(unless (null? flows) (assoc 'row-styles (table-style t)))
(unless (eq? 'cont (car flows)) (cons #f (map (lambda (x) #f) (table-flowss t)))))])
(let ([cnt (let loop ([flows (cdr flows)][n 1]) (let ([flows (car flowss)]
(cond [row-style (car row-styles)])
[(null? flows) n] (let loop ([flows flows])
[(eq? (car flows) 'cont) (loop (cdr flows) (add1 n))] (unless (null? flows)
[else n]))]) (unless (eq? 'cont (car flows))
(unless (= cnt 1) (let ([cnt (let loop ([flows (cdr flows)][n 1])
(printf "\\multicolumn{~a}{l}{" cnt)) (cond
(render-flow (car flows) part ht) [(null? flows) n]
(unless (= cnt 1) [(eq? (car flows) 'cont) (loop (cdr flows) (add1 n))]
(printf "}")) [else n]))])
(unless (null? (list-tail flows cnt)) (unless (= cnt 1)
(printf " &\n")))) (printf "\\multicolumn{~a}{l}{" cnt))
(unless (null? (cdr flows)) (render-flow (car flows) part ht)
(loop (cdr flows))))) (unless (= cnt 1)
(unless index? (printf "}"))
(printf " \\\\\n") (unless (null? (list-tail flows cnt))
(when (equal? row-style "inferencetop") (printf " &\n"))))
(printf "\\hline\n")))) (unless (null? (cdr flows))
(table-flowss t) (loop (cdr flows)))))
(cdr (or (and (list? (table-style t)) (unless (or index?
(assoc 'row-styles (table-style t))) (null? (cdr flowss)))
(cons #f (map (lambda (x) #f) (table-flowss t)))))) (printf " \\\\\n")
(printf "\n\n\\end{~a}~a\n" (when (equal? row-style "inferencetop")
tableform (printf "\\hline\n")))
(if (equal? tableform "longtable") (unless (null? (cdr flowss))
"\\vspace{-3ex}" ;; counteracts mysterious space added after longtable (loop (cdr flowss) (cdr row-styles)))))
""))))) (unless inline?
(printf "\n\n\\end{~a}~a\n"
tableform
(if (equal? tableform "longtable")
"\\vspace{-3ex}" ;; counteracts mysterious space added after longtable
""))))))
null) null)
(define/override (render-itemization t part ht) (define/override (render-itemization t part ht)
@ -242,7 +263,7 @@
(define/override (render-blockquote t part ht) (define/override (render-blockquote t part ht)
(printf "\n\n\\begin{quote}\n") (printf "\n\n\\begin{quote}\n")
(parameterize ([current-table-depth (add1 (current-table-depth))]) (parameterize ([current-table-mode (list "blockquote" t)])
(for-each (lambda (e) (for-each (lambda (e)
(render-flow-element e part ht)) (render-flow-element e part ht))
(blockquote-paragraphs t))) (blockquote-paragraphs t)))