#! /usr/bin/scheme --program ;;; html-prep.ss ;;; ;;; Copyright (c) 1998-2016 R. Kent Dybvig and Oscar Waddell ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a ;;; copy of this software and associated documentation files (the "Software"), ;;; to deal in the Software without restriction, including without limitation ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;;; and/or sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; TODO ;;; * fix paragraph handling ;;; * verify compliance of generated documents ;;; * resolve multicolumn bug --- see ./multicolumn-bug.stex ;;; - I commented out lots of stuff that Kent added and it seems to ;;; work for the one example I care about at the moment (right now ;;; I'm just trying to get Assignment 14 out by hook or by crook) ;;; * move stuff now unique to html-prep.ss from preplib.ss ;;; * add ability to insert arbitrary content into header ;;; * update documentation ;;; html-prep now consults the TEXINPUTS environment variable to ;;; locate .hcls files. ;;; primitive commands (latex standard first, then extensions) ;;; & ;;; \& ;;; ~ ;;; -- (en-dash) ;;; --- (em-dash) ;;; \'e, \'o ;;; \"{} ;;; \c{} ;;; \\[ignored] ;;; \ ;;; $ ... $ (see below) ;;; { ... } (groups) ;;; \begingroup ... \endgroup ;;; \bgroup ... \egroup ;;; % ;;; \[ ... \] (see below) ;;; \begin{eqnarray*} ... \end{eqnarray*} (see below) ;;; \begin{divertoutput}[i] ... \end{divertoutput} ;;; i selects a currently opened file: ;;; 0 first file opened, 1 second file, ... ;;; or -1 most recent, -2 next most recent, ... ;;; \begin{verbatim} ... \end{verbatim} ;;; \bf ;;; \bibitem ;;; \cite{...} ;;; \emph{...} ;;; \epsfbox{...} ;;; \genlab ;;; \hindex{label}{stuff} (see below) ;;; \include{filename} ;;; \input{filename} ;;; \index{stuff} (see below) ;;; \it ;;; \label{...} ;;; \pagebreak[n] ;;; \pageref[class]{...} ;;; \ref[class]{...} ;;; \usepackage{...} ; implicit .hsty suffix ;;; \vskip (remainder of line ignored!) ;;; \def ;;; \newenvironment ;;; \renewenvironment ;;; \newif ;;; \newcounter ;;; \setcounter ;;; \addtocounter ;;; \stepcounter ;;; \tt ;;; \closehtmlfile ;;; \closerawfile ;;; \currentoutputfile ;;; \headerstuff{stuff} (raw stuff between ;;; \documenttitle[formats]{title} ;;; \hpageref[class]{label}{text} (pageref link around text) ;;; \href[class]{label}{text} (ref link around text) ;;; \hardspaces ;;; \rawinput{filename} (inserts raw html from filename) ;;; \makeindex ;;; \openhtmlfile ;;; \openrawfile ;;; \raw{...} ;;; \geq{...} ;;; \leq{...} ;;; \neq{...} ;;; \equiv{...} ;;; \LARGE ;;; \Large ;;; \large ;;; \small ;;; \footnotesize ;;; \tiny ;;; Within $ ... $, \[ ... \], \begin{eqnarray*} ... \end{eqnarray*} ;;; user-defined macros are not presently expanded ;;; \index and \hindex syntax ;;; \index{levels} or \index{levels|pageformat} ;;; \hindex{label}{levels} or \hindex{label}{levels|pageformat} ;;; levels --> level ;;; --> level!levels ;;; level --> keyentry (key and entry same) ;;; level --> key@entry (separate key and entry) ;;; index and hindex entries follow makeindex 2.13 syntax except that ;;; the special characters !, @, |, ", and \ are freely allowed within ;;; embeded {, } pairs in the "actual entry" portion of a level (the ;;; portion following @, if any). a modified version of makeindex 2.13 ;;; that supports this extension (with the -d [allow delimited special ;;; chars] flag) is available here as well. #!chezscheme (import (except (chezscheme) open-input-file) (dsm) (preplib) (script)) (define math-directory (make-parameter "math")) (define push-ofile (lambda (op ofiles) (current-ofile op) (cons op ofiles))) (define pop-ofile (lambda (ofiles) (let ([ofiles (cdr ofiles)]) (current-ofile (and (not (null? ofiles)) (car ofiles))) ofiles))) (define get-counter-value (lambda (count) (getprop count 'counter #f))) (define set-counter-value! (lambda (count value) (putprop count 'counter value))) (define add-subcounter! (lambda (counter subcounter) (putprop counter 'subcounters (cons subcounter (getprop counter 'subcounters '()))))) (define subcounters (lambda (counter) (getprop counter 'subcounters '()))) (define tex-file-name (lambda (fn) (if (or (string=? (format "~a.tex" (path-root fn)) fn) (file-exists? fn)) fn (format "~a.tex" fn)))) (define open-html-file (lambda (ip title) (define next-count (lambda (root) (cond [(assoc root (output-file-counters)) => (lambda (a) (let ([n (+ (cdr a) 1)]) (set-cdr! a n) n))] [else (output-file-counters (cons (cons root 0) (output-file-counters))) 0]))) ; generate sequence of names foo.html, foo_1.html, foo_2.html, ... (let ([op (let ([fn (let ([root (path-root (port-name (current-ifile)))]) (let ([n (next-count root)]) (if (= n 0) (format "~a.html" root) (format "~a_~d.html" root n))))]) (open-output-file fn 'replace))]) (fprintf op "") (fprintf op "~%") (fprintf op "~%~%") (fprintf op "~%") (fprintf op "~%~a~%" title) (when (header-stuff) (display (header-stuff) op)) (when (style-sheet) (fprintf op "\n" (style-sheet))) (fprintf op "~%~%") op))) (define close-html-port (lambda (p) (fprintf p "~%") (fprintf p "~%") (close-output-port p))) (define get-cite (lambda (key) (or (getprop key 'cite) (begin (warningf #f "bib entry ~a not found" key) "???")))) (define put-label! (lambda (name type value) (putprop name type value))) (define get-label (lambda (name type) (or (getprop name type) (begin (warningf #f "label (~a) ~a undefined" type name) "???")))) (define read-aux-file (lambda (fn) (let ([ip (open-input-file fn)]) (parameterize ([current-ifile ip]) (let loop ([newline? #f]) (state-case (c (read-char ip)) [(#\newline) (loop #t)] [(#\\) (when newline? (let ([cmd (read-command ip)]) (case cmd [(|@|) (let ([cmd (read-command ip)]) (case cmd [(input) (read-aux-file (read-bracketed-text ip))]))] [(bibcite) (let* ([key (read-bracketed-text ip)] [cite (read-bracketed-text ip)]) (putprop (string->symbol key) 'cite cite))] [(newlabel) (let* ([name (read-bracketed-text ip)] [ref (begin (read-open-brace ip) (read-bracketed-text ip))] [pageref (read-bracketed-text ip)]) (put-label! (string->symbol name) 'pageref pageref))]))) (loop #f)] [(eof) (close-port ip)] [else (loop #f)])))))) ;; structures (define-structure (index-entry url keys texts pageno pageformat prefix)) (define s$ (lambda (ip op) ; within $...$ (let ([s (let ([buf (open-output-string)]) (let loop () (state-case (c (read-char ip)) [(#\$) (get-output-string buf)] [(eof) (unexpected-eof "within $ ... $")] [(#\newline) (write-char #\space buf) (loop)] [else (write-char c buf) (loop)])))]) (emit-math s op)))) (define (scomment ip op hard-spaces) (state-case (c (read-char ip)) [(eof #\newline) (unless hard-spaces (let eat-spaces () (state-case (c (peek-char ip)) [(#\space #\tab) (read-char ip) (eat-spaces)] [else (void)])))] [else (scomment ip op hard-spaces)])) (define seqnarray* (lambda (ip op) ; within \begin{eqnarray*} ... \end{eqnarray*} (let ([s (let ([buf (open-output-string)]) (let loop () (state-case (c (read-char ip)) [(#\\) (let ([cmd (read-command ip)]) (case cmd [(end) (read-open-brace ip) (if (equal? (read-bracketed-text ip 1) "eqnarray*") (get-output-string buf) (input-error "expected \\end{eqnarray*}"))] [else (fprintf buf "\\~a" cmd) (loop)]))] [(eof) (unexpected-eof "within eqnarray*")] [else (write-char c buf) (loop)])))]) (punt-to-latex (format "\\begin{eqnarray*}~a\\end{eqnarray*}" s) op)))) (define smathdisplay (lambda (ip op) ; within \[ ... \] (let ([s (let ([buf (open-output-string)]) (let loop () (state-case (c (read-char ip)) [(#\\) (let ([cmd (read-command ip)]) (case cmd ;[ [(|]|) (get-output-string buf)] [else (fprintf buf "\\~a" cmd) (loop)]))] [(eof) (unexpected-eof "within \\[ ... \\]")] [else (write-char c buf) (loop)])))]) (emit-math s op)))) (define emit-math (lambda (s op) (cond [(htmlmath (open-input-string s) #f) => (lambda (html) (display html op))] [else (punt-to-latex (format "$~a$" s) op)]))) (define htmlmath (lambda (ip compact?) (let ([buf (open-output-string)]) (let loop ([unary? #t]) (state-case (c (read-char ip)) [(#\\) (let ([cmd (read-command ip)]) (case cmd [(|{|) (fprintf buf "~a" cmd) (loop #t)] [(|}|) (fprintf buf "~a" cmd) (loop #f)] [(|,| |;|) (loop unary?)] [(cdot) (fprintf buf (if (or compact? unary?) "·" " · ")) (loop #t)] [(dots) (fprintf buf "...") (loop #f)] [(gt) (fprintf buf (if (or compact? unary?) ">" " > ")) (loop #t)] [(lt) (fprintf buf (if (or compact? unary?) "<" " < ")) (loop #t)] [(ge geq) (fprintf buf (if (or compact? unary?) "≥" " ≥ ")) (loop #t)] [(le leq) (fprintf buf (if (or compact? unary?) "≤" " ≤ ")) (loop #t)] [(ne neq) (fprintf buf (if (or compact? unary?) "≠" " ≠ ")) (loop #t)] [(equiv) (fprintf buf (if (or compact? unary?) "≡" " ≡ ")) (loop #t)] [(log) (fprintf buf "log") (loop #t)] [(pm) (fprintf buf (if (or compact? unary?) "±" " ± ")) (loop #t)] [(div) (fprintf buf (if (or compact? unary?) "÷" " ÷ ")) (loop #t)] [(times) (fprintf buf (if (or compact? unary?) "×" " × ")) (loop #t)] [else #f]))] [(#\{) (loop unary?)] [(#\}) (loop unary?)] [(#\_) (state-case (c (read-char ip)) [(#\{) (cond [(htmlmath (open-input-string (read-bracketed-text ip 1)) #t) => (lambda (html) (fprintf buf "~a" html) (loop #f))] [else #f])] [(eof) #f] [else (fprintf buf "~a" c) (loop #f)])] [(#\^) (state-case (c (read-char ip)) [(#\{) (cond [(htmlmath (open-input-string (read-bracketed-text ip 1)) #t) => (lambda (html) (fprintf buf "~a" html) (loop #f))] [else #f])] [(eof) #f] [else (fprintf buf "~a" c) (loop #f)])] [((#\a - #\z) (#\A - #\Z)) (fprintf buf "") (let loop ([c c]) (write-char c buf) (state-case (c (peek-char ip)) [((#\a - #\z) (#\A - #\Z)) (read-char ip) (loop c)] [else (void)])) (fprintf buf "") (loop #f)] [(#\<) (fprintf buf (if (or compact? unary?) "<" " < ")) (loop #t)] [(#\>) (fprintf buf (if (or compact? unary?) ">" " > ")) (loop #t)] [(#\= #\+ #\-) (fprintf buf (if (or compact? unary?) "~c" " ~c ") c) (loop #t)] [(#\/ #\( #\[ #\,) (write-char c buf) (loop #t)] [((#\0 - #\9) #\. #\) #\] #\! #\| #\') (write-char c buf) (loop #f)] [(#\space) (loop unary?)] [(#\newline) (write-char c buf) (loop #t)] [(eof) (get-output-string buf)] [else (input-error "unexpected character ~s in math mode" c)]))))) (define punt-to-latex (lambda (s op) (define latex-header "\\documentclass[12pt]{article} \\input mathmacros % Kent wanted it moved back up here for some reason. \\begin{document} \\pagestyle{empty} %\\input mathmacros % I had moved it for a good reason that I don't recall. ") (define latex-trailer " \\end{document} ") (cond [(assoc s (latex-cache)) => (lambda (a) (fprintf op "\"<graphic\">" (cdr a)))] [else (let* ([fn (math-file-name)] [texfn (format "~a.tex" fn)] [giffn (format "~a.gif" fn)]) (fprintf op "\"<graphic\">" giffn) (latex-cache (cons (cons s (format "~a" giffn)) (latex-cache))) ; don't rewrite file unless different to avoid need to remake gif file (let ([s (format "~a~a~a" latex-header s latex-trailer)]) (unless (guard (c [else #f]) (equal? s (call-with-port (open-input-file texfn) get-string-all))) (call-with-port (open-output-file texfn 'replace) (lambda (texop) (display s texop))))))]))) (define math-file-name (let ([seq -1]) (lambda () (set! seq (+ seq 1)) (format "~a/~d" (math-directory) seq)))) (define haux-put-label (lambda (label type url) (write `(putprop ',label ',type ,url) (haux-op)) (newline (haux-op)))) (define current-ofile-name (lambda () (if (current-ofile) (port-name (current-ofile)) "nofile"))) (define slabel (case-lambda [(label text) (slabel label text (gensym))] [(label text tag) (let ([url (format "~a#~a" (current-ofile-name) tag)]) (haux-put-label label 'pageref-url url) (when (current-ref-label) (haux-put-label label 'ref (car (current-ref-label))) (haux-put-label label 'ref-url (cdr (current-ref-label))))) (format "~a" tag text)])) (define sindex ; 1. read contents of \index{} form ; separate at !s into 1 or more levels plus page format after |, if ; present; separate levels at @ into sort key and text, if present ; recognize quoted/escaped characters in the input ; 2. look up pageno & url corresponding ; 3. cons entry on to index-entries (lambda (ip op lab) (call-with-values (lambda () (parse-index ip #f)) (lambda (levels page-format) (let ([keys (map (lambda (level) (or (car level) (cdr level))) levels)] [texts (map cdr levels)] [pageno (get-label lab 'pageref)] [url (get-label lab 'pageref-url)]) (index-entries (cons (make-index-entry url keys texts pageno page-format "") (index-entries)))))))) (define smakeindex ; insert indexspace between letters? ; links per starting letter? (lambda (op) (define print-page (lambda (entry) (let ([pageno (format "\\raw{}~a~a\\raw{}" (index-entry-url entry) (index-entry-prefix entry) (index-entry-pageno entry))] [pageformat (index-entry-pageformat entry)]) (if (string=? pageformat "") (fprintf op ", ~a" pageno) (fprintf op ", \\~a{~a}" pageformat pageno))))) (define see? (lambda (pageformat) (and (fx> (string-length pageformat) 3) (string=? (substring pageformat 0 3) "see")))) (define remove-dups ; remove dup even if url is different, which it usually will be. ; to avoid entries like "begin, 51, 51". if they're on the same ; page in the printed version, they'll be close enough in the ; electronic version. remove duplicate "see" pageformat entries ; regardless of the page and url. (lambda (ls) (if (null? ls) ls (let f ([ls (cdr ls)] [prev (car ls)]) (if (null? ls) (list prev) (let ([x (car ls)]) (if (let ([xpageformat (index-entry-pageformat x)]) (and (see? xpageformat) (string=? (index-entry-pageformat prev) xpageformat))) (f (cdr ls) prev) (if (and (equal? (index-entry-texts x) (index-entry-texts prev)) (string=? (index-entry-prefix x) (index-entry-prefix prev)) (string=? (index-entry-pageno x) (index-entry-pageno prev))) (if (string=? (index-entry-pageformat x) (index-entry-pageformat prev)) (f (cdr ls) prev) (if (string=? (index-entry-pageformat prev) "") (f (cdr ls) x) (if (string=? (index-entry-pageformat x) "") (f (cdr ls) prev) (errorf #f "conflicting page formats for ~s and ~s" x prev)))) (cons prev (f (cdr ls) x)))))))))) (define print-item (lambda (entry texts level) (let f ([texts texts] [level level]) (if (null? texts) (print-page entry) (begin (fprintf op "~% \\") (do ([i level (- i 1)]) ((= i 0)) (display "sub" op)) (fprintf op "item ~a" (car texts)) (f (cdr texts) (+ level 1))))))) (define see-cmp (lambda (xpageformat ypageformat) (if (see? xpageformat) (if (see? ypageformat) (str-cmp xpageformat ypageformat) '>) (if (see? ypageformat) '< '=)))) (guard (c [else #f]) (let ([seed-entries (call-with-port (open-input-file "in.hidx") read)]) (index-entries (append seed-entries (index-entries))))) (parameterize ([print-vector-length #f]) (let ([out.hidx (open-output-file "out.hidx" 'replace)]) (fprintf out.hidx "(~%") ;) (for-each (lambda (x) (fprintf out.hidx "~s~%" x)) (index-entries)) ;( (fprintf out.hidx ")~%"))) (fprintf op "\\begin{theindex}~%") (let ([ls (sort (lambda (x y) ; sort based on each key. if the keys compare equal, ; sort based on text. if the text is equal, sort based ; on the remaining keys and texts. for matching ; keys and texts, push "see" formats to the back, then ; sort on prefix, pageno, and url (let f ([xkeys (index-entry-keys x)] [xtexts (index-entry-texts x)] [ykeys (index-entry-keys y)] [ytexts (index-entry-texts y)]) (cond [(null? xkeys) (or (not (null? ykeys)) (case (see-cmp (index-entry-pageformat x) (index-entry-pageformat y)) [(<) #t] [(>) #f] [else (case (str-cmp (index-entry-prefix x) (index-entry-prefix y)) [(<) #t] [(>) #f] [else (let ([nx (pageno->number (index-entry-pageno x))] [ny (pageno->number (index-entry-pageno y))]) (cond [(< nx ny) #t] [(> nx ny) #f] [else (str-cmp (index-entry-url x) (index-entry-url y))]))])]))] [(null? ykeys) #f] [else (case (str-cmp (car xkeys) (car ykeys)) [(<) #t] [(>) #f] [else ; separate different texts with same keys (case (str-cmp (car xtexts) (car ytexts)) [(<) #t] [(>) #f] [else (f (cdr xkeys) (cdr xtexts) (cdr ykeys) (cdr ytexts))])])]))) (index-entries))]) (let loop ([ls (remove-dups ls)] [last-texts '()]) (unless (null? ls) (let* ([entry (car ls)] [texts (index-entry-texts entry)]) (let f ([texts texts] [last-texts last-texts] [level 0]) (if (null? last-texts) (if (null? texts) (print-page entry) (print-item entry texts level)) (if (eq? (str-cmp (car texts) (car last-texts)) '=) (f (cdr texts) (cdr last-texts) (+ level 1)) (print-item entry texts level)))) (loop (cdr ls) texts))))) (fprintf op "\\end{theindex}~%"))) (define pageno->number (lambda (s) (let ([sip (open-input-string s)]) (let loop ([a -10000]) (state-case (c (read-char sip)) [(#\i) (state-case (c (peek-char sip)) [(#\v) (read-char sip) (loop (+ a 4))] [(#\x) (read-char sip) (loop (+ a 9))] [else (loop (+ a 1))])] [(#\v) (state-case (c (peek-char sip)) [(#\x) (read-char sip) (loop (+ a 5))] [else (loop (+ a 5))])] [(#\x) (loop (+ a 10))] [(eof) a] [else (or (string->number s) -1)]))))) (define char-table (let ([s (make-string 256 #\nul)]) (define fill! (lambda (i ls) (unless (null? ls) (for-each (lambda (c) (string-set! s (char->integer c) (integer->char i))) (if (char? (car ls)) (list (car ls)) (car ls))) (fill! (+ i 1) (cdr ls))))) (fill! 1 '( #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 (#\A #\a) (#\B #\b) (#\C #\c) (#\D #\d) (#\E #\e) (#\F #\f) (#\G #\g) (#\H #\h) (#\I #\i) (#\J #\j) (#\K #\k) (#\L #\l) (#\M #\m) (#\N #\n) (#\O #\o) (#\P #\p) (#\Q #\q) (#\R #\r) (#\S #\s) (#\T #\t) (#\U #\u) (#\V #\v) (#\W #\w) (#\X #\x) (#\Y #\y) (#\Z #\z))) s)) (define char-cvt ; place all non-alphabetic characters up front; commonize upper and ; lower case characters (lambda (c) (string-ref char-table (char->integer c)))) (define str-cmp ; returns <, =, > if xy (lambda (s1 s2) (let ([n1 (string-length s1)] [n2 (string-length s2)]) (let f ([i 0]) (if (fx= i n2) (if (fx= i n1) '= '>) (if (fx= i n1) '< (let ([c1 (char-cvt (string-ref s1 i))] [c2 (char-cvt (string-ref s2 i))]) (if (char))))))))) (define push-undo (lambda (p undos) (cons (cons p (car undos)) (cdr undos)))) (define-syntactic-monad P ip ; current input port op ; current output port def-env ; definition environment pending ; stack of pending latex "environments" groups ; stack of pending groups ips ; input port stack; does not include ip ops ; output port stack; does not include op ifiles ; stack of input files [(cons ip ips) w/o string ports] ofiles ; stack of output files [(cons op ops) w/o string ports] rawfiles ; assocation list of name, raw output-file pairs hard-spaces ; if #t, treat spaces as ~ eofconts ; stack of continuations to call on eof undos ; stack of lists of undo procs to call when group ends column ; current column in current table columns ; stack of current column in pending tables colfmt ; column format for current table colfmts ; stack of column formats for pending tables convert-quotes ; if #t, converts `` and '' to " and -- to - ) (define sinclude (P lambda (fn) (let ([new-ip (guard (c [else (warningf #f "cannot open ~a" fn) #f]) (open-input-file fn))]) (if new-ip (P s0 ([ip new-ip] [ips (cons ip ips)] [eofconts (cons s0 eofconts)] [ifiles (push-ifile new-ip ifiles)])) (P s0))))) (define sbegingroup (P lambda (g) (P s0 ([groups (cons g groups)] [def-env (cons '() def-env)] [undos (cons '() undos)])))) (define sundo (lambda (ls) (if (null? ls) s0 (P lambda () (P (car ls) () (sundo (cdr ls))))))) (define sendgroup (P lambda (g) (unless (eq? (car groups) g) (input-error "unmatched ~a" (if (eq? g 'bgroup) "close brace or egroup" "endgroup"))) (P (sundo (car undos)) ([groups (cdr groups)] [def-env (cdr def-env)] [undos (cdr undos)])))) (define snewcommand (P lambda (cmd) (define iota (lambda (i n) (if (> i n) '() (cons i (iota (+ i 1) n))))) (let* ([argcnt-str (read-optional-arg ip)] [argcnt (if argcnt-str (string->number argcnt-str) 0)] [opt (read-optional-arg ip)] [template (read-bracketed-text ip)]) (unless (and argcnt (<= (if opt 1 0) argcnt 9)) (input-error "invalid argument count ~a" argcnt-str)) (let ([pattern (if opt (cons opt (iota 2 argcnt)) (iota 1 argcnt))]) (set-def! cmd def-env #f (P lambda () (P s0 ([ip (open-input-string (expand-template template (read-args ip pattern cmd) cmd))] [ips (cons ip ips)] [eofconts (cons s0 eofconts)])))))) (P s0))) (define snewenvironment (P lambda (cmd) (define iota (lambda (i n) (if (> i n) '() (cons i (iota (+ i 1) n))))) (let* ([argcnt-str (read-optional-arg ip)] [argcnt (if argcnt-str (string->number argcnt-str) 0)] [opt (read-optional-arg ip)] [b (begin (suppress-white-space ip) (read-bracketed-text ip))] [e (begin (suppress-white-space ip) (read-bracketed-text ip))]) (unless (and argcnt (<= (if opt 1 0) argcnt 9)) (input-error "invalid argument count ~a" argcnt-str)) (let ([pattern (if opt (cons opt (iota 2 argcnt)) (iota 1 argcnt))]) (set-def! cmd def-env #f (P lambda () (P s0 ([ip (open-input-string (expand-template b (read-args ip pattern cmd) cmd))] [ips (cons ip ips)] [eofconts (cons s0 eofconts)] [pending (cons cmd pending)]))))) (let ([endcmd (string->symbol (format "end~a" cmd))]) (set-def! endcmd def-env #f (P lambda () (P s0 ([ip (open-input-string e)] [ips (cons ip ips)] [eofconts (cons (P lambda () (check-pending (car pending) cmd) (P s0 ([pending (cdr pending)]))) eofconts)])))))) (P s0))) (define check-pending (lambda (expected actual) (unless (eq? expected actual) (input-error "expected \\end{~a}, got \\end{~a} or \\end~a" expected actual actual)))) (define process-string (P lambda (s k) (P s0 ([ip (open-input-string s)] [ips (cons ip ips)] [eofconts (cons (P lambda () (P k ([op (car ops)] [ops (cdr ops)]) (get-output-string op))) eofconts)] [op (open-output-string)] [ops (cons op ops)])))) (define new-conditional (lambda (ifcmd def-env default cmdtrue cmdfalse) (define scan-if (let ([buf (open-output-string)]) (lambda (ip def-env hard-spaces) (let loop ([depth 0] [then-part #f]) (state-case (c (read-char ip)) [(#\\) (let ([cmd (read-command ip)]) (cond [(conditional? cmd def-env) (fprintf buf "\\~a" cmd) (loop (+ depth 1) then-part)] [(and (= depth 0) (eq? cmd 'else)) (if then-part (input-error "extra \\else found") (loop depth (get-output-string buf)))] [(eq? cmd 'fi) (if (= depth 0) (if then-part (values then-part (get-output-string buf)) (values (get-output-string buf) "")) (begin (fprintf buf "\\~a" cmd) (loop (- depth 1) then-part)))] [else (fprintf buf "\\~a" cmd) (loop depth then-part)]))] [(#\%) (scomment ip buf hard-spaces) (loop depth then-part)] [(#\{) (fprintf buf "{~a}" (read-bracketed-text ip 1)) (loop depth then-part)] [(#\}) (input-error "unmatched } within \\if ... \\fi")] [(eof) (input-error "unexpected end-of-file within \\if ... \\fi")] [else (write-char c buf) (loop depth then-part)]))))) (let ([cell (cons default (void))]) (set-def! ifcmd def-env #t (P lambda () (call-with-values (lambda () (scan-if ip def-env hard-spaces)) (lambda (then-part else-part) (let ([part (if (car cell) then-part else-part)]) (P s0 ([ip (open-input-string part)] [ips (cons ip ips)] [eofconts (cons s0 eofconts)]))))))) (when cmdtrue (set-def! cmdtrue def-env #f (P lambda () (set-car! cell #t) (P s0)))) (when cmdfalse (set-def! cmdfalse def-env #f (P lambda () (set-car! cell #f) (P s0))))))) (define (sraw ip op) (state-case (c (read-char ip)) [(#\\) (state-case (c2 (peek-char ip)) [(#\%) (write-char (read-char ip) op)] [else (write-char #\\ op)]) (sraw ip op)] [(eof) (void)] [else (write-char c op) (sraw ip op)])) (define snewif (lambda (ip def-env) (state-case (c (read-char ip)) [(#\\) (let ([ifcmd (read-command ip)]) (let ([ifcmd-str (symbol->string ifcmd)]) (unless (and (> (string-length ifcmd-str) 2) (string=? (substring ifcmd-str 0 2) "if")) (input-error "invalid conditional name ~a" ifcmd)) (let ([cmd (substring ifcmd-str 2 (string-length ifcmd-str))]) (new-conditional ifcmd def-env #f (string->symbol (string-append cmd "true")) (string->symbol (string-append cmd "false"))))))] [else (input-error "unexpected character following \\newif")]))) (define-syntax numbering-command (syntax-rules () [(_ who fmt) (global-def who (snumber 'who fmt))])) (define snumber (lambda (who fmt) (P lambda () (let* ([counter (string->symbol (read-bracketed-text ip))] [value (get-counter-value counter)]) (unless value (input-error "unknown counter in \\~a{~a}" who counter)) (display (fmt (get-counter-value counter)) op)) (P s0)))) (define s0 (P lambda () (state-case (c (read-char ip)) [(#\\) (let ([cmd (read-command ip)]) (cond [(get-def cmd def-env) => (lambda (proc) (unless (command-symbol? cmd) (if hard-spaces (let loop () ; squeeze out only empty lines (state-case (c (peek-char ip)) [(#\newline) (read-char ip) (loop)] [(#\%) (read-char ip) (scomment ip op hard-spaces) (loop)] [else (void)])) (suppress-white-space ip))) (P proc))] [else (unexpected-command cmd)]))] [(#\space #\tab) (if hard-spaces (display " " op) (write-char c op)) (P s0)] [(#\~) (display " " op) (P s0)] [(#\-) (if convert-quotes ; emit - for -- and --- for ---. IE4 and older versions of netscape ; can't handle the proper HTML en-dash and em-dash encodings. (if (eqv? (peek-char ip) #\-) (begin (read-char ip) (if (eqv? (peek-char ip) #\-) (begin (read-char ip) (display "---" op)) ; should be — (display "-" op))) ; should be – (write-char c op)) (write-char c op)) (P s0)] [(#\<) (fprintf op "<") (P s0)] [(#\>) (fprintf op ">") (P s0)] [(#\$) (s$ ip op) (P s0)] [(#\%) (scomment ip op hard-spaces) (P s0)] [(#\{) (P sbegingroup () 'group)] [(#\}) (P sendgroup () 'group)] [(#\` #\') (if (and convert-quotes (eqv? (peek-char ip) c)) (begin (read-char ip) (write-char #\" op)) (write-char c op)) (P s0)] [(#\newline) (write-char c op) (when (let loop ([par? #f]) ; insert par for multiple blank lines (state-case (c (peek-char ip)) [(#\newline) (read-char ip) (write-char c op) (loop #t)] [(#\space #\tab) (if hard-spaces par? (begin (read-char ip) (write-char c op) (loop par?)))] [(#\%) (read-char ip) (scomment ip op hard-spaces) (loop par?)] [else par?])) (fprintf op "

~%")) (P s0)] [(#\&) (P sampersand ())] [(eof) (close-input-port ip) (if (null? ips) (void) (P (car eofconts) ([ip (car ips)] [ips (cdr ips)] [ifiles (if (eq? ip (car ifiles)) (pop-ifile ifiles) ifiles)] [eofconts (cdr eofconts)])))] [else (write-char c op) (P s0)]))) ;----------------------------------------------------------------------- ; rudimentary table support (define-record table (col-format border?)) (define silenced? #f) (define parse-col-format (lambda (s) (let ([ip (open-input-string s)]) (let loop ([ls '()] [border? #f]) (state-case (c (read-char ip)) [(#\|) (unless silenced? (set! silenced? #t) (warningf 'tabular "support for rules in HTML tables is imprecise")) (loop ls #t)] [(#\c) (loop (cons " align=\"center\"" ls) border?)] [(#\l) (loop (cons " align=\"left\"" ls) border?)] [(#\r) (loop (cons " align=\"right\"" ls) border?)] [(#\@) (warningf 'tabular "ignoring @{~a} for now" (read-bracketed-text ip)) (loop ls border?)] [(eof) (make-table (list->vector (reverse ls)) border?)] [else (input-error (format "unexpected column format specifier ~a" c))]))))) (define emit-td (P lambda (k) (fprintf (car ops) "~a" (vector-ref (table-col-format colfmt) column) (get-output-string op)) (case (car pending) [(multicolumn) (P k ([pending (cdr pending)] [colfmt (car colfmts)] [colfmts (cdr colfmts)]))] [(tabular) (P k ())] [else (errorf 'html-prep.ss "emit-td somehow invoked with invalid pending ~s" (car pending))]))) (define sampersand (P lambda () (case (car pending) [(tabular multicolumn) (P emit-td () (P lambda () (let ([column (+ column 1)]) (when (>= column (vector-length (table-col-format colfmt))) (unread-char #\& ip) (input-error "Extra alignment character &")) (P s0 ([op (open-output-string)] [column column])))))] [else (input-error "Misplaced or extra alignment tab character &")]))) (define scr (P lambda () (read-optional-arg ip) ; waste bracketed skip amount, if any (case (car pending) [(tabular multicolumn) (P emit-td () (P lambda () (display "" (car ops)) (P s0 ([column 0]))))] [else (display "
\n" op) (P s0)]))) ;----------------------------------------------------------------------- (define header-stuff (make-parameter #f)) (define style-sheet (make-parameter #f)) (define current-ofile (make-parameter #f)) ; for slabel (define current-ref-label (make-parameter #f)) (define document-title (make-parameter #f)) (define index-entries (make-parameter #f)) (define latex-cache (make-parameter #f)) (define output-file-counters (make-parameter #f)) (define haux-op (make-parameter #f)) (define jobname (make-parameter #f)) (define go (lambda (fn) (define bit-sink (let () (define make-bit-sink-port (lambda () (define handler (lambda (msg . args) (record-case (cons msg args) [block-write (p s n) (void)] [clear-output-port (p) (set-port-output-index! p 0)] [close-port (p) (set-port-output-size! p 0) (mark-port-closed! p)] [flush-output-port (p) (set-port-output-index! p 0)] [port-name (p) "bit-sink port"] [write-char (c p) (set-port-output-index! p 0)] [else (errorf 'bit-sink-port "operation ~s not handled" msg)]))) (let ([len 1024]) (let ([p (make-output-port handler (make-string len))]) p)))) (make-bit-sink-port))) (jobname fn) (let ([ip (open-input-file (tex-file-name fn))]) ; preplib parameters (parameterize ([current-ifile #f] [genlab-prefix "h"] [genlab-counters '()]) ; local parameters (parameterize ([header-stuff #f] [style-sheet #f] [current-ofile #f] [current-ref-label #f] [document-title "Untitled Document"] [index-entries '()] [latex-cache '()] [output-file-counters '()] [haux-op bit-sink]) (P s0 ([ip ip] [op bit-sink] [def-env '()] [pending '(top)] [groups '(top)] [ips '()] [ops '()] [ifiles (push-ifile ip '())] [ofiles '()] [rawfiles '()] [hard-spaces #f] [eofconts (list s0)] [undos (list '())] [column #f] ; need flow-sensitive static analysis [columns '()] [colfmt #f] ; need flow-sensitive static analysis [colfmts '()] [convert-quotes #t]))))))) (global-def def (P lambda () (let* ([cmd (state-case (c (read-char ip)) [(#\\) (read-command ip)] [else (input-error "invalid \\def syntax")])] [pattern (read-def-pattern ip)] [template (read-bracketed-text ip)]) (set-def! cmd def-env #f (P lambda () (P s0 ([ip (open-input-string (expand-template template (read-args ip pattern cmd) cmd))] [ips (cons ip ips)] [eofconts (cons s0 eofconts)])))) (P s0)))) ;\let\foo= (global-def let (P lambda () (let* ([cmd (state-case (c (read-char ip)) [(#\\) (read-command ip)] [else (input-error "invalid \\let syntax")])] [rhs (state-case (c (read-char ip)) [(#\=) (state-case (c (read-char ip)) [(#\\) (read-command ip)] [else (input-error "invalid \\let right-hand side")])] [else (input-error "expected = after \\let")])]) (set-def! cmd def-env #f (get-def rhs def-env)) (P s0)))) (global-def edef (P lambda () (let* ([cmd (state-case (c (read-char ip)) [(#\\) (read-command ip)] [else (input-error "invalid \\def syntax")])] [pattern (read-def-pattern ip)] [template (read-bracketed-text ip)]) (P process-string () template (P lambda (template) (set-def! cmd def-env #f (P lambda () (P s0 ([ip (open-input-string (expand-template template (read-args ip pattern cmd) cmd))] [ips (cons ip ips)] [eofconts (cons s0 eofconts)])))) (P s0)))))) (global-def newcommand (P lambda () (read-open-brace ip) (read-back-slash ip) (let ([cmd (read-command ip)]) (read-close-brace ip) (when (get-def cmd def-env) (input-error "\\newcommand: \\~a already defined" cmd)) (P snewcommand () cmd)))) (global-def renewcommand (P lambda () (read-open-brace ip) (read-back-slash ip) (let ([cmd (read-command ip)]) (read-close-brace ip) (unless (get-def cmd def-env) (input-error "\\renewcommand: \\~a undefined" cmd)) (P snewcommand () cmd)))) (global-def newenvironment (P lambda () (let ([cmd (string->symbol (read-bracketed-text ip))]) (when (get-def cmd def-env) (input-error "\\newenvironment: \\~a already defined" cmd)) (P snewenvironment () cmd)))) (global-def renewenvironment (P lambda () (let ([cmd (string->symbol (read-bracketed-text ip))]) (unless (get-def cmd def-env) (input-error "\\renewenvironment: \\~a undefined" cmd)) (P snewenvironment () cmd)))) (global-def begin (P lambda () (let ([cmd (string->symbol (read-bracketed-text ip))]) (cond [(get-def cmd def-env) => (lambda (proc) (P proc))] [else (input-error "undefined command \\begin{~a}" cmd)])))) (global-def end (P lambda () (let* ([cmd (string->symbol (read-bracketed-text ip))] [endcmd (string->symbol (format "end~a" cmd))]) (cond [(get-def endcmd def-env) => (lambda (proc) (P proc))] [else (input-error "undefined command \\end{~a}" cmd)])))) (global-def eqnarray* ; no endeqnarray*---we finish the job here (P lambda () (fprintf op "

~%") (seqnarray* ip op) (fprintf op "

~%") (P s0 ()))) (global-def divertoutput (P lambda () (let* ([level-str (or (read-optional-arg ip) "0")] [level (let ([i (string->number level-str)]) (and (fixnum? i) (let ([n (length ofiles)]) (and (fixnum? i) (if (fx< -1 i n) (fx- n i 1) (and (fx<= (- n) i -1) (fx- -1 i)))))))]) (cond [level (P s0 ([op (list-ref ofiles level)] [ops (cons op ops)]))] [(assoc level-str rawfiles) => (lambda (a) (P s0 ([op (cdr a)] [ops (cons op ops)])))] [else (input-error (format "invalid divertoutput file ~a" level-str))])))) (global-def enddivertoutput (P lambda () (P s0 ([op (car ops)] [ops (cdr ops)])))) (global-def begingroup (P lambda () (P sbegingroup () 'begingroup))) (global-def endgroup (P lambda () (P sendgroup () 'begingroup))) (global-def bgroup (P lambda () (P sbegingroup () 'bgroup))) (global-def egroup (P lambda () (P sendgroup () 'bgroup))) (global-def |[| ;] (P lambda () (fprintf op "

~%") (smathdisplay ip op) (fprintf op "

~%") (P s0))) (global-def raw (P lambda () (sraw (open-input-string (read-bracketed-text ip)) op) (P s0))) (global-def jobname (P lambda () (display (jobname) op) (P s0))) (global-def newif (P lambda () (snewif ip def-env) (P s0))) (numbering-command arabic (lambda (n) n)) (numbering-command alph (lambda (n) (when (> n 26) (input-error "counter value ~a too large for \\alph" n)) (string-ref "abcdefghijklmnopqrstuvwxyz" (- n 1)))) (numbering-command Alph (lambda (n) (when (> n 26) (input-error "counter value ~a too large for \\Alph" n)) (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" (- n 1)))) (global-def newcounter (P lambda () (let* ([name-str (read-bracketed-text ip)] [counter (string->symbol name-str)] [within (read-optional-arg ip)]) (when (get-counter-value counter) (input-error "newcounter of existing counter ~a" counter)) (when within (let ([within (string->symbol within)]) (unless (get-counter-value within) (input-error "newcounter of ~a within unknown counter ~a" counter within)) (add-subcounter! within counter))) (set-counter-value! counter 0) (set-def! (string->symbol (string-append "the" name-str)) def-env #f (P lambda () (display (get-counter-value counter) op) (P s0)))) (P s0))) (global-def setcounter (P lambda () (let* ([counter (string->symbol (read-bracketed-text ip))] [num-str (read-bracketed-text ip)] [old-value (get-counter-value counter)] [new-value (string->number num-str)]) (unless old-value (input-error "setcounter of unknown counter ~a" counter)) (unless new-value (input-error "invalid setcounter value ~a" num-str)) (set-counter-value! counter new-value)) (P s0))) (global-def addtocounter (P lambda () (let* ([counter (string->symbol (read-bracketed-text ip))] [num-str (read-bracketed-text ip)] [old-value (get-counter-value counter)] [incr (string->number num-str)]) (unless old-value (input-error "addtocounter of unknown counter ~a" counter)) (unless incr (input-error "invalid addtocounter increment ~a" num-str)) (set-counter-value! counter (+ old-value incr))) (P s0))) (global-def stepcounter (P lambda () (let* ([counter (string->symbol (read-bracketed-text ip))] [old-value (get-counter-value counter)]) (unless old-value (input-error "\\stepcounter of unknown counter ~a" counter)) (set-counter-value! counter (+ old-value 1)) (for-each (lambda (x) (set-counter-value! x 0)) (subcounters counter))) (P s0))) (global-def refstepcounter (P lambda () (let* ([counter (string->symbol (read-bracketed-text ip))] [old-value (get-counter-value counter)]) (unless old-value (input-error "\\refstepcounter of unknown counter ~a" counter)) (set-counter-value! counter (+ old-value 1)) (for-each (lambda (x) (set-counter-value! x 0)) (subcounters counter)) (P process-string () (format "\\the~a" counter) (P lambda (s) (let ([tag (gensym)]) (current-ref-label (cons s (format "~a#~a" (current-ofile-name) tag))) (fprintf op "" tag)) (P s0)))))) (global-def pagebreak (P lambda () (read-optional-arg ip) ; ignore [...] (P s0))) (global-def verbatim ; no endverbatim---we finish the job here (P lambda () (define escape-char (lambda (c) (case c [(#\space #\tab #\newline #\return) (write-char c op)] [(#\<) (fprintf op "<")] [(#\>) (fprintf op ">")] [(#\&) (fprintf op "&")] [else (write-char c op)]))) (display "

" op)
    (let loop ()
      (state-case (c (read-char ip))
        [(#\\)
         (let ([cmd (read-command ip)])
           (case cmd
             [(end)
              (state-case (c (read-char ip))
                [(#\{)
                 (let ([what (read-alpha-command ip)])
                   (if (and (eq? what 'verbatim) (eqv? (peek-char ip) #\}))
                       (read-char ip)
                       (begin
                         (fprintf op "\\end{~a" what)
                         (loop))))]
                [(eof) (unexpected-eof "within verbatim environment")]
                [else (fprintf op "\\end") (escape-char c) (loop)])]
             [else (fprintf op "\\~a" cmd) (loop)]))]
        [(eof) (unexpected-eof "within verbatim environment")]
        [else (escape-char c) (loop)]))
    (fprintf op "
~%") (P s0 ()))) (global-def |'| (P lambda () (state-case (c (read-char ip)) [(#\e) (fprintf op "é")] [(#\o) (fprintf op "ó")] [else (input-error "invalid \\' command \\'~a" c)]) (P s0))) (global-def |"| ; \"{} (P lambda () (let ([arg (read-bracketed-text ip)]) (unless (= (string-length arg) 1) (input-error "invalid \\\" argument ~s" arg)) (let ([c (string-ref arg 0)]) (case c [(#\a #\e #\i #\o #\u #\y #\A #\E #\I #\O #\U) (fprintf op "&~auml;" c)] [else (input-error "invalid \\\" command \\\"{~a}" c)]))) (P s0))) (global-def |c| ; \c{} (P lambda () (let ([arg (read-bracketed-text ip)]) (unless (= (string-length arg) 1) (input-error "invalid \\c argument ~s" arg)) (let ([c (string-ref arg 0)]) (case c [(#\c #\C) (fprintf op "&~acedil;" c)] [else (input-error "invalid \\c command \\c{~a}" c)]))) (P s0))) (global-def ss (P lambda () (fprintf op "ß") (P s0))) (global-def vskip (P lambda () ; it's a pain to parse tex amounts, so we choose to ignore ; everything up to the next line break instead...watch out! (let ([op (open-output-string)]) (let f () (state-case (c (read-char ip)) [(#\newline eof) (warningf 'vskip "discarded text: ~a" (get-output-string op)) (P s0)] [else (write-char c op) (f)]))))) (global-def large (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def Large (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def LARGE (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def small (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def footnotesize (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def tiny (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def normalsize (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def tt (P lambda () (fprintf op "") (P s0 ([convert-quotes #f] [undos (push-undo (P lambda (next) (fprintf op "") (P next ([convert-quotes #t]))) undos)])))) (global-def bf (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def it (P lambda () (fprintf op "") (P s0 ([undos (push-undo (P lambda (next) (fprintf op "") (P next)) undos)])))) (global-def hardspaces (P lambda () (let ([old-hs hard-spaces]) (P s0 ([hard-spaces #t] [undos (push-undo (P lambda (next) (P next ([hard-spaces old-hs]))) undos)]))))) (global-def include (P lambda () (P process-string () (read-bracketed-text ip) (P lambda (fn) (P sinclude () (format "~a.tex" fn)))))) (global-def input (P lambda () (P process-string () (read-bracketed-text ip) (P lambda (fn) (P sinclude () (tex-file-name fn)))))) (global-def rawinput (P lambda () (P process-string () (read-bracketed-text ip) (P lambda (fn) (call-with-port (guard (c [else (warningf #f "cannot open ~a" fn) #f]) (open-input-file fn)) (lambda (raw-ip) (let loop () (let ([c (read-char raw-ip)]) (unless (eof-object? c) (write-char c op) (loop)))))) (P s0))))) (global-def label (P lambda () (P process-string () (read-bracketed-text ip) (P lambda (s) (display (slabel (string->symbol s) "" s) op) (P s0))))) (global-def href (P lambda () (let ([class (read-optional-arg ip)]) (P process-string () (read-bracketed-text ip) (P lambda (lab) (P process-string () (read-bracketed-text ip) (P lambda (text) (let ([name (string->symbol lab)]) (fprintf op "~a" class (get-label name 'ref-url) text) (P s0))))))))) (global-def hpageref (P lambda () (let ([class (read-optional-arg ip)]) (P process-string () (read-bracketed-text ip) (P lambda (lab) (P process-string () (read-bracketed-text ip) (P lambda (text) (let ([name (string->symbol lab)]) (fprintf op "~a" class (get-label name 'pageref-url) text) (P s0))))))))) (global-def ref (P lambda () (let ([class (read-optional-arg ip)]) (P process-string () (read-bracketed-text ip) (P lambda (s) (let ([name (string->symbol s)]) (fprintf op "~a" class (get-label name 'ref-url) (get-label name 'ref))) (P s0)))))) (global-def pageref (P lambda () (let ([class (read-optional-arg ip)]) (P process-string () (read-bracketed-text ip) (P lambda (s) (let ([name (string->symbol s)]) (fprintf op "~a" class (get-label name 'pageref-url) (get-label name 'pageref))) (P s0)))))) (global-def cite (P lambda () (write-char #\[ op) (let ([keys (let ([sip (open-input-string (read-bracketed-text ip))] [buf (open-output-string)]) (let loop () (state-case (c (read-char sip)) [(#\,) (let ([key (get-output-string buf)]) (cons key (loop)))] [(eof) (list (get-output-string buf))] [else (write-char c buf) (loop)])))]) (do ([keys keys (cdr keys)] [sep "" ","]) ((null? keys) (write-char #\] op)) (let ([key (string->symbol (car keys))]) (fprintf op "~a~a" sep (get-label key 'pageref-url) (get-cite key))))) (P s0))) (global-def epsfbox (P lambda () (fprintf op "

~%") (punt-to-latex (format "\\input{epsf.sty}\\epsfbox{~a}" (read-bracketed-text ip)) op) (fprintf op "

~%") (P s0))) (global-def bibitem (P lambda () (let ([key (string->symbol (read-bracketed-text ip))]) (fprintf op "

[~a] " (slabel key (get-cite key)))) (P s0))) (global-def openhtmlfile (P lambda () (P process-string () (read-bracketed-text ip) (P lambda (title) (let ([new-op (open-html-file (car ifiles) title)]) (P s0 ([op new-op] [ops (cons op ops)] [ofiles (push-ofile new-op ofiles)]))))))) (global-def closehtmlfile (P lambda () (unless (and (not (null? ofiles)) (eq? op (car ofiles))) (input-error "invalid context for \\closehtmlfile")) (close-html-port op) (P s0 ([op (car ops)] [ops (cdr ops)] [ofiles (pop-ofile ofiles)])))) (global-def openrawfile (P lambda () (let ([name (read-bracketed-text ip)]) (P process-string () (read-bracketed-text ip) (P lambda (path) (P s0 ([rawfiles (cons (cons name (open-output-file path 'replace)) rawfiles)]))))))) (global-def closerawfile (P lambda () (let ([name (read-bracketed-text ip)]) (cond [(assoc name rawfiles) => (lambda (a) (close-output-port (cdr a)) (P s0 ([rawfiles (remq a rawfiles)])))] [else (input-error "unrecognized raw file" name)])))) (global-def genlab (P lambda () (display (genlab) op) (P s0))) (global-def hindex (P lambda () (P process-string () (read-bracketed-text ip) (P lambda (s) (read-open-brace ip) (sindex ip op (string->symbol s)) (P s0))))) (global-def index (P lambda () (let ([lab (genlab)]) (display (slabel lab "") op) (read-open-brace ip) (sindex ip op lab) (P s0)))) (global-def makeindex (P lambda () (let ([buf (open-output-string)]) (smakeindex buf) (P s0 ([ip (open-input-string (get-output-string buf))] [ips (cons ip ips)] [eofconts (cons s0 eofconts)]))))) (global-def documentclass (P lambda () (read-optional-arg ip) (P sinclude () (with-source-path 'documentclass (format "~a.hcls" (read-bracketed-text ip)) (lambda (x) (printf "using ~a~%" x) x))))) (global-def document (P lambda () (let ([root (path-root (port-name (car ifiles)))]) (let ([auxfn (format "~a.aux" root)] [hauxfn (format "~a.haux" root)]) (guard (c [else (warningf #f "missing or incomplete aux file")]) (read-aux-file (format "~a.aux" root))) (guard (c [else (warningf #f "missing or incomplete haux file")]) (load hauxfn)) (haux-op (open-output-file hauxfn 'replace)))) (P s0 ([ip (open-input-string (format "\\openhtmlfile{\\raw{~a}}" (document-title)))] [ips (cons ip ips)] [eofconts (cons s0 eofconts)])))) (global-def enddocument (P lambda () (for-each close-output-port (map cdr rawfiles)) (P s0 ([ip (open-input-string "\\closehtmlfile")] [ips (cons ip ips)] [eofconts (cons s0 eofconts)])))) (global-def headerstuff (P lambda () (header-stuff (read-bracketed-text ip)) (P s0))) (global-def documenttitle (P lambda () (let ([fmt (read-optional-arg ip)]) (P process-string () (read-bracketed-text ip) (P lambda (title) (global-def thetitle (P lambda () (display title op) (P s0))) (style-sheet fmt) (document-title title) (P s0)))))) (global-def |{| (P lambda () (display "{" op) (P s0))) (global-def |}| (P lambda () (display "}" op) (P s0))) (global-def | | (P lambda () (display (if hard-spaces " " #\space) op) (P s0))) (global-def |\| scr) (global-def usepackage (P lambda () (let ([filename (string-append (read-bracketed-text ip) ".hsty")]) (P sinclude () (or (ormap (lambda (p) (let ([path (string-append p "/" filename)]) (and (file-exists? path) path))) (source-directories)) (input-error (format "hprep style file ~s not found in TEXINPUTS" filename))))))) (global-def year (P lambda () (let* ([s (date-and-time)] [len (string-length s)]) (display (substring s (- len 4) len) op)) (P s0))) (global-def url (P lambda () (define display-url (lambda (s op) (let ([n (string-length s)]) (let loop ([i 0] [escape? #f]) (unless (fx= i n) (loop (fx+ i 1) (let ([c (string-ref s i)]) (or (and (not escape?) (char=? c #\\)) (begin (write-char c op) #f))))))))) (display-url (read-bracketed-text ip) op) (P s0))) (let () (global-def tabular (P lambda () (let ([s (read-bracketed-text ip)]) (let ([col-format (parse-col-format s)]) (display (if (table-border? col-format) "" "
") op) (P s0 ([op (open-output-string)] [ops (cons op ops)] [column 0] ; could collapse these [columns (cons column columns)] [colfmt col-format] [colfmts (cons colfmt colfmts)] [pending (cons 'tabular pending)])))))) (global-def endtabular (P lambda () (P emit-td () (P lambda () (check-pending (car pending) 'tabular) (display "
" (car ops)) (P s0 ([op (car ops)] [ops (cdr ops)] [column (car columns)] [columns (cdr columns)] [colfmt (car colfmts)] [colfmts (cdr colfmts)] [pending (cdr pending)])))))) (global-def multicolumn (P lambda () (let ([span (or (string->number (read-bracketed-text ip)) (input-error "number expected"))] [v (table-col-format colfmt)]) (unless (integer? span) (input-error "invalid \\multicolumn span")) (unless (<= 1 span (- (vector-length v) column)) (input-error (format "\\multicolumn span ~s out of range for ~s column table" span (vector-length v)))) (let* ([s (read-bracketed-text ip)] [fmt (parse-col-format s)]) (unless (= 1 (vector-length (table-col-format fmt))) (input-error (format "invalid \\multicolumn format ~a" s))) (P s0 ([ip (open-input-string (read-bracketed-text ip))] [ips (cons ip ips)] [colfmt (let ([newsize (- (vector-length v) span -1)]) (let ([new (make-vector newsize)]) (do ([i 0 (+ i 1)]) ((= i newsize) (make-table new (table-border? colfmt))) (vector-set! new i (cond [(< i column) (vector-ref v i)] [(= i column) (format " colspan=\"~a\"~a" span (vector-ref (table-col-format fmt) 0))] [else (vector-ref v (+ i span -1))])))))] [colfmts (cons colfmt colfmts)] [pending (cons 'multicolumn pending)] [eofconts (cons s0 eofconts)])))))) ) (populate-source-directories) (command-line-case (command-line) [((keyword --help)) (usage)] [((flags [--mathdir mathdir $ (math-directory mathdir)]) filename* ...) (for-each go (let ([found (find-filename "html-prep.tex")]) (if found (cons found filename*) filename*)))])