diff options
author | Ludovic Courtes | 2005-07-01 23:55:56 +0000 |
---|---|---|
committer | Ludovic Courtes | 2005-07-01 23:55:56 +0000 |
commit | efea4dc93f2565555e47de0bfd027614a9c8674d (patch) | |
tree | 393a916bf215a675ea75af989f1c66adfe9848c9 /skr/latex.skr | |
parent | a85155f7c411761cfbd75431f265675ae0f394e3 (diff) | |
download | skribilo-efea4dc93f2565555e47de0bfd027614a9c8674d.tar.gz skribilo-efea4dc93f2565555e47de0bfd027614a9c8674d.tar.lz skribilo-efea4dc93f2565555e47de0bfd027614a9c8674d.zip |
Lots of changes, again.
Lots of changes, notably the following:
* skr/*.skr: Moved engines to `src/guile/skribilo/engine'.
* src/guile/skribilo/engine.scm (lookup-engine): Rewritten. Don't use
the auto-load alist.
* src/guile/skribilo/evaluator.scm: New name of the `eval' module.
`eval' couldn't be used as the module base-name because of Guile's
recursive module name space.
git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-2
Diffstat (limited to 'skr/latex.skr')
-rw-r--r-- | skr/latex.skr | 1780 |
1 files changed, 0 insertions, 1780 deletions
diff --git a/skr/latex.skr b/skr/latex.skr deleted file mode 100644 index bc20493..0000000 --- a/skr/latex.skr +++ /dev/null @@ -1,1780 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/latex.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 09:46:09 2003 */ -;* Last change : Thu May 26 12:59:47 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* LaTeX Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/latexe.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* latex-verbatim-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-verbatim-encoding - '((#\\ "{\\char92}") - (#\^ "{\\char94}") - (#\{ "\\{") - (#\} "\\}") - (#\& "\\&") - (#\$ "\\$") - (#\# "\\#") - (#\_ "\\_") - (#\% "\\%") - (#\~ "$_{\\mbox{\\char126}}$") - (#\ç "\\c{c}") - (#\Ç "\\c{C}") - (#\â "\\^{a}") - (#\Â "\\^{A}") - (#\à "\\`{a}") - (#\À "\\`{A}") - (#\é "\\'{e}") - (#\É "\\'{E}") - (#\è "\\`{e}") - (#\È "\\`{E}") - (#\ê "\\^{e}") - (#\Ê "\\^{E}") - (#\ù "\\`{u}") - (#\Ù "\\`{U}") - (#\û "\\^{u}") - (#\Û "\\^{U}") - (#\ø "{\\o}") - (#\ô "\\^{o}") - (#\Ô "\\^{O}") - (#\ö "\\\"{o}") - (#\Ö "\\\"{O}") - (#\î "\\^{\\i}") - (#\Î "\\^{I}") - (#\ï "\\\"{\\i}") - (#\Ï "\\\"{I}") - (#\] "{\\char93}") - (#\[ "{\\char91}") - (#\» "\\,{\\tiny{$^{\\gg}$}}") - (#\« "{\\tiny{$^{\\ll}$}}\\,"))) - -;*---------------------------------------------------------------------*/ -;* latex-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-encoding - (append '((#\| "$|$") - (#\< "$<$") - (#\> "$>$") - (#\: "{\\char58}") - (#\# "{\\char35}") - (#\Newline " %\n")) - latex-verbatim-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-tt-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-tt-encoding - (append '((#\. ".\\-") - (#\/ "/\\-")) - latex-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-pre-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-pre-encoding - (append '((#\Space "\\ ") - (#\Newline "\\\\\n")) - latex-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-symbol-table ... */ -;*---------------------------------------------------------------------*/ -(define (latex-symbol-table math) - `(("iexcl" "!`") - ("cent" "c") - ("pound" "\\pounds") - ("yen" "Y") - ("section" "\\S") - ("mul" ,(math "^-")) - ("copyright" "\\copyright") - ("lguillemet" ,(math "\\ll")) - ("not" ,(math "\\neg")) - ("degree" ,(math "^{\\small{o}}")) - ("plusminus" ,(math "\\pm")) - ("micro" ,(math "\\mu")) - ("paragraph" "\\P") - ("middot" ,(math "\\cdot")) - ("rguillemet" ,(math "\\gg")) - ("1/4" ,(math "\\frac{1}{4}")) - ("1/2" ,(math "\\frac{1}{2}")) - ("3/4" ,(math "\\frac{3}{4}")) - ("iquestion" "?`") - ("Agrave" "\\`{A}") - ("Aacute" "\\'{A}") - ("Acircumflex" "\\^{A}") - ("Atilde" "\\~{A}") - ("Amul" "\\\"{A}") - ("Aring" "{\\AA}") - ("AEligature" "{\\AE}") - ("Oeligature" "{\\OE}") - ("Ccedilla" "{\\c{C}}") - ("Egrave" "{\\`{E}}") - ("Eacute" "{\\'{E}}") - ("Ecircumflex" "{\\^{E}}") - ("Euml" "\\\"{E}") - ("Igrave" "{\\`{I}}") - ("Iacute" "{\\'{I}}") - ("Icircumflex" "{\\^{I}}") - ("Iuml" "\\\"{I}") - ("ETH" "D") - ("Ntilde" "\\~{N}") - ("Ograve" "\\`{O}") - ("Oacute" "\\'{O}") - ("Ocurcumflex" "\\^{O}") - ("Otilde" "\\~{O}") - ("Ouml" "\\\"{O}") - ("times" ,(math "\\times")) - ("Oslash" "\\O") - ("Ugrave" "\\`{U}") - ("Uacute" "\\'{U}") - ("Ucircumflex" "\\^{U}") - ("Uuml" "\\\"{U}") - ("Yacute" "\\'{Y}") - ("szlig" "\\ss") - ("agrave" "\\`{a}") - ("aacute" "\\'{a}") - ("acircumflex" "\\^{a}") - ("atilde" "\\~{a}") - ("amul" "\\\"{a}") - ("aring" "\\aa") - ("aeligature" "\\ae") - ("oeligature" "{\\oe}") - ("ccedilla" "{\\c{c}}") - ("egrave" "{\\`{e}}") - ("eacute" "{\\'{e}}") - ("ecircumflex" "{\\^{e}}") - ("euml" "\\\"{e}") - ("igrave" "{\\`{\\i}}") - ("iacute" "{\\'{\\i}}") - ("icircumflex" "{\\^{\\i}}") - ("iuml" "\\\"{\\i}") - ("ntilde" "\\~{n}") - ("ograve" "\\`{o}") - ("oacute" "\\'{o}") - ("ocurcumflex" "\\^{o}") - ("otilde" "\\~{o}") - ("ouml" "\\\"{o}") - ("divide" ,(math "\\div")) - ("oslash" "\\o") - ("ugrave" "\\`{u}") - ("uacute" "\\'{u}") - ("ucircumflex" "\\^{u}") - ("uuml" "\\\"{u}") - ("yacute" "\\'{y}") - ("ymul" "\\\"{y}") - ;; Greek - ("Alpha" "A") - ("Beta" "B") - ("Gamma" ,(math "\\Gamma")) - ("Delta" ,(math "\\Delta")) - ("Epsilon" "E") - ("Zeta" "Z") - ("Eta" "H") - ("Theta" ,(math "\\Theta")) - ("Iota" "I") - ("Kappa" "K") - ("Lambda" ,(math "\\Lambda")) - ("Mu" "M") - ("Nu" "N") - ("Xi" ,(math "\\Xi")) - ("Omicron" "O") - ("Pi" ,(math "\\Pi")) - ("Rho" "P") - ("Sigma" ,(math "\\Sigma")) - ("Tau" "T") - ("Upsilon" ,(math "\\Upsilon")) - ("Phi" ,(math "\\Phi")) - ("Chi" "X") - ("Psi" ,(math "\\Psi")) - ("Omega" ,(math "\\Omega")) - ("alpha" ,(math "\\alpha")) - ("beta" ,(math "\\beta")) - ("gamma" ,(math "\\gamma")) - ("delta" ,(math "\\delta")) - ("epsilon" ,(math "\\varepsilon")) - ("zeta" ,(math "\\zeta")) - ("eta" ,(math "\\eta")) - ("theta" ,(math "\\theta")) - ("iota" ,(math "\\iota")) - ("kappa" ,(math "\\kappa")) - ("lambda" ,(math "\\lambda")) - ("mu" ,(math "\\mu")) - ("nu" ,(math "\\nu")) - ("xi" ,(math "\\xi")) - ("omicron" ,(math "\\o")) - ("pi" ,(math "\\pi")) - ("rho" ,(math "\\rho")) - ("sigmaf" ,(math "\\varsigma")) - ("sigma" ,(math "\\sigma")) - ("tau" ,(math "\\tau")) - ("upsilon" ,(math "\\upsilon")) - ("phi" ,(math "\\varphi")) - ("chi" ,(math "\\chi")) - ("psi" ,(math "\\psi")) - ("omega" ,(math "\\omega")) - ("thetasym" ,(math "\\vartheta")) - ("piv" ,(math "\\varpi")) - ;; punctuation - ("bullet" ,(math "\\bullet")) - ("ellipsis" ,(math "\\ldots")) - ("weierp" ,(math "\\wp")) - ("image" ,(math "\\Im")) - ("real" ,(math "\\Re")) - ("tm" ,(math "^{\\sc\\tiny{tm}}")) - ("alef" ,(math "\\aleph")) - ("<-" ,(math "\\leftarrow")) - ("<--" ,(math "\\longleftarrow")) - ("uparrow" ,(math "\\uparrow")) - ("->" ,(math "\\rightarrow")) - ("-->" ,(math "\\longrightarrow")) - ("downarrow" ,(math "\\downarrow")) - ("<->" ,(math "\\leftrightarrow")) - ("<-->" ,(math "\\longleftrightarrow")) - ("<+" ,(math "\\hookleftarrow")) - ("<=" ,(math "\\Leftarrow")) - ("<==" ,(math "\\Longleftarrow")) - ("Uparrow" ,(math "\\Uparrow")) - ("=>" ,(math "\\Rightarrow")) - ("==>" ,(math "\\Longrightarrow")) - ("Downarrow" ,(math "\\Downarrow")) - ("<=>" ,(math "\\Leftrightarrow")) - ("<==>" ,(math "\\Longleftrightarrow")) - ;; Mathematical operators - ("forall" ,(math "\\forall")) - ("partial" ,(math "\\partial")) - ("exists" ,(math "\\exists")) - ("emptyset" ,(math "\\emptyset")) - ("infinity" ,(math "\\infty")) - ("nabla" ,(math "\\nabla")) - ("in" ,(math "\\in")) - ("notin" ,(math "\\notin")) - ("ni" ,(math "\\ni")) - ("prod" ,(math "\\Pi")) - ("sum" ,(math "\\Sigma")) - ("asterisk" ,(math "\\ast")) - ("sqrt" ,(math "\\surd")) - ("propto" ,(math "\\propto")) - ("angle" ,(math "\\angle")) - ("and" ,(math "\\wedge")) - ("or" ,(math "\\vee")) - ("cap" ,(math "\\cap")) - ("cup" ,(math "\\cup")) - ("integral" ,(math "\\int")) - ("models" ,(math "\\models")) - ("vdash" ,(math "\\vdash")) - ("dashv" ,(math "\\dashv")) - ("sim" ,(math "\\sim")) - ("cong" ,(math "\\cong")) - ("approx" ,(math "\\approx")) - ("neq" ,(math "\\neq")) - ("equiv" ,(math "\\equiv")) - ("le" ,(math "\\leq")) - ("ge" ,(math "\\geq")) - ("subset" ,(math "\\subset")) - ("supset" ,(math "\\supset")) - ("subseteq" ,(math "\\subseteq")) - ("supseteq" ,(math "\\supseteq")) - ("oplus" ,(math "\\oplus")) - ("otimes" ,(math "\\otimes")) - ("perp" ,(math "\\perp")) - ("mid" ,(math "\\mid")) - ("lceil" ,(math "\\lceil")) - ("rceil" ,(math "\\rceil")) - ("lfloor" ,(math "\\lfloor")) - ("rfloor" ,(math "\\rfloor")) - ("langle" ,(math "\\langle")) - ("rangle" ,(math "\\rangle")) - ;; Misc - ("loz" ,(math "\\diamond")) - ("spades" ,(math "\\spadesuit")) - ("clubs" ,(math "\\clubsuit")) - ("hearts" ,(math "\\heartsuit")) - ("diams" ,(math "\\diamondsuit")) - ("euro" "\\euro{}") - ;; LaTeX - ("dag" "\\dag") - ("ddag" "\\ddag") - ("circ" ,(math "\\circ")) - ("top" ,(math "\\top")) - ("bottom" ,(math "\\bot")) - ("lhd" ,(math "\\triangleleft")) - ("rhd" ,(math "\\triangleright")) - ("parallel" ,(math "\\parallel")))) - -;*---------------------------------------------------------------------*/ -;* latex-engine ... */ -;*---------------------------------------------------------------------*/ -(define latex-engine - (default-engine-set! - (make-engine 'latex - :version 1.0 - :format "latex" - :delegate (find-engine 'base) - :filter (make-string-replace latex-encoding) - :custom '((documentclass "\\documentclass{article}") - (usepackage "\\usepackage{epsfig}\n") - (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n") - (postdocument #f) - (maketitle "\\date{}\n\\maketitle") - (%font-size 0) - ;; color - (color #t) - (color-usepackage "\\usepackage{color}\n") - ;; hyperref - (hyperref #t) - (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n") - ;; source fontification - (source-color #t) - (source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - (image-format ("eps")) - (index-page-ref #t)) - :symbol-table (latex-symbol-table - (lambda (m) - (format "\\begin{math}~a\\end{math}" m)))))) - -;*---------------------------------------------------------------------*/ -;* latex-title-engine ... */ -;*---------------------------------------------------------------------*/ -(define latex-title-engine - (make-engine 'latex-title - :version 1.0 - :format "latex-title" - :delegate latex-engine - :filter (make-string-replace latex-encoding) - :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m))))) - -;*---------------------------------------------------------------------*/ -;* latex-color? ... */ -;*---------------------------------------------------------------------*/ -(define (latex-color? e) - (engine-custom e 'color)) - -;*---------------------------------------------------------------------*/ -;* LaTeX ... */ -;*---------------------------------------------------------------------*/ -(define-markup (LaTeX #!key (space #t)) - (if (engine-format? "latex") - (! (if space "\\LaTeX\\ " "\\LaTeX")) - "LaTeX")) - -;*---------------------------------------------------------------------*/ -;* TeX ... */ -;*---------------------------------------------------------------------*/ -(define-markup (TeX #!key (space #t)) - (if (engine-format? "latex") - (! (if space "\\TeX\\ " "\\TeX")) - "TeX")) - -;*---------------------------------------------------------------------*/ -;* latex ... */ -;*---------------------------------------------------------------------*/ -(define-markup (!latex fmt #!rest opt) - (if (engine-format? "latex") - (apply ! fmt opt) - #f)) - -;*---------------------------------------------------------------------*/ -;* latex-width ... */ -;*---------------------------------------------------------------------*/ -(define (latex-width width) - (if (and (number? width) (inexact? width)) - (string-append (number->string (/ width 100.)) "\\linewidth") - (string-append (number->string width) "pt"))) - -;*---------------------------------------------------------------------*/ -;* latex-font-size ... */ -;*---------------------------------------------------------------------*/ -(define (latex-font-size size) - (case size - ((4) "Huge") - ((3) "huge") - ((2) "Large") - ((1) "large") - ((0) "normalsize") - ((-1) "small") - ((-2) "footnotesize") - ((-3) "scriptsize") - ((-4) "tiny") - (else (if (number? size) - (if (< size 0) "tiny" "Huge") - "normalsize")))) - -;*---------------------------------------------------------------------*/ -;* *skribe-latex-color-table* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-latex-color-table* #f) - -;*---------------------------------------------------------------------*/ -;* latex-declare-color ... */ -;*---------------------------------------------------------------------*/ -(define (latex-declare-color name rgb) - (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb)) - -;*---------------------------------------------------------------------*/ -;* skribe-get-latex-color ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-get-latex-color spec) - (let ((c (and (hashtable? *skribe-latex-color-table*) - (hashtable-get *skribe-latex-color-table* spec)))) - (if (not (string? c)) - (skribe-error 'latex "Can't find color" spec) - c))) - -;*---------------------------------------------------------------------*/ -;* skribe-color->latex-rgb ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-color->latex-rgb spec) - (receive (r g b) - (skribe-color->rgb spec) - (cond - ((and (= r 0) (= g 0) (= b 0)) - "0.,0.,0.") - ((and (= r #xff) (= g #xff) (= b #xff)) - "1.,1.,1.") - (else - (let ((ff (exact->inexact #xff))) - (format "~a,~a,~a" - (number->string (/ r ff)) - (number->string (/ g ff)) - (number->string (/ b ff)))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-latex-declare-colors ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-latex-declare-colors colors) - (set! *skribe-latex-color-table* (make-hashtable)) - (for-each (lambda (spec) - (let ((old (hashtable-get *skribe-latex-color-table* spec))) - (if (not (string? old)) - (let ((name (symbol->string (gensym 'c)))) - ;; bind the color - (hashtable-put! *skribe-latex-color-table* spec name) - ;; and emit a latex declaration - (latex-declare-color - name - (skribe-color->latex-rgb spec)))))) - colors)) - -;*---------------------------------------------------------------------*/ -;* &~ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&~ - :before "~" - :action #f) - -;*---------------------------------------------------------------------*/ -;* &latex-table-start */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-start - :options '() - :action (lambda (n e) - (let ((width (markup-option n 'width))) - (if (number? width) - (printf "\\begin{tabular*}{~a}" (latex-width width)) - (display "\\begin{tabular}"))))) - -;*---------------------------------------------------------------------*/ -;* &latex-table-stop */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-stop - :options '() - :action (lambda (n e) - (let ((width (markup-option n 'width))) - (if (number? width) - (display "\\end{tabular*}\n") - (display "\\end{tabular}\n"))))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'document - :options '(:title :author :ending :env) - :before (lambda (n e) - ;; documentclass - (let ((dc (engine-custom e 'documentclass))) - (if dc - (begin (display dc) (newline)) - (display "\\documentclass{article}\n"))) - (if (latex-color? e) - (display (engine-custom e 'color-usepackage))) - (if (engine-custom e 'hyperref) - (display (engine-custom e 'hyperref-usepackage))) - ;; usepackage - (let ((pa (engine-custom e 'usepackage))) - (if pa (begin (display pa) (newline)))) - ;; colors - (if (latex-color? e) - (begin - (skribe-use-color! (engine-custom e 'source-comment-color)) - (skribe-use-color! (engine-custom e 'source-define-color)) - (skribe-use-color! (engine-custom e 'source-module-color)) - (skribe-use-color! (engine-custom e 'source-markup-color)) - (skribe-use-color! (engine-custom e 'source-thread-color)) - (skribe-use-color! (engine-custom e 'source-string-color)) - (skribe-use-color! (engine-custom e 'source-bracket-color)) - (skribe-use-color! (engine-custom e 'source-type-color)) - (display "\n%% colors\n") - (skribe-latex-declare-colors (skribe-get-used-colors)) - (display "\n\n"))) - ;; predocument - (let ((pd (engine-custom e 'predocument))) - (when pd (display pd) (newline))) - ;; title - (let ((t (markup-option n :title))) - (when t - (skribe-eval (new markup - (markup '&latex-title) - (body t)) - e - :env `((parent ,n))))) - ;; author - (let ((a (markup-option n :author))) - (when a - (skribe-eval (new markup - (markup '&latex-author) - (body a)) - e - :env `((parent ,n))))) - ;; document - (display "\\begin{document}\n") - ;; postdocument - (let ((pd (engine-custom e 'postdocument))) - (if pd (begin (display pd) (newline)))) - ;; maketitle - (let ((mt (engine-custom e 'maketitle))) - (if mt (begin (display mt) (newline))))) - :action (lambda (n e) - (output (markup-body n) e)) - :after (lambda (n e) - (display "\n\\end{document}\n"))) - -;*---------------------------------------------------------------------*/ -;* &latex-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-title - :before "\\title{" - :after "}\n") - -;*---------------------------------------------------------------------*/ -;* &latex-author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-author - :before "\\author{\\centerline{\n" - :action (lambda (n e) - (let ((body (markup-body n))) - (if (pair? body) - (begin - (output (new markup - (markup '&latex-table-start) - (class "&latex-author-table")) - e) - (printf "{~a}\n" (make-string (length body) #\c)) - (let loop ((as body)) - (output (car as) e) - (if (pair? (cdr as)) - (begin - (display " & ") - (loop (cdr as))))) - (display "\\\\\n") - (output (new markup - (markup '&latex-table-stop) - (class "&latex-author-table")) - e)) - (output body e)))) - :after "}}\n") - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (output (new markup - (markup '&latex-table-start) - (class "author")) - e) - (printf "{~a}\n" - (case (markup-option n :align) - ((left) "l") - ((right) "r") - (else "c")))) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (output n e) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (cond - ((pair? address) - (for-each row address)) - ((string? address) - (row address))) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url)))) - :after (lambda (n e) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :predicate (lambda (n e) (markup-option n :photo)) - :before (lambda (n e) - (output (new markup - (markup '&latex-table-start) - (class "author")) - e) - (printf "{cc}\n")) - :action (lambda (n e) - (let ((photo (markup-option n :photo))) - (output photo e) - (display " & ") - (markup-option-add! n :photo #f) - (output n e) - (markup-option-add! n :photo photo) - (display "\\\\\n"))) - :after (lambda (n e) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'toc - :options '() - :action (lambda (n e) (display "\\tableofcontents\n"))) - -;*---------------------------------------------------------------------*/ -;* latex-block-before ... */ -;*---------------------------------------------------------------------*/ -(define (latex-block-before m) - (lambda (n e) - (let ((num (markup-option n :number))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a~a{" m (if (not num) "*" "")) - (output (markup-option n :title) latex-title-engine) - (display "}\n") - (when num - (printf "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) - -;*---------------------------------------------------------------------*/ -;* section ... .. @label chapter@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'chapter - :options '(:title :number :toc :file :env) - :before (latex-block-before 'chapter)) - -;*---------------------------------------------------------------------*/ -;* section ... . @label section@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'section - :options '(:title :number :toc :file :env) - :before (latex-block-before 'section)) - -;*---------------------------------------------------------------------*/ -;* subsection ... @label subsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsection - :options '(:title :number :toc :file :env) - :before (latex-block-before 'subsection)) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... @label subsubsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsubsection - :options '(:title :number :toc :file :env) - :before (latex-block-before 'subsubsection)) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'paragraph - :options '(:title :number :toc :env) - :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n" - (ast-location n))) - (display "\\noindent ")) - :after "\\par\n") - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'footnote - :before "\\footnote{" - :after "}") - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak - :action (lambda (n e) - (display "\\makebox[\\linewidth]{}"))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'hrule - :options '() - :before "\\hrulefill" - :action #f) - -;*---------------------------------------------------------------------*/ -;* latex-color-counter */ -;*---------------------------------------------------------------------*/ -(define latex-color-counter 1) - -;*---------------------------------------------------------------------*/ -;* latex-color ... */ -;*---------------------------------------------------------------------*/ -(define latex-color - (lambda (bg fg n e) - (if (not (latex-color? e)) - (output n e) - (begin - (if bg - (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter)) - (set! latex-color-counter (+ latex-color-counter 1)) - (if fg - (begin - (printf "\\textcolor{~a}{" (skribe-get-latex-color fg)) - (output n e) - (display "}")) - (output n e)) - (set! latex-color-counter (- latex-color-counter 1)) - (if bg - (printf "\\egroup\\colorbox{~a}{\\box~a}%\n" - (skribe-get-latex-color bg) latex-color-counter)))))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'color - :options '(:bg :fg :width) - :action (lambda (n e) - (let* ((w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (m (markup-option n :margin)) - (tw (cond - ((not w) - #f) - ((and (integer? w) (exact? w)) - w) - ((real? w) - (latex-width w))))) - (when bg - (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n") - (when m - (printf "\\addtolength{\\tabcolsep}{~a}" - (latex-width m))) - (output (new markup - (markup '&latex-table-start) - (class "color")) - e) - (if tw - (printf "{p{~a}}\n" tw) - (printf "{l}\n"))) - (latex-color bg fg (markup-body n) e) - (when bg - (output (new markup - (markup '&latex-table-stop) - (class "color")) - e) - (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n"))))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'frame - :options '(:width :border :margin) - :before (lambda (n e) - (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}") - (let ((m (markup-option n :margin))) - (when m - (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) - (newline)) - :action (lambda (n e) - (let* ((b (markup-option n :border)) - (w (markup-option n :width)) - (tw (cond - ((not w) - ".96\\linewidth") - ((and (integer? w) (exact? w)) - w) - ((real? w) - (latex-width w))))) - (output (new markup - (markup '&latex-table-start) - (class "frame")) - e) - (if (and (integer? b) (> b 0)) - (begin - (printf "{|p{~a}|}\\hline\n" tw) - (output (markup-body n) e) - (display "\\\\\\hline\n")) - (begin - (printf "{p{~a}}\n" tw) - (output (markup-body n) e))) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n") - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'font - :options '(:size) - :action (lambda (n e) - (let* ((size (markup-option n :size)) - (cs (let ((n (engine-custom e '%font-size))) - (if (number? n) - n - 0))) - (ns (cond - ((and (integer? size) (exact? size)) - (if (> size 0) - size - (+ cs size))) - ((and (number? size) (inexact? size)) - (+ cs (inexact->exact size))) - ((string? size) - (let ((nb (string->number size))) - (if (not (number? nb)) - (skribe-error - 'font - (format "Illegal font size ~s" size) - nb) - (+ cs nb)))))) - (ne (make-engine (gensym 'latex) - :delegate e - :filter (engine-filter e) - :symbol-table (engine-symbol-table e) - :custom `((%font-size ,ns) - ,@(engine-customs e))))) - (printf "{\\~a{" (latex-font-size ns)) - (output (markup-body n) ne) - (display "}}")))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\\begin{center}\n")) - ((left) - (display "\\begin{flushleft}")) - ((right) - (display "\\begin{flushright}")))) - :after (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\\end{center}\n")) - ((left) - (display "\\end{flushleft}\n")) - ((right) - (display "\\end{flushright}\n"))))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before "\\begin{center}\n" - :after "\\end{center}\n") - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'pre - :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{" - latex-color-counter) - (output (new markup - (markup '&latex-table-start) - (class "pre")) - e) - (display "{l}\n") - (set! latex-color-counter (+ latex-color-counter 1))) - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after (lambda (n e) - (set! latex-color-counter (- latex-color-counter 1)) - (output (new markup - (markup '&latex-table-stop) - (class "pre")) - e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'prog - :options '(:line :mark) - :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{" - latex-color-counter) - (output (new markup - (markup '&latex-table-start) - (class "pre")) - e) - (display "{l}\n") - (set! latex-color-counter (+ latex-color-counter 1))) - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after (lambda (n e) - (set! latex-color-counter (- latex-color-counter 1)) - (output (new markup - (markup '&latex-table-stop) - (class "prog")) - e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) - -;*---------------------------------------------------------------------*/ -;* &prog-line ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&prog-line - :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) - :after "\\\\\n") - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'itemize - :options '(:symbol) - :before "\\begin{itemize}\n" - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{itemize} ") - -(markup-writer 'itemize - :predicate (lambda (n e) (markup-option n :symbol)) - :options '(:symbol) - :before (lambda (n e) - (display "\\begin{list}{") - (output (markup-option n :symbol) e) - (display "}{}") - (newline)) - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{list}\n") - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'enumerate - :options '(:symbol) - :before "\\begin{enumerate}\n" - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{enumerate}\n") - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'description - :options '(:symbol) - :before "\\begin{description}\n" - :action (lambda (n e) - (for-each (lambda (item) - (let ((k (markup-option item :key))) - (for-each (lambda (i) - (display " \\item[") - (output i e) - (display "]\n")) - (if (pair? k) k (list k))) - (output (markup-body item) e))) - (markup-body n))) - :after "\\end{description}\n") - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (if k - (begin - (display "[") - (output k e) - (display "] ")))) - (output (markup-body n) e))) - -;*---------------------------------------------------------------------*/ -;* blockquote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote - :before "\n\\begin{quote}\n" - :after "\n\\end{quote}") - -;*---------------------------------------------------------------------*/ -;* figure ... @label figure@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'figure - :options '(:legend :number :multicolumns) - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend)) - (mc (markup-option n :multicolumns))) - (display (if mc - "\\begin{figure*}[!th]\n" - "\\begin{figure}[ht]\n")) - (output (markup-body n) e) - (printf "\\caption{\\label{~a}" (string-canonicalize ident)) - (output legend e) - (display (if mc - "}\\end{figure*}\n" - "}\\end{figure}\n"))))) - -;*---------------------------------------------------------------------*/ -;* table-column-number ... */ -;* ------------------------------------------------------------- */ -;* Computes how many columns are contained in a table. */ -;*---------------------------------------------------------------------*/ -(define (table-column-number t) - (define (row-columns row) - (let luup ((cells (markup-body row)) - (nbcols 0)) - (cond - ((null? cells) - nbcols) - ((pair? cells) - (luup (cdr cells) - (+ nbcols (markup-option (car cells) :colspan)))) - (else - (skribe-type-error 'tr "Illegal tr body, " row "pair"))))) - (let loop ((rows (markup-body t)) - (nbcols 0)) - (if (null? rows) - nbcols - (loop (cdr rows) - (max (row-columns (car rows)) nbcols))))) - -;*---------------------------------------------------------------------*/ -;* table ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'table - :options '(:width :frame :rules :cellstyle) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (nbcols (table-column-number n)) - (id (markup-ident n)) - (cla (markup-class n)) - (rows (markup-body n))) - ;; the table header - (output (new markup - (markup '&latex-table-start) - (class "table") - (options `((width ,width)))) - e) - ;; store the actual number of columns - (markup-option-add! n '&nbcols nbcols) - ;; compute the table header - (let ((cols (cond - ((= nbcols 0) - (skribe-error 'table - "Illegal empty table" - n)) - ((or (not width) (= nbcols 1)) - (make-string nbcols #\c)) - (else - (let ((v (make-vector - (- nbcols 1) - "@{\\extracolsep{\\fill}}c"))) - (apply string-append - (cons "c" (vector->list v)))))))) - (case frame - ((none) - (printf "{~a}\n" cols)) - ((border box) - (printf "{|~a|}" cols) - (markup-option-add! n '&lhs #t) - (markup-option-add! n '&rhs #t) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-above" id)) - (class "table-line-above")) - e)) - ((above hsides) - (printf "{~a}" cols) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-above" id)) - (class "table-line-above")) - e)) - ((vsides) - (markup-option-add! n '&lhs #t) - (markup-option-add! n '&rhs #t) - (printf "{|~a|}\n" cols)) - ((lhs) - (markup-option-add! n '&lhs #t) - (printf "{|~a}\n" cols)) - ((rhs) - (markup-option-add! n '&rhs #t) - (printf "{~a|}\n" cols)) - (else - (printf "{~a}\n" cols))) - ;; mark each row with appropriate '&tl (top-line) - ;; and &bl (bottom-line) options - (when (pair? rows) - (if (and (memq rules '(rows all)) - (or (not (eq? cstyle 'collapse)) - (not (memq frame '(border box above hsides))))) - (let ((frow (car rows))) - (if (is-markup? frow 'tr) - (markup-option-add! frow '&tl #t)))) - (if (eq? rules 'header) - (let ((frow (car rows))) - (if (is-markup? frow 'tr) - (markup-option-add! frow '&bl #t)))) - (when (and (pair? (cdr rows)) - (memq rules '(rows all))) - (for-each (lambda (row) - (if (is-markup? row 'tr) - (markup-option-add! row '&bl #t))) - rows) - (markup-option-add! (car (last-pair rows)) '&bl #f)) - (if (and (memq rules '(rows all)) - (or (not (eq? cstyle 'collapse)) - (not (memq frame '(border box above hsides))))) - (let ((lrow (car (last-pair rows)))) - (if (is-markup? lrow 'tr) - (markup-option-add! lrow '&bl #t)))))))) - :after (lambda (n e) - (case (markup-option n :frame) - ((hsides below box border) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-below" (markup-ident n))) - (class "table-hline-below")) - e))) - (output (new markup - (markup '&latex-table-stop) - (class "table") - (options `((width ,(markup-option n :width))))) - e))) - -;*---------------------------------------------------------------------*/ -;* &latex-table-hline */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-hline - :action "\\hline\n") - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tr - :options '() - :action (lambda (n e) - (let* ((parent (ast-parent n)) - (_ (if (not (is-markup? parent 'table)) - (skribe-type-error 'tr "Illegal parent, " parent - "#<table>"))) - (nbcols (markup-option parent '&nbcols)) - (lhs (markup-option parent '&lhs)) - (rhs (markup-option parent '&rhs)) - (rules (markup-option parent :rules)) - (collapse (eq? (markup-option parent :cellstyle) - 'collapse)) - (vrules (memq rules '(cols all))) - (cells (markup-body n))) - (if (markup-option n '&tl) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (markup-ident n)) - (class (markup-class n))) - e)) - (if (> nbcols 0) - (let laap ((nbc nbcols) - (cs cells)) - (if (null? cs) - (when (> nbc 1) - (display " & ") - (laap (- nbc 1) cs)) - (let* ((c (car cs)) - (nc (- nbc (markup-option c :colspan)))) - (when (= nbcols nbc) - (cond - ((and lhs vrules (not collapse)) - (markup-option-add! c '&lhs "||")) - ((or lhs vrules) - (markup-option-add! c '&lhs #\|)))) - (when (= nc 0) - (cond - ((and rhs vrules (not collapse)) - (markup-option-add! c '&rhs "||")) - ((or rhs vrules) - (markup-option-add! c '&rhs #\|)))) - (when (and vrules (> nc 0) (< nc nbcols)) - (markup-option-add! c '&rhs #\|)) - (output c e) - (when (> nc 0) - (display " & ") - (laap nc (cdr cs))))))))) - :after (lambda (n e) - (display "\\\\") - (if (markup-option n '&bl) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (markup-ident n)) - (class (markup-class n))) - e) - (newline)))) - -;*---------------------------------------------------------------------*/ -;* tc */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tc - :options '(:width :align :valign :colspan) - :action (lambda (n e) - (let ((id (markup-ident n)) - (cla (markup-class n))) - (let* ((o0 (markup-body n)) - (o1 (if (eq? (markup-option n 'markup) 'th) - (new markup - (markup '&latex-th) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o0)) - o0)) - (o2 (if (markup-option n :width) - (new markup - (markup '&latex-tc-parbox) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o1)) - o1)) - (o3 (if (or (> (markup-option n :colspan) 1) - (not (eq? (markup-option n :align) - 'center)) - (markup-option n '&lhs) - (markup-option n '&rhs)) - (new markup - (markup '&latex-tc-multicolumn) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o2)) - o2))) - (output o3 e))))) - -;*---------------------------------------------------------------------*/ -;* &latex-th ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-th - :before "\\textsf{" - :after "}") - -;*---------------------------------------------------------------------*/ -;* &latex-tc-parbox ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-tc-parbox - :before (lambda (n e) - (let ((width (markup-option n :width)) - (valign (markup-option n :valign))) - (printf "\\parbox{~a}{" (latex-width width)))) - :after "}") - -;*---------------------------------------------------------------------*/ -;* &latex-tc-multicolumn ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-tc-multicolumn - :before (lambda (n e) - (let ((colspan (markup-option n :colspan)) - (lhs (or (markup-option n '&lhs) "")) - (rhs (or (markup-option n '&rhs) "")) - (align (case (markup-option n :align) - ((left) #\l) - ((center) #\c) - ((right) #\r) - (else #\c)))) - (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) - :after "}") - -;*---------------------------------------------------------------------*/ -;* image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'image - :options '(:file :url :width :height :zoom) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (zoom (markup-option n :zoom)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("eps")))))) - (if (not (string? img)) - (skribe-error 'latex "Illegal image" file) - (begin - (printf "\\epsfig{file=~a" (strip-ref-base img)) - (if width (printf ", width=~a" (latex-width width))) - (if height (printf ", height=~apt" height)) - (if zoom (printf ", zoom=\"~a\"" zoom)) - (display "}")))))) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'roman :before "{\\textrm{" :after "}}") -(markup-writer 'bold :before "{\\textbf{" :after "}}") -(markup-writer 'underline :before "{\\underline{" :after "}}") -(markup-writer 'emph :before "{\\em{" :after "}}") -(markup-writer 'it :before "{\\textit{" :after "}}") -(markup-writer 'code :before "{\\texttt{" :after "}}") -(markup-writer 'var :before "{\\texttt{" :after "}}") -(markup-writer 'sc :before "{\\sc{" :after "}}") -(markup-writer 'sf :before "{\\sf{" :after "}}") -(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}") -(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}") - -(markup-writer 'tt - :before "{\\texttt{" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-tt-encoding) - :custom (engine-customs e) - :symbol-table (engine-symbol-table e)))) - (output (markup-body n) ne))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* q ... @label q@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'q - :before "``" - :after "''") - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :before "{\\texttt{" - :action (lambda (n e) - (let ((text (markup-option n :text))) - (output (or text (markup-body n)) e))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mark - :before (lambda (n e) - (printf "\\label{~a}" (string-canonicalize (markup-ident n))))) - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page) - :action (lambda (n e) - (let ((t (markup-option n :text))) - (if t - (begin - (output t e) - (output "~" e (markup-writer-get '&~ e)))))) - :after (lambda (n e) - (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c))) - (if (markup-option n :page) - (printf "\\begin{math}{\\pageref{~a}}\\end{math}" - (string-canonicalize id)) - (printf "\\ref{~a}" - (string-canonicalize id)))))) - -;*---------------------------------------------------------------------*/ -;* bib-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (output (markup-option (handle-ast (markup-body n)) :title) e)) - :after "]") - -;*---------------------------------------------------------------------*/ -;* bib-ref+ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (invoke (writer-action (markup-writer-get 'bib-ref e)) - (car rs) - e) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* url-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :action (lambda (n e) - (let ((text (markup-option n :text)) - (url (markup-option n :url))) - (if (not text) - (output url e) - (output text e))))) - -;*---------------------------------------------------------------------*/ -;* url-ref hyperref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :predicate (lambda (n e) - (engine-custom e 'hyperref)) - :action (lambda (n e) - (let ((body (markup-option n :text)) - (url (markup-option n :url))) - (if (and body (not (equal? body url))) - (begin - (display "\\href{") - (display url) - (display "}{") - (output body e) - (display "}")) - (begin - (display "\\href{") - (display url) - (printf "}{~a}" url)))))) - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :before "{\\textit{" - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (v (string->number (markup-option n :text)))) - (cond - ((and (number? o) (number? v)) - (display (+ o v))) - (else - (display v))))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* &the-bibliography ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-bibliography - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[21]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - \\itemsep 0pt - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-label e)) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :predicate (lambda (n e) - (engine-custom e 'hyperref)) - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before "\\item[{\\char91}" - :action (lambda (n e) (output (markup-option n :title) e)) - :after "{\\char93}] ") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-url ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-url - :action (lambda (n e) - (let* ((en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (t (bold (markup-body url)))) - (skribe-eval (ref :url (markup-body url) :text t) e)))) - -;*---------------------------------------------------------------------*/ -;* &source-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-line-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-keyword ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (underline (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &source-error ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'error-color) cc) - (color :fg cc (underline n1)) - (underline n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-define ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-module ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-markup ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-thread ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-string ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-bracket ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-key ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) |