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

removed some for-syntax requires that are no longer needed for runtime-path

Browse Source 
svn: r10100

original commit: 364c048008eab69895c8a593f51dfd947e0b6fa1
This commit is contained in:
Eli Barzilay 2008-06-03 00:02:59 +00:00
parent 7f97a4f018
commit 13cda846d0
1 changed files with 331 additions and 373 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,11 +1,11 @@
#lang scheme/base
(module latex-render scheme/base
(require "struct.ss" (require "struct.ss"
mzlib/class mzlib/class
scheme/runtime-path scheme/runtime-path
scheme/port scheme/port
setup/main-collects scheme/string
(for-syntax scheme/base)) setup/main-collects)
(provide render-mixin) (provide render-mixin)
(define current-table-mode (make-parameter #f)) (define current-table-mode (make-parameter #f))
@ -30,46 +30,36 @@
format-number) format-number)
(define/override (render-one d ri fn) (define/override (render-one d ri fn)
(let ([style-file (or style-file (let ([style-file (or style-file scribble-tex)])
scribble-tex)])
(with-input-from-file style-file (with-input-from-file style-file
(lambda () (lambda ()
(copy-port (current-input-port) (copy-port (current-input-port) (current-output-port))))
(current-output-port))))
(printf "\\begin{document}\n\\preDoc\n") (printf "\\begin{document}\n\\preDoc\n")
(when (part-title-content d) (when (part-title-content d)
(printf "\\titleAndVersion{") (printf "\\titleAndVersion{")
(render-content (part-title-content d) d ri) (render-content (part-title-content d) d ri)
(printf "}{~a}\n" (printf "}{~a}\n"
(or (and (versioned-part? d) (or (and (versioned-part? d) (versioned-part-version d))
(versioned-part-version d))
(version)))) (version))))
(render-part d ri) (render-part d ri)
(printf "\\postDoc\n\\end{document}\n"))) (printf "\\postDoc\n\\end{document}\n")))
(define/override (render-part d ri) (define/override (render-part d ri)
(let ([number (collected-info-number (part-collected-info d ri))]) (let ([number (collected-info-number (part-collected-info d ri))])
(when (and (part-title-content d) (when (and (part-title-content d) (pair? number))
(pair? number))
(when (part-style? d 'index) (when (part-style? d 'index)
(printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n")) (printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n"))
(let ([no-number? (and (pair? number) (let ([no-number? (and (pair? number) (not (car number)))])
(not (car number)))])
(printf "\\~a~a~a" (printf "\\~a~a~a"
(case (length number) (case (length number)
[(0 1) "sectionNewpage\n\n\\section"] [(0 1) "sectionNewpage\n\n\\section"]
[(2) "subsection"] [(2) "subsection"]
[(3) "subsubsection"] [(3) "subsubsection"]
[else "subsubsection*"]) [else "subsubsection*"])
(if (and (part-style? d 'hidden) (if (and (part-style? d 'hidden) (not no-number?))
(not no-number?)) "hidden" "")
"hidden" (if no-number? "*" ""))
"") (when (not (or (part-style? d 'hidden) no-number?))
(if no-number?
"*"
""))
(when (not (or (part-style? d 'hidden)
no-number?))
(printf "[") (printf "[")
(parameterize ([disable-images #t]) (parameterize ([disable-images #t])
(render-content (part-title-content d) d ri)) (render-content (part-title-content d) d ri))
@ -77,16 +67,12 @@
(printf "{") (printf "{")
(render-content (part-title-content d) d ri) (render-content (part-title-content d) d ri)
(printf "}") (printf "}")
(when (part-style? d 'index) (when (part-style? d 'index) (printf "\n\n")))
(printf "\n\n"))) (for ([t (part-tags d)])
(for-each (lambda (t)
(printf "\\label{t:~a}" (t-encode (tag-key t ri)))) (printf "\\label{t:~a}" (t-encode (tag-key t ri))))
(part-tags d))
(render-flow (part-flow d) d ri #f) (render-flow (part-flow d) d ri #f)
(for-each (lambda (sec) (render-part sec ri)) (for ([sec (part-parts d)]) (render-part sec ri))
(part-parts d)) (when (part-style? d 'index) (printf "\\onecolumn\n\n"))
(when (part-style? d 'index)
(printf "\\onecolumn\n\n"))
null)) null))
(define/override (render-paragraph p part ri) (define/override (render-paragraph p part ri)
@ -98,8 +84,7 @@
(if (toc-paragraph? p) (if (toc-paragraph? p)
(printf "\\newpage \\tableofcontents \\newpage") (printf "\\newpage \\tableofcontents \\newpage")
(super render-paragraph p part ri)) (super render-paragraph p part ri))
(when margin? (when margin? (printf "}")))
(printf "}")))
(printf "\n\n") (printf "\n\n")
null) null)
@ -110,33 +95,31 @@
(null? (element-content e)))]) (null? (element-content e)))])
(parameterize ([show-link-page-numbers #f]) (parameterize ([show-link-page-numbers #f])
(when (target-element? e) (when (target-element? e)
(printf "\\label{t:~a}" (t-encode (tag-key (target-element-tag e) ri)))) (printf "\\label{t:~a}"
(t-encode (tag-key (target-element-tag e) ri))))
(when part-label? (when part-label?
(printf "\\S") (printf "\\S")
(render-content (let ([dest (resolve-get part ri (link-element-tag e))]) (render-content
(let ([dest (resolve-get part ri (link-element-tag e))])
(if dest (if dest
(if (list? (cadr dest)) (if (list? (cadr dest))
(format-number (cadr dest) null) (format-number (cadr dest) null)
(begin (begin (fprintf (current-error-port)
(fprintf (current-error-port)
"Internal tag error: ~s -> ~s\n" "Internal tag error: ~s -> ~s\n"
(link-element-tag e) (link-element-tag e)
dest) dest)
'("!!!"))) '("!!!")))
(list "???"))) (list "???")))
part part ri)
ri)
(printf " ``")) (printf " ``"))
(let ([style (and (element? e) (let ([style (and (element? e)
(let ([s (flatten-style (let ([s (flatten-style (element-style e))])
(element-style e))])
(if (with-attributes? s) (if (with-attributes? s)
(with-attributes-style s) (with-attributes-style s)
s)))] s)))]
[wrap (lambda (e s tt?) [wrap (lambda (e s tt?)
(printf "{\\~a{" s) (printf "{\\~a{" s)
(parameterize ([rendering-tt (or tt? (parameterize ([rendering-tt (or tt? (rendering-tt))])
(rendering-tt))])
(super render-element e part ri)) (super render-element e part ri))
(printf "}}"))]) (printf "}}"))])
(cond (cond
@ -149,26 +132,24 @@
[(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)]
[(hspace) (let ([s (content->string (element-content e))]) [(hspace)
(let ([s (content->string (element-content e))])
(case (string-length s) (case (string-length s)
[(0) (void)] [(0) (void)]
[else [else
(printf "\\mbox{\\hphantom{\\mytexttt{~a}}}" (printf "\\mbox{\\hphantom{\\mytexttt{~a}}}"
(regexp-replace* #rx"." s "x"))]))] (regexp-replace* #rx"." s "x"))]))]
[(newline) (printf "\\\\")] [(newline) (printf "\\\\")]
[else (error 'latex-render "unrecognzied style symbol: ~s" style)])] [else (error 'latex-render
"unrecognzied style symbol: ~s" style)])]
[(string? style) [(string? style)
(wrap e style (regexp-match? #px"^scheme(?!error)" style))] (wrap e style (regexp-match? #px"^scheme(?!error)" style))]
[(and (pair? style) [(and (pair? style) (memq (car style) '(bg-color color)))
(or (eq? (car style) 'bg-color) (wrap e (format
(eq? (car style) 'color))) "~a{~a}"
(wrap e (format "~a{~a}"
(format (if (eq? (car style) 'bg-color) (format (if (eq? (car style) 'bg-color)
"in~acolorbox" "in~acolorbox" "intext~acolor")
"intext~acolor") (if (= (length style) 2) "" "rgb"))
(if (= (length style) 2)
""
"rgb"))
(if (= (length style) 2) (if (= (length style) 2)
(cadr style) (cadr style)
(format "~a,~a,~a" (format "~a,~a,~a"
@ -182,60 +163,53 @@
(let ([fn (install-file (let ([fn (install-file
(main-collects-relative->path (main-collects-relative->path
(image-file-path style)))]) (image-file-path style)))])
(printf "\\includegraphics[scale=~a]{~a}" (image-file-scale style) fn)))] (printf "\\includegraphics[scale=~a]{~a}"
(image-file-scale style) fn)))]
[else (super render-element e part ri)]))) [else (super render-element e part ri)])))
(when part-label? (when part-label?
(printf "''")) (printf "''"))
(when (and (link-element? e) (when (and (link-element? e)
(show-link-page-numbers)) (show-link-page-numbers))
(printf ", \\pageref{t:~a}" (t-encode (tag-key (link-element-tag e) ri)))) (printf ", \\pageref{t:~a}"
(t-encode (tag-key (link-element-tag e) ri))))
null)) null))
(define/private (t-encode s) (define/private (t-encode s)
(apply (string-append*
string-append
(map (lambda (c) (map (lambda (c)
(cond (cond
[(and (or (char-alphabetic? c) [(and (or (char-alphabetic? c) (char-numeric? c))
(char-numeric? c))
((char->integer c) . < . 128)) ((char->integer c) . < . 128))
(string c)] (string c)]
[(char=? c #\space) "_"] [(char=? c #\space) "_"]
[else [else (format "x~x" (char->integer c))]))
(format "x~x" (char->integer c))]))
(string->list (format "~s" s))))) (string->list (format "~s" s)))))
(define/override (render-table t part ri inline-table?) (define/override (render-table t part ri inline-table?)
(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?) [inline?
(not index?) (and (not boxed?) (not index?)
(or (null? (table-flowss t)) (or (null? (table-flowss t))
(= 1 (length (car (table-flowss t))))) (= 1 (length (car (table-flowss t)))))
(let ([m (current-table-mode)]) (let ([m (current-table-mode)])
(and m (and m
(equal? "bigtabular" (car m)) (equal? "bigtabular" (car m))
(= 1 (length (car (table-flowss (cadr m))))))))] (= 1 (length (car (table-flowss (cadr m))))))))]
[tableform (cond [tableform
[index? "list"] (cond [index? "list"]
[(and (not (current-table-mode)) [(and (not (current-table-mode)) (not inline-table?))
(not inline-table?))
"bigtabular"] "bigtabular"]
[else "tabular"])] [else "tabular"])]
[opt (cond [opt (cond [(equal? tableform "bigtabular") "[l]"]
[(equal? tableform "bigtabular") "[l]"]
[(equal? tableform "tabular") "[t]"] [(equal? tableform "tabular") "[t]"]
[else ""])] [else ""])]
[flowss (if index? [flowss (if index? (cddr (table-flowss t)) (table-flowss t))])
(cddr (table-flowss t)) (unless (or (null? flowss) (null? (car flowss)))
(table-flowss t))]) (parameterize ([current-table-mode
(unless (or (null? flowss) (if inline? (current-table-mode) (list tableform t))]
(null? (car flowss))) [show-link-page-numbers
(parameterize ([current-table-mode (if inline? (or index? (show-link-page-numbers))])
(current-table-mode)
(list tableform t))]
[show-link-page-numbers (or index?
(show-link-page-numbers))])
(cond (cond
[index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")] [index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")]
[inline? (void)] [inline? (void)]
@ -250,7 +224,7 @@
"") "")
tableform tableform
opt opt
(apply string-append (string-append*
(map (lambda (i align) (map (lambda (i align)
(format "~a@{}" (format "~a@{}"
(case align (case align
@ -259,73 +233,63 @@
[else "l"]))) [else "l"])))
(car flowss) (car flowss)
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'alignment (or (table-style t) null))) (assoc 'alignment
(cons #f (map (lambda (x) #f) (car flowss))))))))]) (or (table-style t) null)))
(cons #f (map (lambda (x) #f)
(car flowss))))))))])
(let loop ([flowss flowss] (let loop ([flowss flowss]
[row-styles (cdr (or (and (list? (table-style t)) [row-styles
(cdr (or (and (list? (table-style t))
(assoc 'row-styles (table-style t))) (assoc 'row-styles (table-style t)))
(cons #f (map (lambda (x) #f) flowss))))]) (cons #f (map (lambda (x) #f) flowss))))])
(let ([flows (car flowss)] (let ([flows (car flowss)]
[row-style (car row-styles)]) [row-style (car row-styles)])
(let loop ([flows flows]) (let loop ([flows flows])
(unless (null? flows) (unless (null? flows)
(when index? (when index? (printf "\\item "))
(printf "\\item "))
(unless (eq? 'cont (car flows)) (unless (eq? 'cont (car flows))
(let ([cnt (let loop ([flows (cdr flows)][n 1]) (let ([cnt (let loop ([flows (cdr flows)][n 1])
(cond (cond [(null? flows) n]
[(null? flows) n] [(eq? (car flows) 'cont)
[(eq? (car flows) 'cont) (loop (cdr flows) (add1 n))] (loop (cdr flows) (add1 n))]
[else n]))]) [else n]))])
(unless (= cnt 1) (unless (= cnt 1) (printf "\\multicolumn{~a}{l}{" cnt))
(printf "\\multicolumn{~a}{l}{" cnt))
(render-flow (car flows) part ri #f) (render-flow (car flows) part ri #f)
(unless (= cnt 1) (unless (= cnt 1) (printf "}"))
(printf "}")) (unless (null? (list-tail flows cnt)) (printf " &\n"))))
(unless (null? (list-tail flows cnt)) (unless (null? (cdr flows)) (loop (cdr flows)))))
(printf " &\n")))) (unless (or index? (null? (cdr flowss)))
(unless (null? (cdr flows))
(loop (cdr flows)))))
(unless (or index?
(null? (cdr flowss)))
(printf " \\\\\n") (printf " \\\\\n")
(when (equal? row-style "inferencetop") (when (equal? row-style "inferencetop") (printf "\\hline\n")))
(printf "\\hline\n")))
(unless (null? (cdr flowss)) (unless (null? (cdr flowss))
(loop (cdr flowss) (cdr row-styles))))) (loop (cdr flowss) (cdr row-styles)))))
(unless inline? (unless inline?
(printf "~a\n\n\\end{~a}\n" (printf "~a\n\n\\end{~a}\n"
(if (equal? tableform "bigtabular") (if (equal? tableform "bigtabular") "\n\\\\" "")
"\n\\\\"
"")
tableform))))) tableform)))))
null) null)
(define/override (render-itemization t part ri) (define/override (render-itemization t part ri)
(printf "\n\n\\begin{itemize}\n") (printf "\n\n\\begin{itemize}\n")
(for-each (lambda (flow) (for ([flow (itemization-flows t)])
(printf "\n\n\\item ") (printf "\n\n\\item ")
(render-flow flow part ri #t)) (render-flow flow part ri #t))
(itemization-flows t))
(printf "\n\n\\end{itemize}\n") (printf "\n\n\\end{itemize}\n")
null) null)
(define/override (render-blockquote t part ri) (define/override (render-blockquote t part ri)
(let ([kind (or (blockquote-style t) (let ([kind (or (blockquote-style t) "quote")])
"quote")])
(printf "\n\n\\begin{~a}\n" kind) (printf "\n\n\\begin{~a}\n" kind)
(parameterize ([current-table-mode (list "blockquote" t)]) (parameterize ([current-table-mode (list "blockquote" t)])
(for-each (lambda (e) (for ([e (blockquote-paragraphs t)]) (render-block e part ri #f)))
(render-block e part ri #f))
(blockquote-paragraphs t)))
(printf "\n\n\\end{~a}\n" kind) (printf "\n\n\\end{~a}\n" kind)
null)) null))
(define/override (render-other i part ri) (define/override (render-other i part ri)
(cond (cond
[(string? i) (display-protected i)] [(string? i) (display-protected i)]
[(symbol? i) (display [(symbol? i)
(case i (display (case i
[(nbsp) "~"] [(nbsp) "~"]
[(mdash) "---"] [(mdash) "---"]
[(ndash) "--"] [(ndash) "--"]
@ -347,39 +311,33 @@
(let loop ([i 0]) (let loop ([i 0])
(unless (= i len) (unless (= i len)
(let ([c (string-ref s i)]) (let ([c (string-ref s i)])
(display
(case c (case c
[(#\\) (display "$\\backslash$")] [(#\\) "$\\backslash$"]
[(#\_) (display "$\\_$")] [(#\_) "$\\_$"]
[(#\^) (display "{\\char'136}")] [(#\^) "{\\char'136}"]
[(#\>) (if (rendering-tt) [(#\>) (if (rendering-tt) "{\\texttt >}" "$>$")]
(display "{\\texttt >}") [(#\<) (if (rendering-tt) "{\\texttt <}" "$<$")]
(display "$>$"))] [(#\|) (if (rendering-tt) "{\\texttt |}" "$|$")]
[(#\<) (if (rendering-tt) [(#\? #\! #\. #\:)
(display "{\\texttt <}") (if (rendering-tt) (format "{\\hbox{\\texttt{~a}}}" c) c)]
(display "$<$"))] [(#\~) "$\\sim$"]
[(#\|) (if (rendering-tt) [(#\{ #\} #\# #\% #\& #\$) (format "\\~a" c)]
(display "{\\texttt |}") [(#\uDF) "{\\ss}"]
(display "$|$"))] [(#\u039A) "K"] ; kappa
[(#\? #\! #\. #\:) (if (rendering-tt) [(#\u0391) "A"] ; alpha
(printf "{\\hbox{\\texttt{~a}}}" c) [(#\u039F) "O"] ; omicron
(display c))] [(#\u03A3) "$\\Sigma$"]
[(#\~) (display "$\\sim$")] [(#\u03BA) "$\\kappa$"]
[(#\{ #\} #\# #\% #\& #\$) (display "\\") (display c)] [(#\u03B1) "$\\alpha$"]
[(#\uDF) (display "{\\ss}")] [(#\u03BF) "o"] ; omicron
[(#\u039A) (display "K")] ; kappa [(#\u03C3) "$\\sigma$"]
[(#\u0391) (display "A")] ; alpha [(#\u03C2) "$\\varsigma$"]
[(#\u039F) (display "O")] ; omicron [(#\u03BB) "$\\lambda$"]
[(#\u03A3) (display "$\\Sigma$")] [(#\u039B) "$\\Lambda$"]
[(#\u03BA) (display "$\\kappa$")] [(#\u03BC) "$\\mu$"]
[(#\u03B1) (display "$\\alpha$")] [(#\u03C0) "$\\pi$"]
[(#\u03BF) (display "o")] ; omicron [else c])))
[(#\u03C3) (display "$\\sigma$")]
[(#\u03C2) (display "$\\varsigma$")]
[(#\u03BB) (display "$\\lambda$")]
[(#\u039B) (display "$\\Lambda$")]
[(#\u03BC) (display "$\\mu$")]
[(#\u03C0) (display "$\\pi$")]
[else (display c)]))
(loop (add1 i)))))) (loop (add1 i))))))
;; ---------------------------------------- ;; ----------------------------------------
@ -393,4 +351,4 @@
;; ---------------------------------------- ;; ----------------------------------------
(super-new)))) (super-new)))