diff options
Diffstat (limited to 'skr')
| -rw-r--r-- | skr/base.skr | 464 | ||||
| -rw-r--r-- | skr/context.skr | 1380 | ||||
| -rw-r--r-- | skr/html.skr | 2271 | ||||
| -rw-r--r-- | skr/html4.skr | 165 | ||||
| -rw-r--r-- | skr/latex-simple.skr | 101 | ||||
| -rw-r--r-- | skr/latex.skr | 1780 | ||||
| -rw-r--r-- | skr/xml.skr | 111 |
7 files changed, 0 insertions, 6272 deletions
diff --git a/skr/base.skr b/skr/base.skr deleted file mode 100644 index ec987ec..0000000 --- a/skr/base.skr +++ /dev/null @@ -1,464 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/base.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 12:39:30 2003 */ -;* Last change : Wed Oct 27 11:24:20 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* BASE Skribe engine */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* base-engine ... */ -;*---------------------------------------------------------------------*/ -(define base-engine - (default-engine-set! - (make-engine 'base - :version 'plain - :symbol-table '(("iexcl" "!") - ("cent" "c") - ("lguillemet" "\"") - ("not" "!") - ("registered" "(r)") - ("degree" "o") - ("plusminus" "+/-") - ("micro" "o") - ("paragraph" "p") - ("middot" ".") - ("rguillemet" "\"") - ("iquestion" "?") - ("Agrave" "À") - ("Aacute" "A") - ("Acircumflex" "Â") - ("Atilde" "A") - ("Amul" "A") - ("Aring" "A") - ("AEligature" "AE") - ("Oeligature" "OE") - ("Ccedilla" "Ç") - ("Egrave" "È") - ("Eacute" "É") - ("Ecircumflex" "Ê") - ("Euml" "E") - ("Igrave" "I") - ("Iacute" "I") - ("Icircumflex" "Î") - ("Iuml" "I") - ("ETH" "D") - ("Ntilde" "N") - ("Ograve" "O") - ("Oacute" "O") - ("Ocurcumflex" "O") - ("Otilde" "O") - ("Ouml" "O") - ("times" "x") - ("Oslash" "O") - ("Ugrave" "Ù") - ("Uacute" "U") - ("Ucircumflex" "Û") - ("Uuml" "Ü") - ("Yacute" "Y") - ("agrave" "à") - ("aacute" "a") - ("acircumflex" "â") - ("atilde" "a") - ("amul" "a") - ("aring" "a") - ("aeligature" "æ") - ("oeligature" "oe") - ("ccedilla" "ç") - ("egrave" "è") - ("eacute" "é") - ("ecircumflex" "ê") - ("euml" "e") - ("igrave" "i") - ("iacute" "i") - ("icircumflex" "î") - ("iuml" "i") - ("ntilde" "n") - ("ograve" "o") - ("oacute" "o") - ("ocurcumflex" "o") - ("otilde" "o") - ("ouml" "o") - ("divide" "/") - ("oslash" "o") - ("ugrave" "ù") - ("uacute" "u") - ("ucircumflex" "û") - ("uuml" "ü") - ("yacute" "y") - ("ymul" "y") - ;; punctuation - ("bullet" ".") - ("ellipsis" "...") - ("<-" "<-") - ("<--" "<--") - ("uparrow" "^;") - ("->" "->") - ("-->" "-->") - ("downarrow" "v") - ("<->" "<->") - ("<-->" "<-->") - ("<+" "<+") - ("<=" "<=;") - ("<==" "<==") - ("Uparrow" "^") - ("=>" "=>") - ("==>" "==>") - ("Downarrow" "v") - ("<=>" "<=>") - ("<==>" "<==>") - ;; Mathematical operators - ("asterisk" "*") - ("angle" "<") - ("and" "^;") - ("or" "v") - ("models" "|=") - ("vdash" "|-") - ("dashv" "-|") - ("sim" "~") - ("mid" "|") - ("langle" "<") - ("rangle" ">") - ;; LaTeX - ("circ" "o") - ("top" "T") - ("lhd" "<") - ("rhd" ">") - ("parallel" "||"))))) - -;*---------------------------------------------------------------------*/ -;* mark ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'symbol - :action (lambda (n e) - (let* ((s (markup-body n)) - (c (assoc s (engine-symbol-table e)))) - (if (pair? c) - (display (cadr c)) - (output s e))))) - -;*---------------------------------------------------------------------*/ -;* unref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'unref - :options 'all - :action (lambda (n e) - (let* ((s (markup-option n :skribe)) - (k (markup-option n 'kind)) - (f (cond - (s - (format "?~a@~a " k s)) - (else - (format "?~a " k)))) - (msg (list f (markup-body n))) - (n (list "[" (color :fg "red" (bold msg)) "]"))) - (skribe-eval n e)))) - -;*---------------------------------------------------------------------*/ -;* &the-bibliography ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-bibliography - :before (lambda (n e) - (let ((w (markup-writer-get 'table e))) - (and (writer? w) (invoke (writer-before w) n e)))) - :action (lambda (n e) - (when (pair? (markup-body n)) - (for-each (lambda (i) (output i e)) (markup-body n)))) - :after (lambda (n e) - (let ((w (markup-writer-get 'table e))) - (and (writer? w) (invoke (writer-after w) n e))))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry - :options '(:title) - :before (lambda (n e) - (invoke (writer-before (markup-writer-get 'tr e)) n e)) - :action (lambda (n e) - (let ((wtc (markup-writer-get 'tc e))) - ;; the label - (markup-option-add! n :valign 'top) - (markup-option-add! n :align 'right) - (invoke (writer-before wtc) n e) - (output n e (markup-writer-get '&bib-entry-label e)) - (invoke (writer-after wtc) n e) - ;; the body - (markup-option-add! n :valign 'top) - (markup-option-add! n :align 'left) - (invoke (writer-before wtc) n e) - (output n e (markup-writer-get '&bib-entry-body)) - (invoke (writer-after wtc) n e))) - :after (lambda (n e) - (invoke (writer-after (markup-writer-get 'tr e)) n e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before "[" - :action (lambda (n e) (output (markup-option n :title) e)) - :after "]") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-body ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-body - :action (lambda (n e) - (define (output-fields descr) - (let loop ((descr descr) - (pending #f) - (armed #f)) - (cond - ((null? descr) - 'done) - ((pair? (car descr)) - (if (eq? (caar descr) 'or) - (let ((o1 (cadr (car descr)))) - (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending - #t) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed)))) - (let ((o (markup-option n (cadr (car descr))))) - (if o - (begin - (if (and pending armed) - (output pending e)) - (output (caar descr) e) - (output o e) - (if (pair? (cddr (car descr))) - (output (caddr (car descr)) e)) - (loop (cdr descr) #f #t)) - (loop (cdr descr) pending armed))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (loop (cdr descr) #f #t)) - (loop (cdr descr) pending armed)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author " -- " (or title url documenturl) " -- " - number ", " institution ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((article) - `(author " -- " (or title url documenturl) " -- " - journal ", " volume "" ("(" number ")") ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author " -- " (or title url documenturl) " -- " - booktitle ", " series ", " ("(" number ")") ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((book) - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year ", " ("pp. " pages) ".")) - ((phdthesis) - '(author " -- " (or title url documenturl) " -- " type ", " - school ", " address - ", " month ", " year".")) - ((misc) - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year".")) - (else - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year ", " ("pp. " pages) ".")))))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-ident ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-ident - :action (lambda (n e) - (output (markup-option n 'number) e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-publisher ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-publisher - :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &the-index ... @label the-index@ */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index - :options '(:column) - :before (lambda (n e) - (output (markup-option n 'header) e)) - :action (lambda (n e) - (define (make-mark-entry n fst) - (let ((l (tr :class 'index-mark-entry - (td :colspan 2 :align 'left - (bold (it (sf n))))))) - (if fst - (list l) - (list (tr (td :colspan 2)) l)))) - (define (make-primary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (c (if note - (list b - (it (list " (" note ")"))) - b))) - (when p - (markup-option-add! b :text - (list (markup-option b :text) - ", p.")) - (markup-option-add! b :page #t)) - (tr :class 'index-primary-entry - (td :colspan 2 :valign 'top :align 'left c)))) - (define (make-secondary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) - (cond - ((not (or bb (is-markup? b 'url-ref))) - (skribe-error 'the-index - "Illegal entry" - b)) - (note - (let ((r (if bb - (it (ref :class "the-index-secondary" - :handle bb - :page p - :text (if p - (list note ", p.") - note))) - (it (ref :class "the-index-secondary" - :url (markup-option b :url) - :page p - :text (if p - (list note ", p.") - note)))))) - (tr :class 'index-secondary-entry - (td :valign 'top :align 'right :width 1. " ...") - (td :valign 'top :align 'left r)))) - (else - (let ((r (if bb - (ref :class "the-index-secondary" - :handle bb - :page p - :text (if p " ..., p." " ...")) - (ref :class "the-index-secondary" - :url (markup-option b :url) - :page p - :text (if p " ..., p." " ..."))))) - (tr :class 'index-secondary-entry - (td :valign 'top :align 'right :width 1.) - (td :valign 'top :align 'left r))))))) - (define (make-column ie p) - (let loop ((ie ie) - (f #t)) - (cond - ((null? ie) - '()) - ((not (pair? (car ie))) - (append (make-mark-entry (car ie) f) - (loop (cdr ie) #f))) - (else - (cons (make-primary-entry (caar ie) p) - (append (map (lambda (x) - (make-secondary-entry x p)) - (cdar ie)) - (loop (cdr ie) #f))))))) - (define (make-sub-tables ie nc p) - (let* ((l (length ie)) - (w (/ 100. nc)) - (iepc (let ((d (/ l nc))) - (if (integer? d) - (inexact->exact d) - (+ 1 (inexact->exact (truncate d)))))) - (split (list-split ie iepc))) - (tr (map (lambda (ies) - (td :valign 'top :width w - (if (pair? ies) - (table :width 100. (make-column ies p)) - ""))) - split)))) - (let* ((ie (markup-body n)) - (nc (markup-option n :column)) - (loc (ast-loc n)) - (pref (eq? (engine-custom e 'index-page-ref) #t)) - (t (cond - ((null? ie) - "") - ((or (not (integer? nc)) (= nc 1)) - (table :width 100. - :&skribe-eval-location loc - :class "index-table" - (make-column ie pref))) - (else - (table :width 100. - :&skribe-eval-location loc - :class "index-table" - (make-sub-tables ie nc pref)))))) - (output (skribe-eval t e) e)))) - -;*---------------------------------------------------------------------*/ -;* &the-index-header ... */ -;* ------------------------------------------------------------- */ -;* The index header is only useful for targets that support */ -;* hyperlinks such as HTML. */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header - :action (lambda (n e) #f)) - -;*---------------------------------------------------------------------*/ -;* &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") - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (n (markup-ident (handle-body (markup-body n))))) - (skribe-eval (it (if (integer? o) (+ o n) n)) e)))) - - - -;;;; A VIRER (mais handle-body n'est pas défini) -(markup-writer 'line-ref - :options '(:offset) - :action #f) diff --git a/skr/context.skr b/skr/context.skr deleted file mode 100644 index 5bc5316..0000000 --- a/skr/context.skr +++ /dev/null @@ -1,1380 +0,0 @@ -;;;; -;;;; context.skr -- ConTeXt mode for Skribe -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 23-Sep-2004 17:21 (eg) -;;;; Last file update: 3-Nov-2004 12:54 (eg) -;;;; - -;;;; ====================================================================== -;;;; context-customs ... -;;;; ====================================================================== -(define context-customs - '((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") - (index-page-ref #t) - (image-format ("jpg")) - (font-size 11) - (font-type "roman") - (user-style #f) - (document-style "book"))) - -;;;; ====================================================================== -;;;; context-encoding ... -;;;; ====================================================================== -(define context-encoding - '((#\# "\\type{#}") - (#\| "\\type{|}") - (#\{ "$\\{$") - (#\} "$\\}$") - (#\~ "\\type{~}") - (#\& "\\type{&}") - (#\_ "\\type{_}") - (#\^ "\\type{^}") - (#\[ "\\type{[}") - (#\] "\\type{]}") - (#\< "\\type{<}") - (#\> "\\type{>}") - (#\$ "\\type{$}") - (#\% "\\%") - (#\\ "$\\backslash$"))) - -;;;; ====================================================================== -;;;; context-pre-encoding ... -;;;; ====================================================================== -(define context-pre-encoding - (append '((#\space "~") - (#\~ "\\type{~}")) - context-encoding)) - - -;;;; ====================================================================== -;;;; context-symbol-table ... -;;;; ====================================================================== -(define (context-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{}") - ;; ConTeXt - ("dag" "\\dag") - ("ddag" "\\ddag") - ("circ" ,(math "\\circ")) - ("top" ,(math "\\top")) - ("bottom" ,(math "\\bot")) - ("lhd" ,(math "\\triangleleft")) - ("rhd" ,(math "\\triangleright")) - ("parallel" ,(math "\\parallel")))) - -;;;; ====================================================================== -;;;; context-width -;;;; ====================================================================== -(define (context-width width) - (cond - ((string? width) - width) - ((and (number? width) (inexact? width)) - (string-append (number->string (/ width 100.)) "\\textwidth")) - (else - (string-append (number->string width) "pt")))) - -;;;; ====================================================================== -;;;; context-dim -;;;; ====================================================================== -(define (context-dim dimension) - (cond - ((string? dimension) - dimension) - ((number? dimension) - (string-append (number->string (inexact->exact (round dimension))) - "pt")))) - -;;;; ====================================================================== -;;;; context-url -;;;; ====================================================================== -(define(context-url url text e) - (let ((name (gensym 'url)) - (text (or text url))) - (printf "\\useURL[~A][~A][][" name url) - (output text e) - (printf "]\\from[~A]" name))) - -;;;; ====================================================================== -;;;; Color Management ... -;;;; ====================================================================== -(define *skribe-context-color-table* (make-hashtable)) - -(define (skribe-color->context-color spec) - (receive (r g b) - (skribe-color->rgb spec) - (let ((ff (exact->inexact #xff))) - (format "r=~a,g=~a,b=~a" - (number->string (/ r ff)) - (number->string (/ g ff)) - (number->string (/ b ff)))))) - - -(define (skribe-declare-used-colors) - (printf "\n%%Colors\n") - (for-each (lambda (spec) - (let ((c (hashtable-get *skribe-context-color-table* spec))) - (unless (string? c) - ;; Color was never used before - (let ((name (symbol->string (gensym 'col)))) - (hashtable-put! *skribe-context-color-table* spec name) - (printf "\\definecolor[~A][~A]\n" - name - (skribe-color->context-color spec)))))) - (skribe-get-used-colors)) - (newline)) - -(define (skribe-declare-standard-colors engine) - (for-each (lambda (x) - (skribe-use-color! (engine-custom engine x))) - '(source-comment-color source-define-color source-module-color - source-markup-color source-thread-color source-string-color - source-bracket-color source-type-color))) - -(define (skribe-get-color spec) - (let ((c (and (hashtable? *skribe-context-color-table*) - (hashtable-get *skribe-context-color-table* spec)))) - (if (not (string? c)) - (skribe-error 'context "Can't find color" spec) - c))) - -;;;; ====================================================================== -;;;; context-engine ... -;;;; ====================================================================== -(define context-engine - (default-engine-set! - (make-engine 'context - :version 1.0 - :format "context" - :delegate (find-engine 'base) - :filter (make-string-replace context-encoding) - :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m))) - :custom context-customs))) - -;;;; ====================================================================== -;;;; document ... -;;;; ====================================================================== -(markup-writer 'document - :options '(:title :subtitle :author :ending :env) - :before (lambda (n e) - ;; Prelude - (printf "% interface=en output=pdftex\n") - (display "%%%% -*- TeX -*-\n") - (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n" - (skribe-release) (date)) - ;; Make URLs active - (printf "\\setupinteraction[state=start]\n") - ;; Choose the document font - (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) - (engine-custom e 'font-size)) - ;; Color - (display "\\setupcolors[state=start]\n") - ;; Load Style - (printf "\\input skribe-context-~a.tex\n" - (engine-custom e 'document-style)) - ;; Insert User customization - (let ((s (engine-custom e 'user-style))) - (when s (printf "\\input ~a\n" s))) - ;; Output used colors - (skribe-declare-standard-colors e) - (skribe-declare-used-colors) - - (display "\\starttext\n\\StartTitlePage\n") - ;; title - (let ((t (markup-option n :title))) - (when t - (skribe-eval (new markup - (markup '&context-title) - (body t) - (options - `((subtitle ,(markup-option n :subtitle))))) - e - :env `((parent ,n))))) - ;; author(s) - (let ((a (markup-option n :author))) - (when a - (if (list? a) - ;; List of authors. Use multi-columns - (begin - (printf "\\defineparagraphs[Authors][n=~A]\n" (length a)) - (display "\\startAuthors\n") - (let Loop ((l a)) - (unless (null? l) - (output (car l) e) - (unless (null? (cdr l)) - (display "\\nextAuthors\n") - (Loop (cdr l))))) - (display "\\stopAuthors\n\n")) - ;; One author, that's easy - (output a e)))) - ;; End of the title - (display "\\StopTitlePage\n")) - :after (lambda (n e) - (display "\n\\stoptext\n"))) - - - -;;;; ====================================================================== -;;;; &context-title ... -;;;; ====================================================================== -(markup-writer '&context-title - :before "{\\DocumentTitle{" - :action (lambda (n e) - (output (markup-body n) e) - (let ((sub (markup-option n 'subtitle))) - (when sub - (display "\\\\\n\\switchtobodyfont[16pt]\\it{") - (output sub e) - (display "}\n")))) - :after "}}") - -;;;; ====================================================================== -;;;; author ... -;;;; ====================================================================== -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :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)) - (out (lambda (n) - (output n e) - (display "\\\\\n")))) - (display "{\\midaligned{") - (when name (out name)) - (when title (out title)) - (when affiliation (out affiliation)) - (when (pair? address) (for-each out address)) - (when phone (out phone)) - (when email (out email)) - (when url (out url)) - (display "}}\n")))) - - -;;;; ====================================================================== -;;;; toc ... -;;;; ====================================================================== -(markup-writer 'toc - :options '() - :action (lambda (n e) (display "\\placecontent\n"))) - -;;;; ====================================================================== -;;;; context-block-before ... -;;;; ====================================================================== -(define (context-block-before name name-unnum) - (lambda (n e) - (let ((num (markup-option n :number))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a[~a]{" (if num name name-unnum) - (string-canonicalize (markup-ident n))) - (output (markup-option n :title) e) - (display "}\n")))) - - -;;;; ====================================================================== -;;;; chapter, section, ... -;;;; ====================================================================== -(markup-writer 'chapter - :options '(:title :number :toc :file :env) - :before (context-block-before 'chapter 'title)) - - -(markup-writer 'section - :options '(:title :number :toc :file :env) - :before (context-block-before 'section 'subject)) - - -(markup-writer 'subsection - :options '(:title :number :toc :file :env) - :before (context-block-before 'subsection 'subsubject)) - - -(markup-writer 'subsubsection - :options '(:title :number :toc :file :env) - :before (context-block-before 'subsubsection 'subsubsubject)) - -;;;; ====================================================================== -;;;; paragraph ... -;;;; ====================================================================== -(markup-writer 'paragraph - :options '(:title :number :toc :env) - :after "\\par\n") - -;;;; ====================================================================== -;;;; footnote ... -;;;; ====================================================================== -(markup-writer 'footnote - :before "\\footnote{" - :after "}") - -;;;; ====================================================================== -;;;; linebreak ... -;;;; ====================================================================== -(markup-writer 'linebreak - :action "\\crlf ") - -;;;; ====================================================================== -;;;; hrule ... -;;;; ====================================================================== -(markup-writer 'hrule - :options '(:width :height) - :before (lambda (n e) - (printf "\\blackrule[width=~A,height=~A]\n" - (context-width (markup-option n :width)) - (context-dim (markup-option n :height))))) - -;;;; ====================================================================== -;;;; color ... -;;;; ====================================================================== -(markup-writer 'color - :options '(:bg :fg :width :margin :border) - :before (lambda (n e) - (let ((bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (w (markup-option n :width)) - (m (markup-option n :margin)) - (b (markup-option n :border)) - (c (markup-option n :round-corner))) - (if (or bg w m b) - (begin - (printf "\\startframedtext[width=~a" (if w - (context-width w) - "fit")) - (printf ",rulethickness=~A" (if b (context-width b) "0pt")) - (when m - (printf ",offset=~A" (context-width m))) - (when bg - (printf ",background=color,backgroundcolor=~A" - (skribe-get-color bg))) - (when fg - (printf ",foregroundcolor=~A" - (skribe-get-color fg))) - (when c - (display ",framecorner=round")) - (printf "]\n")) - ;; Probably just a foreground was specified - (when fg - (printf "\\startcolor[~A] " (skribe-get-color fg)))))) - :after (lambda (n e) - (let ((bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (w (markup-option n :width)) - (m (markup-option n :margin)) - (b (markup-option n :border))) - (if (or bg w m b) - (printf "\\stopframedtext ") - (when fg - (printf "\\stopcolor ")))))) -;;;; ====================================================================== -;;;; frame ... -;;;; ====================================================================== -(markup-writer 'frame - :options '(:width :border :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (b (markup-option n :border)) - (c (markup-option n :round-corner))) - (printf "\\startframedtext[width=~a" (if w - (context-width w) - "fit")) - (printf ",rulethickness=~A" (context-dim b)) - (printf ",offset=~A" (context-width m)) - (when c - (display ",framecorner=round")) - (printf "]\n"))) - :after "\\stopframedtext ") - -;;;; ====================================================================== -;;;; font ... -;;;; ====================================================================== -(markup-writer 'font - :options '(:size) - :action (lambda (n e) - (let* ((size (markup-option n :size)) - (cs (engine-custom e 'font-size)) - (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 'context) - :delegate e - :filter (engine-filter e) - :symbol-table (engine-symbol-table e) - :custom `((font-size ,ns) - ,@(engine-customs e))))) - (printf "{\\switchtobodyfont[~apt]" ns) - (output (markup-body n) ne) - (display "}")))) - - -;;;; ====================================================================== -;;;; flush ... -;;;; ====================================================================== -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n\n\\midaligned{")) - ((left) - (display "\n\n\\leftaligned{")) - ((right) - (display "\n\n\\rightaligned{")))) - :after "}\n") - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before "\n\n\\midaligned{" - :after "}\n") - -;;;; ====================================================================== -;;;; pre ... -;;;; ====================================================================== -(markup-writer 'pre - :before "{\\tt\n\\startlines\n\\fixedspaces\n" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'context) - :delegate e - :filter (make-string-replace context-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after "\n\\stoplines\n}") - -;;;; ====================================================================== -;;;; prog ... -;;;; ====================================================================== -(markup-writer 'prog - :options '(:line :mark) - :before "{\\tt\n\\startlines\n\\fixedspaces\n" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'context) - :delegate e - :filter (make-string-replace context-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after "\n\\stoplines\n}") - - -;;;; ====================================================================== -;;;; itemize, enumerate ... -;;;; ====================================================================== -(define (context-itemization-action n e descr?) - (let ((symbol (markup-option n :symbol))) - (for-each (lambda (item) - (if symbol - (begin - (display "\\sym{") - (output symbol e) - (display "}")) - ;; output a \item iff not a description - (unless descr? - (display " \\item "))) - (output item e) - (newline)) - (markup-body n)))) - -(markup-writer 'itemize - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[serried]\n" - :action (lambda (n e) (context-itemization-action n e #f)) - :after "\\stopitemize\n\\stopnarrower\n") - - -(markup-writer 'enumerate - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[n][standard]\n" - :action (lambda (n e) (context-itemization-action n e #f)) - :after "\\stopitemize\n\\stopnarrower\n") - -;;;; ====================================================================== -;;;; description ... -;;;; ====================================================================== -(markup-writer 'description - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[serried]\n" - :action (lambda (n e) (context-itemization-action n e #t)) - :after "\\stopitemize\n\\stopnarrower\n") - -;;;; ====================================================================== -;;;; item ... -;;;; ====================================================================== -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (when k - ;; Output the key(s) - (let Loop ((l (if (pair? k) k (list k)))) - (unless (null? l) - (output (bold (car l)) e) - (unless (null? (cdr l)) - (display "\\crlf\n")) - (Loop (cdr l)))) - (display "\\nowhitespace\\startnarrower[left]\n")) - ;; Output body - (output (markup-body n) e) - ;; Terminate - (when k - (display "\n\\stopnarrower\n"))))) - -;;;; ====================================================================== -;;;; blockquote ... -;;;; ====================================================================== -(markup-writer 'blockquote - :before "\n\\startnarrower[left,right]\n" - :after "\n\\stopnarrower\n") - - -;;;; ====================================================================== -;;;; 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))) - (unless number - (display "{\\setupcaptions[number=off]\n")) - (display "\\placefigure\n") - (printf " [~a]\n" (string-canonicalize ident)) - (display " {") (output legend e) (display "}\n") - (display " {") (output (markup-body n) e) (display "}") - (unless number - (display "}\n"))))) - -;;;; ====================================================================== -;;;; table ... -;;;; ====================================================================== - ;; width doesn't work -(markup-writer 'table - :options '(:width :border :frame :rules :cellpadding) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (cp (markup-option n :cellpadding)) - (cs (markup-option n :cellspacing))) - (printf "\n{\\bTABLE\n") - (printf "\\setupTABLE[") - (printf "width=~A" (if width (context-width width) "fit")) - (when border - (printf ",rulethickness=~A" (context-dim border))) - (when cp - (printf ",offset=~A" (context-width cp))) - (printf ",frame=off]\n") - - (when rules - (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n") - (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n")) - (case rules - ((rows) (display hor)) - ((cols) (display vert)) - ((all) (display hor) (display vert))))) - - (when frame - ;; hsides, vsides, lhs, rhs, box, border - (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n") - (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n") - (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n") - (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n")) - (case frame - ((above) (display top)) - ((below) (display bot)) - ((hsides) (display top) (display bot)) - ((lhs) (display left)) - ((rhs) (display right)) - ((vsides) (display left) (diplay right)) - ((box border) (display top) (display bot) - (display left) (display right))))))) - - :after (lambda (n e) - (printf "\\eTABLE}\n"))) - - -;;;; ====================================================================== -;;;; tr ... -;;;; ====================================================================== -(markup-writer 'tr - :options '(:bg) - :before (lambda (n e) - (display "\\bTR") - (let ((bg (markup-option n :bg))) - (when bg - (printf "[background=color,backgroundcolor=~A]" - (skribe-get-color bg))))) - :after "\\eTR\n") - - -;;;; ====================================================================== -;;;; tc ... -;;;; ====================================================================== -(markup-writer 'tc - :options '(:width :align :valign :colspan) - :before (lambda (n e) - (let ((th? (eq? 'th (markup-option n 'markup))) - (width (markup-option n :width)) - (align (markup-option n :align)) - (valign (markup-option n :valign)) - (colspan (markup-option n :colspan)) - (rowspan (markup-option n :rowspan)) - (bg (markup-option n :bg))) - (printf "\\bTD[") - (printf "width=~a" (if width (context-width width) "fit")) - (when valign - ;; This is buggy. In fact valign an align can't be both - ;; specified in ConTeXt - (printf ",align=~a" (case valign - ((center) 'lohi) - ((bottom) 'low) - ((top) 'high)))) - (when align - (printf ",align=~a" (case align - ((left) 'right) ; !!!! - ((right) 'left) ; !!!! - (else 'middle)))) - (unless (equal? colspan 1) - (printf ",nx=~a" colspan)) - (display "]") - (when th? - ;; This is a TH, output is bolded - (display "{\\bf{")))) - - :after (lambda (n e) - (when (equal? (markup-option n 'markup) 'th) - ;; This is a TH, output is bolded - (display "}}")) - (display "\\eTD"))) - -;;;; ====================================================================== -;;;; 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 - '("jpg")))))) - (if (not (string? img)) - (skribe-error 'context "Illegal image" file) - (begin - (printf "\\externalfigure[~A][frame=off" (strip-ref-base img)) - (if zoom (printf ",factor=~a" (inexact->exact zoom))) - (if width (printf ",width=~a" (context-width width))) - (if height (printf ",height=~apt" (context-dim height))) - (display "]")))))) - - -;;;; ====================================================================== -;;;; Ornaments ... -;;;; ====================================================================== -(markup-writer 'roman :before "{\\rm{" :after "}}") -(markup-writer 'bold :before "{\\bf{" :after "}}") -(markup-writer 'underline :before "{\\underbar{" :after "}}") -(markup-writer 'emph :before "{\\em{" :after "}}") -(markup-writer 'it :before "{\\it{" :after "}}") -(markup-writer 'code :before "{\\tt{" :after "}}") -(markup-writer 'var :before "{\\tt{" :after "}}") -(markup-writer 'sc :before "{\\sc{" :after "}}") -;;//(markup-writer 'sf :before "{\\sf{" :after "}}") -(markup-writer 'sub :before "{\\low{" :after "}}") -(markup-writer 'sup :before "{\\high{" :after "}}") - - -;;// -;;//(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 ... -;;;; ====================================================================== -(markup-writer 'q - :before "\\quotation{" - :after "}") - -;;;; ====================================================================== -;;;; mailto ... -;;;; ====================================================================== -(markup-writer 'mailto - :options '(:text) - :action (lambda (n e) - (let ((text (markup-option n :text)) - (url (markup-body n))) - (when (pair? url) - (context-url (format "mailto:~A" (car url)) - (or text - (car url)) - e))))) -;;;; ====================================================================== -;;;; mark ... -;;;; ====================================================================== -(markup-writer 'mark - :before (lambda (n e) - (printf "\\reference[~a]{}\n" - (string-canonicalize (markup-ident n))))) - -;;;; ====================================================================== -;;;; ref ... -;;;; ====================================================================== -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection - :figure :mark :handle :page) - :action (lambda (n e) - (let* ((text (markup-option n :text)) - (page (markup-option n :page)) - (c (handle-ast (markup-body n))) - (id (markup-ident c))) - (cond - (page ;; Output the page only (this is a hack) - (when text (output text e)) - (printf "\\at[~a]" - (string-canonicalize id))) - ((or (markup-option n :chapter) - (markup-option n :section) - (markup-option n :subsection) - (markup-option n :subsubsection)) - (if text - (printf "\\goto{~a}[~a]" (or text id) - (string-canonicalize id)) - (printf "\\in[~a]" (string-canonicalize id)))) - ((markup-option n :mark) - (printf "\\goto{~a}[~a]" - (or text id) - (string-canonicalize id))) - (else ;; Output a little image indicating the direction - (printf "\\in[~a]" (string-canonicalize id))))))) - -;;;; ====================================================================== -;;;; bib-ref ... -;;;; ====================================================================== -(markup-writer 'bib-ref - :options '(:text :bib) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) - (let* ((obj (handle-ast (markup-body n))) - (title (markup-option obj :title)) - (ref (markup-option title 'number)) - (ident (markup-ident obj))) - (printf "\\goto{~a}[~a]" ref (string-canonicalize ident)))) - :after (lambda (n e) (output "]" e))) - -;;;; ====================================================================== -;;;; bib-ref+ ... -;;;; ====================================================================== -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before (lambda (n e) (output "[" e)) - :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 (lambda (n e) (output "]" e))) - -;;;; ====================================================================== -;;;; url-ref ... -;;;; ====================================================================== -(markup-writer 'url-ref - :options '(:url :text) - :action (lambda (n e) - (context-url (markup-option n :url) (markup-option n :text) e))) - -;;//;*---------------------------------------------------------------------*/ -;;//;* 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 "\n% Bibliography\n\n") - - -;;;; ====================================================================== -;;;; &bib-entry ... -;;;; ====================================================================== -(markup-writer '&bib-entry - :options '(:title) - :action (lambda (n e) - (skribe-eval (mark (markup-ident n)) e) - (output n e (markup-writer-get '&bib-entry-label e)) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n\n") - -;;;; ====================================================================== -;;;; &bib-entry-label ... -;;;; ====================================================================== -(markup-writer '&bib-entry-label - :options '(:title) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) (output (markup-option n :title) e)) - :after (lambda (n e) (output "] "e))) - -;;;; ====================================================================== -;;;; &bib-entry-title ... -;;;; ====================================================================== -(markup-writer '&bib-entry-title - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url)) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - - -;;//;*---------------------------------------------------------------------*/ -;;//;* &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)))) - - -;;;; ====================================================================== -;;;; &the-index ... -;;;; ====================================================================== -(markup-writer '&the-index - :options '(:column) - :action - (lambda (n e) - (define (make-mark-entry n) - (display "\\blank[medium]\n{\\bf\\it\\tfc{") - (skribe-eval (bold n) e) - (display "}}\\crlf\n")) - - (define (make-primary-entry n) - (let ((b (markup-body n))) - (markup-option-add! b :text (list (markup-option b :text) ", ")) - (markup-option-add! b :page #t) - (output n e))) - - (define (make-secondary-entry n) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) - (if note - (begin ;; This is another entry - (display "\\crlf\n ... ") - (markup-option-add! b :text (list note ", "))) - (begin ;; another line on an entry - (markup-option-add! b :text ", "))) - (markup-option-add! b :page #t) - (output n e))) - - ;; Writer body starts here - (let ((col (markup-option n :column))) - (when col - (printf "\\startcolumns[n=~a]\n" col)) - (for-each (lambda (item) - ;;(DEBUG "ITEM= ~S" item) - (if (pair? item) - (begin - (make-primary-entry (car item)) - (for-each (lambda (x) (make-secondary-entry x)) - (cdr item))) - (make-mark-entry item)) - (display "\\crlf\n")) - (markup-body n)) - (when col - (printf "\\stopcolumns\n"))))) - -;;;; ====================================================================== -;;;; &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 (it (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 (it n1)) - (it 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)))) - - - -;;;; ====================================================================== -;;;; Context Only Markups -;;;; ====================================================================== - -;;; -;;; Margin -- put text in the margin -;;; -(define-markup (margin #!rest opts #!key (ident #f) (class "margin") - (side 'right) text) - (new markup - (markup 'margin) - (ident (or ident (symbol->string (gensym 'ident)))) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -(markup-writer 'margin - :options '(:text) - :before (lambda (n e) - (display - "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n") - (display "\\inright{") - (output (markup-option n :text) e) - (display "}{")) - :after "}") - -;;; -;;; ConTeXt and TeX -;;; -(define-markup (ConTeXt #!key (space #t)) - (if (engine-format? "context") - (! (if space "\\CONTEXT\\ " "\\CONTEXT")) - "ConTeXt")) - -(define-markup (TeX #!key (space #t)) - (if (engine-format? "context") - (! (if space "\\TEX\\ " "\\TEX")) - "ConTeXt")) - -;;;; ====================================================================== -;;;; Restore the base engine -;;;; ====================================================================== -(default-engine-set! (find-engine 'base)) diff --git a/skr/html.skr b/skr/html.skr deleted file mode 100644 index 79186ca..0000000 --- a/skr/html.skr +++ /dev/null @@ -1,2271 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/html.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 12:28:57 2003 */ -;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* HTML Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/htmle.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html-file-default ... */ -;*---------------------------------------------------------------------*/ -(define html-file-default - ;; Default implementation of the `file-name-proc' custom. - (let ((table '()) - (filename (gensym))) - (define (get-file-name base suf) - (let* ((c (assoc base table)) - (n (if (pair? c) - (let ((n (+ 1 (cdr c)))) - (set-cdr! c n) - n) - (begin - (set! table (cons (cons base 1) table)) - 1)))) - (format "~a-~a.~a" base n suf))) - (lambda (node e) - (let ((f (markup-option node filename)) - (file (markup-option node :file))) - (cond - ((string? f) - f) - ((string? file) - file) - ((or file - (and (is-markup? node 'chapter) - (engine-custom e 'chapter-file)) - (and (is-markup? node 'section) - (engine-custom e 'section-file)) - (and (is-markup? node 'subsection) - (engine-custom e 'subsection-file)) - (and (is-markup? node 'subsubsection) - (engine-custom e 'subsubsection-file))) - (let* ((b (or (and (string? *skribe-dest*) - (prefix *skribe-dest*)) - "")) - (s (or (and (string? *skribe-dest*) - (suffix *skribe-dest*)) - "html")) - (nm (get-file-name b s))) - (markup-option-add! node filename nm) - nm)) - ((document? node) - *skribe-dest*) - (else - (let ((p (ast-parent node))) - (if (container? p) - (let ((file (html-file p e))) - (if (string? file) - (begin - (markup-option-add! node filename file) - file) - #f)) - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* html-engine ... */ -;*---------------------------------------------------------------------*/ -(define html-engine - ;; setup the html engine - (default-engine-set! - (make-engine 'html - :version 1.0 - :format "html" - :delegate (find-engine 'base) - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@"))) - :custom `(;; the icon associated with the URL - (favicon #f) - ;; charset used - (charset "ISO-8859-1") - ;; enable/disable Javascript - (javascript #f) - ;; user html head - (head #f) - ;; user CSS - (css ()) - ;; user inlined CSS - (inline-css ()) - ;; user JS - (js ()) - ;; emit-sui - (emit-sui #f) - ;; the body - (background "#ffffff") - (foreground #f) - ;; the margins - (margin-padding 3) - (left-margin #f) - (chapter-left-margin #f) - (section-left-margin #f) - (left-margin-font #f) - (left-margin-size 17.) - (left-margin-background "#dedeff") - (left-margin-foreground #f) - (right-margin #f) - (chapter-right-margin #f) - (section-right-margin #f) - (right-margin-font #f) - (right-margin-size 17.) - (right-margin-background "#dedeff") - (right-margin-foreground #f) - ;; author configuration - (author-font #f) - ;; title configuration - (title-font #f) - (title-background "#8381de") - (title-foreground #f) - (file-title-separator " -- ") - ;; html file naming - (file-name-proc ,html-file-default) - ;; index configuration - (index-header-font-size +2.) - ;; chapter configuration - (chapter-number->string number->string) - (chapter-file #f) - ;; section configuration - (section-title-start "<h3>") - (section-title-stop "</h3>") - (section-title-background "#dedeff") - (section-title-foreground "black") - (section-title-number-separator " ") - (section-number->string number->string) - (section-file #f) - ;; subsection configuration - (subsection-title-start "<h3>") - (subsection-title-stop "</h3>") - (subsection-title-background "#ffffff") - (subsection-title-foreground "#8381de") - (subsection-title-number-separator " ") - (subsection-number->string number->string) - (subsection-file #f) - ;; subsubsection configuration - (subsubsection-title-start "<h4>") - (subsubsection-title-stop "</h4>") - (subsubsection-title-background #f) - (subsubsection-title-foreground "#8381de") - (subsubsection-title-number-separator " ") - (subsubsection-number->string number->string) - (subsubsection-file #f) - ;; 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 - (image-format ("png" "gif" "jpg" "jpeg"))) - :symbol-table '(("iexcl" "¡") - ("cent" "¢") - ("pound" "£") - ("currency" "¤") - ("yen" "¥") - ("section" "§") - ("mul" "¨") - ("copyright" "©") - ("female" "ª") - ("lguillemet" "«") - ("not" "¬") - ("registered" "®") - ("degree" "°") - ("plusminus" "±") - ("micro" "µ") - ("paragraph" "¶") - ("middot" "·") - ("male" "¸") - ("rguillemet" "»") - ("1/4" "¼") - ("1/2" "½") - ("3/4" "¾") - ("iquestion" "¿") - ("Agrave" "À") - ("Aacute" "Á") - ("Acircumflex" "Â") - ("Atilde" "Ã") - ("Amul" "Ä") - ("Aring" "Å") - ("AEligature" "Æ") - ("Oeligature" "Œ") - ("Ccedilla" "Ç") - ("Egrave" "È") - ("Eacute" "É") - ("Ecircumflex" "Ê") - ("Euml" "Ë") - ("Igrave" "Ì") - ("Iacute" "Í") - ("Icircumflex" "Î") - ("Iuml" "Ï") - ("ETH" "Ð") - ("Ntilde" "Ñ") - ("Ograve" "Ò") - ("Oacute" "Ó") - ("Ocurcumflex" "Ô") - ("Otilde" "Õ") - ("Ouml" "Ö") - ("times" "×") - ("Oslash" "Ø") - ("Ugrave" "Ù") - ("Uacute" "Ú") - ("Ucircumflex" "Û") - ("Uuml" "Ü") - ("Yacute" "Ý") - ("THORN" "Þ") - ("szlig" "ß") - ("agrave" "à") - ("aacute" "á") - ("acircumflex" "â") - ("atilde" "ã") - ("amul" "ä") - ("aring" "å") - ("aeligature" "æ") - ("oeligature" "œ") - ("ccedilla" "ç") - ("egrave" "è") - ("eacute" "é") - ("ecircumflex" "ê") - ("euml" "ë") - ("igrave" "ì") - ("iacute" "í") - ("icircumflex" "î") - ("iuml" "ï") - ("eth" "ð") - ("ntilde" "ñ") - ("ograve" "ò") - ("oacute" "ó") - ("ocurcumflex" "ô") - ("otilde" "õ") - ("ouml" "ö") - ("divide" "÷") - ("oslash" "ø") - ("ugrave" "ù") - ("uacute" "ú") - ("ucircumflex" "û") - ("uuml" "ü") - ("yacute" "ý") - ("thorn" "þ") - ("ymul" "ÿ") - ;; Greek - ("Alpha" "Α") - ("Beta" "Β") - ("Gamma" "Γ") - ("Delta" "Δ") - ("Epsilon" "Ε") - ("Zeta" "Ζ") - ("Eta" "Η") - ("Theta" "Θ") - ("Iota" "Ι") - ("Kappa" "Κ") - ("Lambda" "Λ") - ("Mu" "Μ") - ("Nu" "Ν") - ("Xi" "Ξ") - ("Omicron" "Ο") - ("Pi" "Π") - ("Rho" "Ρ") - ("Sigma" "Σ") - ("Tau" "Τ") - ("Upsilon" "Υ") - ("Phi" "Φ") - ("Chi" "Χ") - ("Psi" "Ψ") - ("Omega" "Ω") - ("alpha" "α") - ("beta" "β") - ("gamma" "γ") - ("delta" "δ") - ("epsilon" "ε") - ("zeta" "ζ") - ("eta" "η") - ("theta" "θ") - ("iota" "ι") - ("kappa" "κ") - ("lambda" "λ") - ("mu" "μ") - ("nu" "ν") - ("xi" "ξ") - ("omicron" "ο") - ("pi" "π") - ("rho" "ρ") - ("sigmaf" "ς") - ("sigma" "σ") - ("tau" "τ") - ("upsilon" "υ") - ("phi" "φ") - ("chi" "χ") - ("psi" "ψ") - ("omega" "ω") - ("thetasym" "ϑ") - ("piv" "ϖ") - ;; punctuation - ("bullet" "•") - ("ellipsis" "…") - ("weierp" "℘") - ("image" "ℑ") - ("real" "ℜ") - ("tm" "™") - ("alef" "ℵ") - ("<-" "←") - ("<--" "←") - ("uparrow" "↑") - ("->" "→") - ("-->" "→") - ("downarrow" "↓") - ("<->" "↔") - ("<-->" "↔") - ("<+" "↵") - ("<=" "⇐") - ("<==" "⇐") - ("Uparrow" "⇑") - ("=>" "⇒") - ("==>" "⇒") - ("Downarrow" "⇓") - ("<=>" "⇔") - ("<==>" "⇔") - ;; Mathematical operators - ("forall" "∀") - ("partial" "∂") - ("exists" "∃") - ("emptyset" "∅") - ("infinity" "∞") - ("nabla" "∇") - ("in" "∈") - ("notin" "∉") - ("ni" "∋") - ("prod" "∏") - ("sum" "∑") - ("asterisk" "∗") - ("sqrt" "√") - ("propto" "∝") - ("angle" "∠") - ("and" "∧") - ("or" "∨") - ("cap" "∩") - ("cup" "∪") - ("integral" "∫") - ("therefore" "∴") - ("models" "|=") - ("vdash" "|-") - ("dashv" "-|") - ("sim" "∼") - ("cong" "≅") - ("approx" "≈") - ("neq" "≠") - ("equiv" "≡") - ("le" "≤") - ("ge" "≥") - ("subset" "⊂") - ("supset" "⊃") - ("nsupset" "⊃") - ("subseteq" "⊆") - ("supseteq" "⊇") - ("oplus" "⊕") - ("otimes" "⊗") - ("perp" "⊥") - ("mid" "|") - ("lceil" "⌈") - ("rceil" "⌉") - ("lfloor" "⌊") - ("rfloor" "⌋") - ("langle" "〈") - ("rangle" "〉") - ;; Misc - ("loz" "◊") - ("spades" "♠") - ("clubs" "♣") - ("hearts" "♥") - ("diams" "♦") - ("euro" "ℐ") - ;; LaTeX - ("dag" "dag") - ("ddag" "ddag") - ("circ" "o") - ("top" "T") - ("bottom" "⊥") - ("lhd" "<") - ("rhd" ">") - ("parallel" "||"))))) - -;*---------------------------------------------------------------------*/ -;* html-file ... */ -;*---------------------------------------------------------------------*/ -(define (html-file n e) - (let ((proc (or (engine-custom e 'file-name-proc) html-file-default))) - (proc n e))) - -;*---------------------------------------------------------------------*/ -;* html-title-engine ... */ -;*---------------------------------------------------------------------*/ -(define html-title-engine - (copy-engine 'html-title base-engine - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """))))) - -;*---------------------------------------------------------------------*/ -;* html-browser-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-browser-title n) - (and (markup? n) - (or (markup-option n :html-title) - (if (document? n) - (markup-option n :title) - (html-browser-title (ast-parent n)))))) - - -;*---------------------------------------------------------------------*/ -;* html-container-number ... */ -;* ------------------------------------------------------------- */ -;* Returns a string representing the container number */ -;*---------------------------------------------------------------------*/ -(define (html-container-number c e) - (define (html-number n proc) - (cond - ((string? n) - n) - ((number? n) - (if (procedure? proc) - (proc n) - (number->string n))) - (else - ""))) - (define (html-chapter-number c) - (html-number (markup-option c :number) - (engine-custom e 'chapter-number->string))) - (define (html-section-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'section-number->string)))) - (cond - ((is-markup? p 'chapter) - (string-append (html-chapter-number p) "." s)) - (else - (string-append s))))) - (define (html-subsection-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'subsection-number->string)))) - (cond - ((is-markup? p 'section) - (string-append (html-section-number p) "." s)) - (else - (string-append "." s))))) - (define (html-subsubsection-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'subsubsection-number->string)))) - (cond - ((is-markup? p 'subsection) - (string-append (html-subsection-number p) "." s)) - (else - (string-append ".." s))))) - (define (inner-html-container-number c) - (html-number (markup-option c :number) #f)) - (let ((n (markup-option c :number))) - (if (not n) - "" - (case (markup-markup c) - ((chapter) - (html-chapter-number c)) - ((section) - (html-section-number c)) - ((subsection) - (html-subsection-number c)) - ((subsubsection) - (html-subsubsection-number c)) - (else - (if (container? c) - (inner-html-container-number c) - (skribe-error 'html-container-number - "Not a container" - (markup-markup c)))))))) - -;*---------------------------------------------------------------------*/ -;* html-counter ... */ -;*---------------------------------------------------------------------*/ -(define (html-counter cnts) - (cond - ((not cnts) - "") - ((null? cnts) - "") - ((not (pair? cnts)) - cnts) - ((null? (cdr cnts)) - (format "~a." (car cnts))) - (else - (let loop ((cnts cnts)) - (if (null? (cdr cnts)) - (format "~a" (car cnts)) - (format "~a.~a" (car cnts) (loop (cdr cnts)))))))) - -;*---------------------------------------------------------------------*/ -;* html-width ... */ -;*---------------------------------------------------------------------*/ -(define (html-width width) - (cond - ((and (integer? width) (exact? width)) - (format "~A" width)) - ((real? width) - (format "~A%" (inexact->exact (round width)))) - ((string? width) - width) - (else - (skribe-error 'html-width "bad width" width)))) - -;*---------------------------------------------------------------------*/ -;* html-class ... */ -;*---------------------------------------------------------------------*/ -(define (html-class m) - (if (markup? m) - (let ((c (markup-class m))) - (if (or (string? c) (symbol? c) (number? c)) - (printf " class=\"~a\"" c))))) - -;*---------------------------------------------------------------------*/ -;* html-markup-class ... */ -;*---------------------------------------------------------------------*/ -(define (html-markup-class m) - (lambda (n e) - (printf "<~a" m) - (html-class n) - (display ">"))) - -;*---------------------------------------------------------------------*/ -;* html-color-spec? ... */ -;*---------------------------------------------------------------------*/ -(define (html-color-spec? v) - (and v - (not (unspecified? v)) - (or (not (string? v)) (> (string-length v) 0)))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'document - :options '(:title :author :ending :html-title :env) - :action (lambda (n e) - (let* ((id (markup-ident n)) - (title (new markup - (markup '&html-document-title) - (parent n) - (ident (string-append id "-title")) - (class (markup-class n)) - (options `((author ,(markup-option n :author)))) - (body (markup-option n :title))))) - (&html-generic-document n title e))) - :after (lambda (n e) - (if (engine-custom e 'emit-sui) - (document-sui n e)))) - -;*---------------------------------------------------------------------*/ -;* &html-html ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-html - :before "<!-- 95% W3C COMPLIANT, 95% CSS FREE, RAW HTML --> -<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> -<html>\n" - :after "</html>") - -;*---------------------------------------------------------------------*/ -;* &html-head ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-head - :before (lambda (n e) - (printf "<head>\n") - (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;") - (printf "charset=~A\">\n" (engine-custom (find-engine 'html) - 'charset))) - :after "</head>\n\n") - -;*---------------------------------------------------------------------*/ -;* &html-body ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-body - :before (lambda (n e) - (let ((bg (engine-custom e 'background))) - (display "<body") - (html-class n) - (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) - (display ">\n"))) - :after "</body>\n") - -;*---------------------------------------------------------------------*/ -;* &html-page ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-page - :action (lambda (n e) - (define (html-margin m fn size bg fg cla) - (printf "<td align=\"left\" valign=\"top\" class=\"~a\"" cla) - (if size - (printf " width=\"~a\"" (html-width size))) - (if (html-color-spec? bg) - (printf " bgcolor=\"~a\">" bg) - (display ">")) - (printf "<div class=\"~a\">\n" cla) - (cond - ((and (string? fg) (string? fn)) - (printf "<font color=\"~a\" \"~a\">" fg fn)) - ((string? fg) - (printf "<font color=\"~a\">" fg)) - ((string? fn) - (printf "<font \"~a\">" fn))) - (if (procedure? m) - (skribe-eval (m n e) e) - (output m e)) - (if (or (string? fg) (string? fn)) - (display "</font>")) - (display "</div></td>\n")) - (let ((body (markup-body n)) - (lm (engine-custom e 'left-margin)) - (lmfn (engine-custom e 'left-margin-font)) - (lms (engine-custom e 'left-margin-size)) - (lmbg (engine-custom e 'left-margin-background)) - (lmfg (engine-custom e 'left-margin-foreground)) - (rm (engine-custom e 'right-margin)) - (rmfn (engine-custom e 'right-margin-font)) - (rms (engine-custom e 'right-margin-size)) - (rmbg (engine-custom e 'right-margin-background)) - (rmfg (engine-custom e 'right-margin-foreground))) - (cond - ((and lm rm) - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac)) - (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") - (html-margin body #f #f #f #f "skribe-body") - (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") - (display "</tr></table>")) - (lm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac)) - (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") - (html-margin body #f #f #f #f "skribe-body") - (display "</tr></table>")) - (rm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n")) - (html-margin body #f #f #f #f "skribe-body") - (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") - (display "</tr></table>")) - (else - (display "<div class=\"skribe-body\">\n") - (output body e) - (display "</div>\n")))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-header ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-header n e) - (let* ((ic (engine-custom e 'favicon)) - (id (markup-ident n))) - (unless (string? id) - (skribe-error '&html-generic-header - (format "Illegal identifier `~a'" id) - n)) - ;; title - (output (new markup - (markup '&html-header-title) - (parent n) - (ident (string-append id "-title")) - (class (markup-class n)) - (body (markup-body n))) - e) - ;; favicon - (output (new markup - (markup '&html-header-favicon) - (parent n) - (ident (string-append id "-favicon")) - (body (cond - ((string? ic) - ic) - ((procedure? ic) - (ic d e))))) - e) - ;; style - (output (new markup - (markup '&html-header-style) - (parent n) - (ident (string-append id "-style")) - (class (markup-class n))) - e) - ;; css - (output (new markup - (markup '&html-header-css) - (parent n) - (ident (string-append id "-css")) - (body (let ((c (engine-custom e 'css))) - (if (string? c) - (list c) - c)))) - e) - ;; javascript - (output (new markup - (markup '&html-header-javascript) - (parent n) - (ident (string-append id "-javascript"))) - e))) - -(markup-writer '&html-header-title - :before "<title>" - :action (lambda (n e) - (output (markup-body n) html-title-engine)) - :after "</title>\n") - -(markup-writer '&html-header-favicon - :action (lambda (n e) - (let ((i (markup-body n))) - (when i - (printf " <link rel=\"shortcut icon\" href=~s>\n" i))))) - -(markup-writer '&html-header-css - :action (lambda (n e) - (let ((css (markup-body n))) - (when (pair? css) - (for-each (lambda (css) - (printf " <link href=~s rel=\"stylesheet\" type=\"text/css\">\n" css)) - css))))) - -(markup-writer '&html-header-style - :before " <style type=\"text/css\">\n <!--\n" - :action (lambda (n e) - (let ((hd (engine-custom e 'head)) - (icss (let ((ic (engine-custom e 'inline-css))) - (if (string? ic) - (list ic) - ic)))) - (display " pre { font-family: monospace }\n") - (display " tt { font-family: monospace }\n") - (display " code { font-family: monospace }\n") - (display " p.flushright { text-align: right }\n") - (display " p.flushleft { text-align: left }\n") - (display " span.sc { font-variant: small-caps }\n") - (display " span.sf { font-family: sans-serif }\n") - (display " span.skribetitle { font-family: sans-serif; font-weight: bolder; font-size: x-large; }\n") - (when hd (display (format " ~a\n" hd))) - (when (pair? icss) - (for-each (lambda (css) - (let ((p (open-input-file css))) - (if (not (input-port? p)) - (skribe-error - 'html-css - "Can't open CSS file for input" - css) - (begin - (let loop ((l (read-line p))) - (unless (eof-object? l) - (display l) - (newline) - (loop (read-line p)))) - (close-input-port p))))) - icss)))) - :after " -->\n </style>\n") - -(markup-writer '&html-header-javascript - :action (lambda (n e) - (when (engine-custom e 'javascript) - (display " <script language=\"JavaScript\" type=\"text/javascript\">\n") - (display " <!--\n") - (display " function skribenospam( n, d, f ) {\n") - (display " nn=n.replace( / /g , \".\" );\n" ) - (display " dd=d.replace( / /g , \".\" );\n" ) - (display " document.write( \"<a href=\\\"mailto:\" + nn + \"@\" + dd + \"\\\">\" );\n") - (display " if( f ) {\n") - (display " document.write( \"<tt>\" + nn + \"@\" + dd + \"</\" + \"tt><\" + \"/a>\" );\n") - (display " }\n") - (display " }\n") - (display " -->\n") - (display " </script>\n")) - (let* ((ejs (engine-custom e 'js)) - (js (cond - ((string? ejs) - (list ejs)) - ((list? ejs) - ejs) - (else - '())))) - (for-each (lambda (s) - (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s)) - js)))) - - -;*---------------------------------------------------------------------*/ -;* &html-header ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-document-header :action &html-generic-header) -(markup-writer '&html-chapter-header :action &html-generic-header) -(markup-writer '&html-section-header :action &html-generic-header) -(markup-writer '&html-subsection-header :action &html-generic-header) -(markup-writer '&html-subsubsection-header :action &html-generic-header) - -;*---------------------------------------------------------------------*/ -;* &html-ending ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-ending - :before "<div class=\"skribe-ending\">" - :action (lambda (n e) - (let ((body (markup-body n))) - (if body - (output body #t) - (skribe-eval [ -,(hrule) -,(p :class "ending" (font :size -1 [ -This ,(sc "Html") page has been produced by -,(ref :url (skribe-url) :text "Skribe"). -,(linebreak) -Last update ,(it (date)).]))] e)))) - :after "</div>\n") - -;*---------------------------------------------------------------------*/ -;* &html-generic-title ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (when title - (display "<table width=\"100%\" class=\"skribetitle\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>") - (if (html-color-spec? tbg) - (printf "<td align=\"center\" bgcolor=\"~a\">" tbg) - (display "<td align=\"center\">")) - (if (string? tfg) - (printf "<font color=\"~a\">" tfg)) - (when title - (if (string? tfont) - (begin - (printf "<font ~a><strong>" tfont) - (output title e) - (display "</strong></font>")) - (begin - (printf "<div class=\"skribetitle\"><strong><big><big><big>") - (output title e) - (display "</big></big></big></strong></div>")))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "</font>")) - (display "</td></tr></tbody></table>\n")))) - -;*---------------------------------------------------------------------*/ -;* &html-document-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-document-title :action &html-generic-title) -(markup-writer '&html-chapter-title :action &html-generic-title) -(markup-writer '&html-section-title :action &html-generic-title) -(markup-writer '&html-subsection-title :action &html-generic-title) -(markup-writer '&html-subsubsection-title :action &html-generic-title) - -;*---------------------------------------------------------------------*/ -;* &html-footnotes */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-footnotes - :before (lambda (n e) - (let ((footnotes (markup-body n))) - (when (pair? footnotes) - (display "<div class=\"footnote\">") - (display "<br><br>\n") - (display "<hr width='20%' size='2' align='left'>\n")))) - :action (lambda (n e) - (let ((footnotes (markup-body n))) - (when (pair? footnotes) - (let loop ((fns footnotes)) - (if (pair? fns) - (let ((fn (car fns))) - (printf "<a name=\"footnote-~a\">" - (string-canonicalize - (container-ident fn))) - (printf "<sup><small>~a</small></sup></a>: " - (markup-option fn :number)) - (output (markup-body fn) e) - (display "\n<br>\n") - (loop (cdr fns))))) - (display "<div>"))))) - -;*---------------------------------------------------------------------*/ -;* html-title-authors ... */ -;*---------------------------------------------------------------------*/ -(define (html-title-authors authors e) - (define (html-authorsN authors cols first) - (define (make-row authors . opt) - (tr (map (lambda (v) - (apply td :align 'center :valign 'top v opt)) - authors))) - (define (make-rows authors) - (let loop ((authors authors) - (rows '()) - (row '()) - (cnum 0)) - (cond - ((null? authors) - (reverse! (cons (make-row (reverse! row)) rows))) - ((= cnum cols) - (loop authors - (cons (make-row (reverse! row)) rows) - '() - 0)) - (else - (loop (cdr authors) - rows - (cons (car authors) row) - (+ cnum 1)))))) - (output (table :cellpadding 10 - (if first - (cons (make-row (list (car authors)) :colspan cols) - (make-rows (cdr authors))) - (make-rows authors))) - e)) - (cond - ((pair? authors) - (display "<center>\n") - (let ((len (length authors))) - (case len - ((1) - (output (car authors) e)) - ((2 3) - (html-authorsN authors len #f)) - ((4) - (html-authorsN authors 2 #f)) - (else - (html-authorsN authors 3 #t)))) - (display "</center>\n")) - (else - (html-title-authors (list authors) e)))) - -;*---------------------------------------------------------------------*/ -;* document-sui ... */ -;*---------------------------------------------------------------------*/ -(define (document-sui n e) - (define (sui) - (display "(sui \"") - (skribe-eval (markup-option n :title) html-title-engine) - (display "\"\n") - (printf " :file ~s\n" (sui-referenced-file n e)) - (sui-marks n e) - (sui-blocks 'chapter n e) - (sui-blocks 'section n e) - (sui-blocks 'subsection n e) - (sui-blocks 'subsubsection n e) - (display " )\n")) - (if (string? *skribe-dest*) - (let ((f (format "~a.sui" (prefix *skribe-dest*)))) - (with-output-to-file f sui)) - (sui))) - -;*---------------------------------------------------------------------*/ -;* sui-referenced-file ... */ -;*---------------------------------------------------------------------*/ -(define (sui-referenced-file n e) - (let ((file (html-file n e))) - (if (member (suffix file) '("skb" "sui" "skr" "html")) - (string-append (strip-ref-base (prefix file)) ".html") - file))) - -;*---------------------------------------------------------------------*/ -;* sui-marks ... */ -;*---------------------------------------------------------------------*/ -(define (sui-marks n e) - (printf " (marks") - (for-each (lambda (m) - (printf "\n (~s" (markup-ident m)) - (printf " :file ~s" (sui-referenced-file m e)) - (printf " :mark ~s" (markup-ident m)) - (when (markup-class m) - (printf " :class ~s" (markup-class m))) - (display ")")) - (search-down (lambda (n) (is-markup? n 'mark)) n)) - (display ")\n")) - -;*---------------------------------------------------------------------*/ -;* sui-blocks ... */ -;*---------------------------------------------------------------------*/ -(define (sui-blocks kind n e) - (printf " (~as" kind) - (for-each (lambda (chap) - (display "\n (\"") - (skribe-eval (markup-option chap :title) html-title-engine) - (printf "\" :file ~s" (sui-referenced-file chap e)) - (printf " :mark ~s" (markup-ident chap)) - (when (markup-class chap) - (printf " :class ~s" (markup-class chap))) - (display ")")) - (container-search-down (lambda (n) (is-markup? n kind)) n)) - (display ")\n")) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (display "<table") - (html-class n) - (display "><tbody>\n")) - :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)) - (nfn (engine-custom e 'author-font)) - (align (markup-option n :align))) - (define (row n) - (printf "<tr><td align=\"~a\">" align) - (output n e) - (display "</td></tr>")) - ;; name - (printf "<tr><td align=\"~a\">" align) - (if nfn - (printf "<font ~a>\n" nfn) - (display "<font size=\"+2\"><i>\n")) - (output name e) - (if nfn - (printf "</font>\n") - (display "</i></font>\n")) - (display "</td></tr>") - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url)))) - :after "</tbody></table>") - -;*---------------------------------------------------------------------*/ -;* 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) - (display "<table") - (html-class n) - (display "><tbody>\n<tr>")) - :action (lambda (n e) - (let ((photo (markup-option n :photo))) - (display "<td>") - (output photo e) - (display "</td><td>") - (markup-option-add! n :photo #f) - (output n e) - (markup-option-add! n :photo photo) - (display "</td>"))) - :after "</tr>\n</tbody></table>") - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'toc - :options 'all - :action (lambda (n e) - (define (col n) - (let loop ((i 0)) - (if (< i n) - (begin - (display "<td></td>") - (loop (+ i 1)))))) - (define (toc-entry fe level) - (let* ((c (car fe)) - (ch (cdr fe)) - (t (markup-option c :title)) - (id (markup-ident c)) - (f (html-file c e))) - (unless (string? id) - (skribe-error 'toc - (format "Illegal identifier `~a'" id) - c)) - (display " <tr>") - ;; blank columns - (col level) - ;; number - (printf "<td valign=\"top\" align=\"left\">~a</td>" - (html-container-number c e)) - ;; title - (printf "<td colspan=\"~a\" width=\"100%\">" - (- 4 level)) - (printf "<a href=\"~a#~a\">" - (if (string=? f *skribe-dest*) - "" - (strip-ref-base (or f *skribe-dest* ""))) - (string-canonicalize id)) - (output (markup-option c :title) e) - (display "</a></td>") - (display "</tr>\n") - ;; the children - (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) - (define (symbol->keyword s) - (cond-expand - (stklos - (make-keyword s)) - (bigloo - (string->keyword (string-append ":" (symbol->string s)))))) - (let* ((c (markup-option n :chapter)) - (s (markup-option n :section)) - (ss (markup-option n :subsection)) - (sss (markup-option n :subsubsection)) - (b (markup-body n)) - (bb (if (handle? b) - (handle-ast b) - b))) - (if (not (container? bb)) - (error 'toc - "Illegal body (container expected)" - (if (markup? bb) - (markup-markup bb) - "???")) - (let ((lst (find-down (lambda (x) - (and (markup? x) - (markup-option x :toc) - (or (and sss (is-markup? x 'subsubsection)) - (and ss (is-markup? x 'subsection)) - (and s (is-markup? x 'section)) - (and c (is-markup? x 'chapter)) - (markup-option n (symbol->keyword - (markup-markup x)))))) - (container-body bb)))) - ;; avoid to produce an empty table - (unless (null? lst) - (display "<table cellspacing=\"1\" cellpadding=\"1\" width=\"100%\"") - (html-class n) - (display ">\n<tbody>\n") - - (for-each (lambda (n) (toc-entry n 0)) lst) - - (display "</tbody>\n</table>\n"))))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-document ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-document n title e) - (let* ((id (markup-ident n)) - (header (new markup - (markup '&html-chapter-header) - (ident (string-append id "-header")) - (class (markup-class n)) - (parent n) - (body (html-browser-title n)))) - (head (new markup - (markup '&html-head) - (ident (string-append id "-head")) - (class (markup-class n)) - (parent n) - (body header))) - (ftnote (new markup - (markup '&html-footnotes) - (ident (string-append id "-footnote")) - (class (markup-class n)) - (parent n) - (body (reverse! - (container-env-get n 'footnote-env))))) - (page (new markup - (markup '&html-page) - (ident (string-append id "-page")) - (class (markup-class n)) - (parent n) - (body (list (markup-body n) ftnote)))) - (ending (new markup - (markup '&html-ending) - (ident (string-append id "-ending")) - (class (markup-class n)) - (parent n) - (body (or (markup-option n :ending) - (let ((p (ast-document n))) - (and p (markup-option p :ending))))))) - (body (new markup - (markup '&html-body) - (ident (string-append id "-body")) - (class (markup-class n)) - (parent n) - (body (list title page ending)))) - (html (new markup - (markup '&html-html) - (ident (string-append id "-html")) - (class (markup-class n)) - (parent n) - (body (list head body))))) - ;; No file must be opened for documents. These files are - ;; directly opened by Skribe - (if (document? n) - (output html e) - (with-output-to-file (html-file n e) - (lambda () - (output html e)))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-subdocument ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-subdocument n e) - (let* ((p (ast-document n)) - (id (markup-ident n)) - (ti (let* ((nb (html-container-number n e)) - (tc (markup-option n :title)) - (ti (if (document? p) - (list (markup-option p :title) - (engine-custom e 'file-title-separator) - tc) - tc)) - (sep (engine-custom - e - (symbol-append (markup-markup n) - '-title-number-separator))) - (nti (and tc - (if (and nb (not (equal? nb ""))) - (list nb - (if (unspecified? sep) ". " sep) - ti) - ti)))) - (new markup - (markup (symbol-append '&html- (markup-markup n) '-title)) - (ident (string-append id "-title")) - (parent n) - (options '((author ()))) - (body nti))))) - (case (markup-markup n) - ((chapter) - (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id)) - ((section) - (skribe-message " [~s section: ~a]\n" (engine-ident e) id))) - (&html-generic-document n ti e))) - -;*---------------------------------------------------------------------*/ -;* chapter ... @label chapter@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'chapter - :options '(:title :number :file :toc :html-title :env) - :before (lambda (n e) - (let ((title (markup-option n :title)) - (ident (markup-ident n))) - (display "<!-- ") - (output title html-title-engine) - (display " -->\n") - (display "<a name=\"") - (display (string-canonicalize ident)) - (display "\"></a>\n") - (display "<center><h1") - (html-class n) - (display ">") - (output (html-container-number n e) e) - (display " ") - (output (markup-option n :title) e) - (display "</h1></center>"))) - :after "<br>") - -;; This writer is invoked only for chapters rendered inside separate files! -(markup-writer 'chapter - :options '(:title :number :file :toc :html-title :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'chapter-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* html-section-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-section-title n e) - (let* ((title (markup-option n :title)) - (number (markup-option n :number)) - (c (markup-class n)) - (ident (markup-ident n)) - (kind (markup-markup n)) - (tbg (engine-custom e (symbol-append kind '-title-background))) - (tfg (engine-custom e (symbol-append kind '-title-foreground))) - (tstart (engine-custom e (symbol-append kind '-title-start))) - (tstop (engine-custom e (symbol-append kind '-title-stop))) - (nsep (engine-custom e (symbol-append kind '-title-number-separator)))) - ;; the section header - (display "<!-- ") - (output title html-title-engine) - (display " -->\n") - (display "<a name=\"") - (display (string-canonicalize ident)) - (display "\"></a>\n") - (if c - (printf "<div class=\"~a-atitle\">" c) - (printf "<div class=\"skribe~atitle\">" (markup-markup n))) - (when (html-color-spec? tbg) - (display "<table width=\"100%\">") - (printf "<tr><td bgcolor=\"~a\">" tbg)) - (display tstart) - (if tfg (printf "<font color=\"~a\">" tfg)) - (if number - (begin - (output (html-container-number n e) e) - (output nsep e))) - (output title e) - (if tfg (display "</font>\n")) - (display tstop) - (when (and (string? tbg) (> (string-length tbg) 0)) - (display "</td></tr></table>\n")) - (display "</div>") - (display "<div") - (html-class n) - (display ">")) - (newline)) - -;*---------------------------------------------------------------------*/ -;* section ... @label section@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :before html-section-title - :after "</div><br>\n") - -;; on-file section writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'section-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* subsection ... @label subsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsection - :options '(:title :html-title :number :toc :env :file) - :before html-section-title - :after "</div>\n") - -;; on-file subsection writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'subsection-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... @label subsubsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsubsection - :options '(:title :html-title :number :toc :env :file) - :before html-section-title - :after "</div>\n") - -;; on-file subsection writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'subsubsection-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'paragraph - :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>" - (ast-location n))) - ((html-markup-class "p") n e)) - :after "</p>") - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'footnote - :options '(:number) - :action (lambda (n e) - (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>" - (string-canonicalize (container-ident n)) - (markup-option n :number)))) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak - :before (lambda (n e) - (display "<br") - (html-class n) - (display "/>"))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'hrule - :options '(:width :height) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (height (markup-option n :height))) - (display "<hr") - (html-class n) - (if (< width 100) - (printf " width=\"~a\"" (html-width width))) - (if (> height 1) - (printf " size=\"~a\"" height)) - (display ">")))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'color - :options '(:bg :fg :width :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg))) - (when (html-color-spec? bg) - (display "<table cellspacing=\"0\"") - (html-class n) - (printf " cellpadding=\"~a\"" (if m m 0)) - (if w (printf " width=\"~a\"" (html-width w))) - (display "><tbody>\n<tr>") - (display "<td bgcolor=\"") - (output bg e) - (display "\">")) - (when (html-color-spec? fg) - (display "<font color=\"") - (output fg e) - (display "\">")))) - :after (lambda (n e) - (when (html-color-spec? (markup-option n :fg)) - (display "</font>")) - (when (html-color-spec? (markup-option n :bg)) - (display "</td></tr>\n</tbody></table>")))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'frame - :options '(:width :margin :border) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (b (markup-option n :border)) - (w (markup-option n :width))) - (display "<table cellspacing=\"0\"") - (html-class n) - (printf " cellpadding=\"~a\"" (if m m 0)) - (printf " border=\"~a\"" (if b b 0)) - (if w (printf " width=\"~a\"" (html-width w))) - (display "><tbody>\n<tr><td>"))) - :after "</td></tr>\n</tbody></table>") - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'font - :options '(:size :face) - :before (lambda (n e) - (let ((size (markup-option n :size)) - (face (markup-option n :face))) - (when (and (number? size) (inexact? size)) - (let ((s (if (> size 0) "<big>" "<small>")) - (d (if (> size 0) 1 -1))) - (do ((i (inexact->exact size) (- i d))) - ((= i 0)) - (display s)))) - (when (or (and (number? size) (exact? size)) face) - (display "<font") - (html-class n) - (when (and (number? size) (exact? size) (not (= size 0))) - (printf " size=\"~a\"" size)) - (when face (printf " face=\"~a\"" face)) - (display ">")))) - :after (lambda (n e) - (let ((size (markup-option n :size)) - (face (markup-option n :face))) - (when (or (and (number? size) (exact? size) (not (= size 0))) - face) - (display "</font>")) - (when (and (number? size) (inexact? size)) - (let ((s (if (> size 0) "</big>" "</small>")) - (d (if (> size 0) 1 -1))) - (do ((i (inexact->exact size) (- i d))) - ((= i 0)) - (display s))))))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "<center") - (html-class n) - (display ">\n")) - ((left) - (display "<p style=\"text-align:left;\"") - (html-class n) - (display ">\n")) - ((right) - (display "<table ") - (html-class n) - (display "width=\"100%\" cellpadding=\"0\" cellspacing=\"0\" border=\"0\"><tr><td align=\"right\">")) - (else - (skribe-error 'flush - "Illegal side" - (markup-option n :side))))) - :after (lambda (n e) - (case (markup-option n :side) - ((center) - (display "</center>\n")) - ((right) - (display "</td></tr></table>\n")) - ((left) - (display "</p>\n"))))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before (html-markup-class "center") - :after "</center>\n") - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'pre :before (html-markup-class "pre") :after "</pre>\n") - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'prog - :options '(:line :mark) - :before (html-markup-class "pre") - :after "</pre>\n") - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'itemize - :options '(:symbol) - :before (html-markup-class "ul") - :action (lambda (n e) - (for-each (lambda (item) - (let ((ident (and (markup? item) - (markup-ident item)))) - (display "<li") - (html-class item) - (display ">") - (if ident ;; produce an anchor - (printf "\n<a name=\"~a\"></a>\n" - (string-canonicalize ident))) - (output item e) - (display "</li>\n"))) - (markup-body n))) - :after "</ul>") - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'enumerate - :options '(:symbol) - :before (html-markup-class "ol") - :action (lambda (n e) - (for-each (lambda (item) - (let ((ident (and (markup? item) - (markup-ident item)))) - (display "<li") - (html-class item) - (display ">") - (if ident ;; produce an anchor - (printf "\n<a name=\"~a\"></a>\n" ident)) - (output item e) - (display "</li>\n"))) - (markup-body n))) - :after "</ol>") - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'description - :options '(:symbol) - :before (html-markup-class "dl") - :action (lambda (n e) - (for-each (lambda (item) - (let ((k (markup-option item :key))) - (for-each (lambda (i) - (display " <dt") - (html-class i) - (display ">") - (output i e) - (display "</dt>")) - (if (pair? k) k (list k))) - (display "<dd") - (html-class item) - (display ">") - (output (markup-body item) e) - (display "</dd>\n"))) - (markup-body n))) - :after "</dl>") - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (if k - (begin - (display "<b") - (html-class n) - (display ">") - (output k e) - (display "</b> ")))) - (output (markup-body n) e))) - -;*---------------------------------------------------------------------*/ -;* blockquote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote - :options '() - :before (lambda (n e) - (display "<blockquote ") - (html-class n) - (display ">\n")) - :after "\n</blockquote>\n") - -;*---------------------------------------------------------------------*/ -;* figure ... @label figure@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'figure - :options '(:legend :number :multicolumns :legend-width) - :before (html-markup-class "br") - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend))) - (display "<a name=\"") - (display (string-canonicalize ident)) - (display "\"></a>\n") - (output (markup-body n) e) - (display "<br>\n") - (output (new markup - (markup '&html-figure-legend) - (parent n) - (ident (string-append ident "-legend")) - (class (markup-class n)) - (options `((:number ,number))) - (body legend)) - e))) - :after "<br>") - -;*---------------------------------------------------------------------*/ -;* &html-figure-legend ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-legend - :options '(:number) - :before (lambda (n e) - (display "<center>") - (let ((number (markup-option n :number)) - (legend (markup-option n :legend))) - (if number - (printf "<strong>Fig. ~a:</strong> " number) - (printf "<strong>Fig. :</strong> ")))) - :after "</center>") - -;*---------------------------------------------------------------------*/ -;* table ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'table - :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (cp (markup-option n :cellpadding)) - (cs (markup-option n :cellspacing))) - (display "<table") - (html-class n) - (if width (printf " width=\"~a\"" (html-width width))) - (if border (printf " border=\"~a\"" border)) - (if (and (number? cp) (>= cp 0)) - (printf " cellpadding=\"~a\"" cp)) - (if (and (number? cs) (>= cs 0)) - (printf " cellspacing=\"~a\"" cs)) - (cond - ((symbol? cstyle) - (printf " style=\"border-collapse: ~a;\"" cstyle)) - ((string? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) - ((number? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) - (if frame - (printf " frame=\"~a\"" - (if (eq? frame 'none) "void" frame))) - (if (and rules (not (eq? rules 'header))) - (printf " rules=\"~a\"" rules)) - (display "><tbody>\n"))) - :after "</tbody></table>\n") - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tr - :options '(:bg) - :before (lambda (n e) - (let ((bg (markup-option n :bg))) - (display "<tr") - (html-class n) - (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) - (display ">"))) - :after "</tr>\n") - -;*---------------------------------------------------------------------*/ -;* tc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tc - :options '(markup :width :align :valign :colspan :rowspan :bg) - :before (lambda (n e) - (let ((markup (or (markup-option n 'markup) 'td)) - (width (markup-option n :width)) - (align (markup-option n :align)) - (valign (let ((v (markup-option n :valign))) - (cond - ((or (eq? v 'center) - (equal? v "center")) - "middle") - (else - v)))) - (colspan (markup-option n :colspan)) - (rowspan (markup-option n :rowspan)) - (bg (markup-option n :bg))) - (printf "<~a" markup) - (html-class n) - (if width (printf " width=\"~a\"" (html-width width))) - (if align (printf " align=\"~a\"" align)) - (if valign (printf " valign=\"~a\"" valign)) - (if colspan (printf " colspan=\"~a\"" colspan)) - (if rowspan (printf " rowspan=\"~a\"" rowspan)) - (when (html-color-spec? bg) - (printf " bgcolor=\"~a\"" bg)) - (display ">"))) - :after (lambda (n e) - (let ((markup (or (markup-option n 'markup) 'td))) - (printf "</~a>" markup)))) - -;*---------------------------------------------------------------------*/ -;* image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'image - :options '(:file :url :width :height) - :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)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("gif" "jpg" "png")))))) - (if (not (string? img)) - (skribe-error 'html "Illegal image" file) - (begin - (printf "<img src=\"~a\" border=\"0\"" img) - (html-class n) - (if body - (begin - (display " alt=\"") - (output body e) - (display "\"")) - (printf " alt=\"~a\"" file)) - (if width (printf " width=\"~a\"" (html-width width))) - (if height (printf " height=\"~a\"" height)) - (display ">")))))) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'roman :before "") -(markup-writer 'bold :before (html-markup-class "strong") :after "</strong>") -(markup-writer 'underline :before (html-markup-class "u") :after "</u>") -(markup-writer 'strike :before (html-markup-class "strike") :after "</strike>") -(markup-writer 'emph :before (html-markup-class "em") :after "</em>") -(markup-writer 'kbd :before (html-markup-class "kbd") :after "</kbd>") -(markup-writer 'it :before (html-markup-class "em") :after "</em>") -(markup-writer 'tt :before (html-markup-class "tt") :after "</tt>") -(markup-writer 'code :before (html-markup-class "code") :after "</code>") -(markup-writer 'var :before (html-markup-class "var") :after "</var>") -(markup-writer 'samp :before (html-markup-class "samp") :after "</samp>") -(markup-writer 'sc :before "<span class=\"sc\">" :after "</span>") -(markup-writer 'sf :before "<span class=\"sf\">" :after "</span>") -(markup-writer 'sub :before (html-markup-class "sub") :after "</sub>") -(markup-writer 'sup :before (html-markup-class "sup") :after "</sup>") - -;*---------------------------------------------------------------------*/ -;* q ... @label q@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'q - :before "\"" - :after "\"") - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :action (lambda (n e) - (let ((text (markup-option n :text))) - (display "<a href=\"mailto:") - (output (markup-body n) e) - (display #\") - (html-class n) - (display #\>) - (if text - (output text e) - (skribe-eval (tt (markup-body n)) e)) - (display "</a>")))) - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :predicate (lambda (n e) - (and (engine-custom e 'javascript) - (or (string? (markup-body n)) - (and (pair? (markup-body n)) - (null? (cdr (markup-body n))) - (string? (car (markup-body n))))))) - :action (lambda (n e) - (let* ((body (markup-body n)) - (email (if (string? body) body (car body))) - (split (pregexp-split "@" email)) - (na (car split)) - (do (if (pair? (cdr split)) (cadr split) "")) - (nn (pregexp-replace* "[.]" na " ")) - (dd (pregexp-replace* "[.]" do " ")) - (text (markup-option n :text))) - (display "<script language=\"JavaScript\" type=\"text/javascript\"") - (if (not text) - (printf ">skribenospam( ~s, ~s, true )" nn dd) - (begin - (printf ">skribenospam( ~s, ~s, false )" nn dd) - (display "</script>") - (output text e) - (display "<script language=\"JavaScript\" type=\"text/javascript\">document.write(\"</\" + \"a>\")"))) - (display "</script>\n")))) - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mark - :before (lambda (n e) - (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) - (html-class n) - (display ">")) - :after "</a>") - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle) - :before (lambda (n e) - (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c)) - (f (html-file c e)) - (class (if (markup-class n) - (markup-class n) - "inbound"))) - (printf "<a href=\"~a#~a\" class=\"~a\"" - (if (string=? f *skribe-dest*) - "" - (strip-ref-base (or f *skribe-dest* ""))) - (string-canonicalize id) - class) - (display ">"))) - :action (lambda (n e) - (let ((t (markup-option n :text)) - (m (markup-option n 'mark)) - (f (markup-option n :figure)) - (c (markup-option n :chapter)) - (s (markup-option n :section)) - (ss (markup-option n :subsection)) - (sss (markup-option n :subsubsection))) - (cond - (t - (output t e)) - (f - (output (new markup - (markup '&html-figure-ref) - (body (markup-body n))) - e)) - ((or c s ss sss) - (output (new markup - (markup '&html-section-ref) - (body (markup-body n))) - e)) - - ((not m) - (output (new markup - (markup '&html-unmark-ref) - (body (markup-body n))) - e)) - (else - (display m))))) - :after "</a>") - -;*---------------------------------------------------------------------*/ -;* &html-figure-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (or (not (markup? c)) - (not (is-markup? c 'figure))) - (display "???") - (output (markup-option c :number) e))))) - -;*---------------------------------------------------------------------*/ -;* &html-section-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-section-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (not (markup? c)) - (display "???") - (output (markup-option c :title) e))))) - -;*---------------------------------------------------------------------*/ -;* &html-unmark-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-unmark-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (not (markup? c)) - (display "???") - (let ((t (markup-option c :title))) - (if t - (output t e) - (let ((l (markup-option c :legend))) - (if l - (output t e) - (display - (string-canonicalize - (markup-ident c))))))))))) - -;*---------------------------------------------------------------------*/ -;* bib-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref - :options '(:text :bib) - :before "[" - :action (lambda (n e) (output n e (markup-writer-get 'ref 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) - (output (car rs) e (markup-writer-get 'ref e)) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* url-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :before (lambda (n e) - (let* ((url (markup-option n :url)) - (class (cond - ((markup-class n) - (markup-class n)) - ((not (string? url)) - #f) - (else - (let ((l (string-length url))) - (let loop ((i 0)) - (cond - ((= i l) - #f) - ((char=? (string-ref url i) #\:) - (substring url 0 i)) - (else - (loop (+ i 1)))))))))) - (display "<a href=\"") - (output url html-title-engine) - (display "\"") - (when class (printf " class=\"~a\"" class)) - (display ">"))) - :action (lambda (n e) - (let ((v (markup-option n :text))) - (output (or v (markup-option n :url)) e))) - :after "</a>") - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :before (html-markup-class "i") - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (v (string->number (markup-option n :text)))) - (if (and (number? o) (number? v)) - (markup-option-add! n :text (+ o v))) - (output n e (markup-writer-get 'ref e)) - (if (and (number? o) (number? v)) - (markup-option-add! n :text v)))) - :after "</i>") - -;*---------------------------------------------------------------------*/ -;* page-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'page-ref - :options '(:mark :handle) - :action (lambda (n e) - (error 'page-ref:html "Not implemented yet" n))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before (lambda (n e) - (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) - (html-class n) - (display ">")) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-label base-engine))) - :after "</a>") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url (or (markup-option en 'url) - (markup-option en 'documenturl))) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - -;*---------------------------------------------------------------------*/ -;* &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)))) - -;*---------------------------------------------------------------------*/ -;* &the-index-header ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header - :action (lambda (n e) - (display "<center") - (html-class n) - (display ">") - (for-each (lambda (h) - (let ((f (engine-custom e 'index-header-font-size))) - (if f - (skribe-eval (font :size f (bold (it h))) e) - (output h e)) - (display " "))) - (markup-body n)) - (display "</center>") - (skribe-eval (linebreak 2) 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 (bold (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 'source-color) cc) - (color :fg cc n1) - 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)) - (bold 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)) diff --git a/skr/html4.skr b/skr/html4.skr deleted file mode 100644 index acb7068..0000000 --- a/skr/html4.skr +++ /dev/null @@ -1,165 +0,0 @@ -;;;; -;;;; html4.skr -- HTML 4.01 Engine -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 18-Feb-2004 11:58 (eg) -;;;; Last file update: 26-Feb-2004 21:09 (eg) -;;;; - -(define (find-children node) - (define (flat l) - (cond - ((null? l) l) - ((pair? l) (append (flat (car l)) - (flat (cdr l)))) - (else (list l)))) - - (if (markup? node) - (flat (markup-body node)) - node)) - -;;; ====================================================================== - -(let ((le (find-engine 'html))) - ;;---------------------------------------------------------------------- - ;; Customizations - ;;---------------------------------------------------------------------- - (engine-custom-set! le 'html-variant "html4") - (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401") - (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer") - - ;;---------------------------------------------------------------------- - ;; &html-html ... - ;;---------------------------------------------------------------------- - (markup-writer '&html-html le - :before "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> -<html>\n" - :after "</html>") - - ;;---------------------------------------------------------------------- - ;; &html-ending - ;;---------------------------------------------------------------------- - (let* ((img (engine-custom le 'html4-logo)) - (url (engine-custom le 'html4-validator)) - (bottom (list (hrule) - (table :width 100. - (tr - (td :align 'left - (font :size -1 [ - This ,(sc "Html") page has been produced by - ,(ref :url (skribe-url) :text "Skribe"). - ,(linebreak) - Last update ,(it (date)).])) - (td :align 'right :valign 'top - (ref :url url - :text (image :url img :width 88 :height 31)))))))) - (markup-writer '&html-ending le - :before "<div class=\"skribe-ending\">" - :action (lambda (n e) - (let ((body (markup-body n))) - (if body - (output body #t) - (skribe-eval bottom e)))) - :after "</div>\n")) - - ;;---------------------------------------------------------------------- - ;; color ... - ;;---------------------------------------------------------------------- - (markup-writer 'color le - :options '(:bg :fg :width :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg))) - (when bg - (display "<table cellspacing=\"0\"") - (html-class n) - (printf " cellpadding=\"~a\"" (if m m 0)) - (if w (printf " width=\"~a\"" (html-width w))) - (display "><tbody>\n<tr>") - (display "<td bgcolor=\"") - (output bg e) - (display "\">")) - (when fg - (display "<span style=\"color:") - (output fg e) - (display ";\">")))) - :after (lambda (n e) - (when (markup-option n :fg) - (display "</span>")) - (when (markup-option n :bg) - (display "</td></tr>\n</tbody></table>")))) - - ;;---------------------------------------------------------------------- - ;; font ... - ;;---------------------------------------------------------------------- - (markup-writer 'font le - :options '(:size :face) - :before (lambda (n e) - (let ((face (markup-option n :face)) - (size (let ((sz (markup-option n :size))) - (cond - ((or (unspecified? sz) (not sz)) - #f) - ((and (number? sz) (or (inexact? sz) (negative? sz))) - (format "~a%" - (+ 100 - (* 20 (inexact->exact (truncate sz)))))) - ((number? sz) - sz) - (else - (skribe-error 'font - (format "Illegal font size ~s" sz) - n)))))) - (display "<span ") - (html-class n) - (display "style=\"") - (if size (printf "font-size: ~a; " size)) - (if face (printf "font-family:'~a'; " face)) - (display "\">"))) - :after "</span>") - - ;;---------------------------------------------------------------------- - ;; paragraph ... - ;;---------------------------------------------------------------------- - (copy-markup-writer 'paragraph le - :validate (lambda (n e) - (let ((pred (lambda (x) - (and (container? x) - (not (memq (markup-markup x) '(font color))))))) - (not (any pred (find-children n)))))) - - ;;---------------------------------------------------------------------- - ;; roman ... - ;;---------------------------------------------------------------------- - (markup-writer 'roman le - :before "<span style=\"font-family: serif\">" - :after "</span>") - - ;;---------------------------------------------------------------------- - ;; table ... - ;;---------------------------------------------------------------------- - (let ((old-writer (markup-writer-get 'table le))) - (copy-markup-writer 'table le - :validate (lambda (n e) - (not (null? (markup-body n)))))) -) diff --git a/skr/latex-simple.skr b/skr/latex-simple.skr deleted file mode 100644 index dd2eccb..0000000 --- a/skr/latex-simple.skr +++ /dev/null @@ -1,101 +0,0 @@ -;;; -;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER -;;; CE FICHIER (sion simplifie il ne rest plus grand chose) -;;; Erick 27-10-04 -;;; - - -;*=====================================================================*/ -;* scmws04/src/latex-style.skr */ -;* ------------------------------------------------------------- */ -;* Author : Damien Ciabrini */ -;* Creation : Tue Aug 24 19:17:04 2004 */ -;* Last change : Thu Oct 28 21:45:25 2004 (eg) */ -;* Copyright : 2004 Damien Ciabrini, see LICENCE file */ -;* ------------------------------------------------------------- */ -;* Custom style for Latex... */ -;*=====================================================================*/ - -(let* ((le (find-engine 'latex)) - (oa (markup-writer-get 'author le))) - ; latex class & package for the workshop - (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}") - (engine-custom-set! le 'usepackage - "\\usepackage{epsfig} -\\usepackage{workshop} -\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.} - {September 22, 2004, Snowbird, Utah, USA.} -\\CopyrightYear{2004} -\\CopyrightHolder{Damien Ciabrini} -\\renewcommand{\\ttdefault}{cmtt} -") - (engine-custom-set! le 'image-format '("eps")) - (engine-custom-set! le 'source-define-color "#000080") - (engine-custom-set! le 'source-thread-color "#8080f0") - (engine-custom-set! le 'source-string-color "#000000") - - ; hyperref options - (engine-custom-set! le 'hyperref #t) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}") - ; nbsp with ~ char - (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding)) - - ; let latex process citations - (markup-writer 'bib-ref le - :options '(:text :bib) - :before "\\cite{" - :action (lambda (n e) (display (markup-option n :bib))) - :after "}") - (markup-writer 'bib-ref+ le - :options '(:text :bib) - :before "\\cite{" - :action (lambda (n e) - (let loop ((bibs (markup-option n :bib))) - (if (pair? bibs) - (begin - (display (car bibs)) - (if (pair? (cdr bibs)) (display ", ")) - (loop (cdr bibs)))))) - :after "}") - (markup-writer '&the-bibliography le - :action (lambda (n e) - (print "\\bibliographystyle{abbrv}") - (display "\\bibliography{biblio}"))) - - ; ACM-style for authors - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (if (pair? body) - (print "\\numberofauthors{" (length body) "}")) - (print "\\author{"))) - :after "}\n") - (markup-writer 'author le - :options (writer-options oa) - :before "" - :action (lambda (n e) - (let ((name (markup-option n :name)) - (affiliation (markup-option n :affiliation)) - (address (markup-option n :address)) - (email (markup-option n :email))) - (define (row pre n post) - (display pre) - (output n e) - (display post) - (display "\\\\\n")) - ;; name - (if name (row "\\alignauthor " name "")) - ;; affiliation - (if affiliation (row "\\affaddr{" affiliation "}")) - ;; address - (if (pair? address) - (for-each (lambda (x) - (row "\\affaddr{" x "}")) address)) - ;; email - (if email (row "\\email{" email "}")))) - :after "") -) - -(define (include-biblio) - (the-bibliography)) 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)) diff --git a/skr/xml.skr b/skr/xml.skr deleted file mode 100644 index 784b6f0..0000000 --- a/skr/xml.skr +++ /dev/null @@ -1,111 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/xml.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 09:46:09 2003 */ -;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Generic XML Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/xmle.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* xml-engine ... */ -;*---------------------------------------------------------------------*/ -(define xml-engine - ;; setup the xml engine - (default-engine-set! - (make-engine 'xml - :version 1.0 - :format "html" - :delegate (find-engine 'base) - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@")))))) - -;*---------------------------------------------------------------------*/ -;* markup ... */ -;*---------------------------------------------------------------------*/ -(let ((xml-margin 0)) - (define (make-margin) - (make-string xml-margin #\space)) - (define (xml-attribute? val) - (cond - ((or (string? val) (number? val) (boolean? val)) - #t) - ((list? val) - (every? xml-attribute? val)) - (else - #f))) - (define (xml-attribute att val) - (let ((s (keyword->string att))) - (printf " ~a=\"" (substring s 1 (string-length s))) - (let loop ((val val)) - (cond - ((or (string? val) (number? val)) - (display val)) - ((boolean? val) - (display (if val "true" "false"))) - ((pair? val) - (for-each loop val)) - (else - #f))) - (display #\"))) - (define (xml-option opt val e) - (let* ((m (make-margin)) - (ks (keyword->string opt)) - (s (substring ks 1 (string-length ks)))) - (printf "~a<~a>\n" m s) - (output val e) - (printf "~a</~a>\n" m s))) - (define (xml-options n e) - ;; display the true options - (let ((opts (filter (lambda (o) - (and (keyword? (car o)) - (not (xml-attribute? (cadr o))))) - (markup-options n)))) - (if (pair? opts) - (let ((m (make-margin))) - (display m) - (display "<options>\n") - (set! xml-margin (+ xml-margin 1)) - (for-each (lambda (o) - (xml-option (car o) (cadr o) e)) - opts) - (set! xml-margin (- xml-margin 1)) - (display m) - (display "</options>\n"))))) - (markup-writer #t - :options 'all - :before (lambda (n e) - (printf "~a<~a" (make-margin) (markup-markup n)) - ;; display the xml attributes - (for-each (lambda (o) - (if (and (keyword? (car o)) - (xml-attribute? (cadr o))) - (xml-attribute (car o) (cadr o)))) - (markup-options n)) - (set! xml-margin (+ xml-margin 1)) - (display ">\n")) - :action (lambda (n e) - ;; options - (xml-options n e) - ;; body - (output (markup-body n) e)) - :after (lambda (n e) - (printf "~a</~a>\n" (make-margin) (markup-markup n)) - (set! xml-margin (- xml-margin 1))))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) |